Re: Max integer in an 8 byte COMP field?

In IDMS, we have dbkeys that are larger than what CoBOL recognizes. So
I have the following program to convert them:

IDENTIFICATION DIVISION.
PROGRAM-ID. SISR084.
AUTHOR. HOWARD BRAZEE.
******************************************************************
* *
*REMARKS. CONVERTS DBKEY TO AND FROM DB-KEY: 04292500-005 *
* FORMAT *
* *
* EXAMPLE OF PROGRAM CALLING THIS CAN BE FOUND IN *
* UMSDEV.BRFIX.LIB(DBKEYJ) (JCL) *
* & UMSDEV.BRFIX.LIB(DBKEY) (COBOL) *
* *
* & UMS.PROD.SOURCE(SIPR724) (TEFG) *
* *
* IT CAN BE USED TO DISPLAY A DB-KEY IN A FORMAT THAT CAN *
* BE CUT AND PASTED INTO DBOL. *
* *
* THE DBOL-KEY CAN ALSO BE USED AS INPUT INTO THIS *
* ROUTINE - BUT IT HAS TO BE IN THE FORMAT OF *
* 05026000-014 *
* CUTTING AND PASTING THE KEY FROM DBOL MIGHT GIVE YOU *
* 5026000-14 *
* ADD THE LEADING ZEROS IF THIS HAPPENS. *
* *
* THE PROGRAM UMSDEV.BRFIX.LIB(DBKEY) DOES THE FOLLOWING: *
* 1. IT READS A DB-KEY PASSED TO THE PROGRAM FROM *
* UMSDEV.BRFIX.LIB(DBKEYJ) IN THE FORMAT ABOVE. *
* 2. IT TRANSLATES THAT NUMBER INTO A DB-KEY *
* USING SISR084 *
* 3. IT OBTAINS THAT DATABASE RECORD USING THAT DBKEY *
* 4. IT DISPLAYS INFORMATION ABOUT THAT DATABASE RECORD. *
* 5. IT ACCEPTS THAT RECORD'S DB-KEY. *
* 6. IT TRANSLATES THAT DB-KEY INTO A DBOL-TYPE NUMBER *
* USING SISR084 *
* *
* *
* CODE EXTRACT *
* COPY IDMS RECORD GETDBKEY-DBCONV-RECORD *
* ... *
* MOVE LOW-VALUES TO GETDBKEY-DBCONV-X. *
* MOVE DBKEY TO GETDBKEY-DBCONV-DBKEY. *
* MOVE SPACES TO GETDBKEY-DBCONV-DISPLAY-DBKEY.
*
* CALL "SISR084" USING GETDBKEY-DBCONV-RECORD. *
* CALL "SISR084" USING DBKEY-DBCONV-DISPLAY-DBKEY. *
* DISPLAY 'DB-KEY ="' GETDBKEY-DBCONV-DISPLAY-DBKEY '"'. *
* OR *
* MOVE SPACES TO GETDBKEY-DBCONV-RECORD. *
* MOVE '04292500-005 TO DBKEY-DBCONV-DBKEY *
* CALL "SISR084" USING DBKEY-DBCONV-DISPLAY-DBKEY. *
* MOVE DBKEY-DBCONV-DBKEY TO DBREC-DBKEY. *
* *
* MOVE PASSED-DBKEY TO GETDBKEY-DBCONV-DISPLAY-DBKEY *
* MOVE ZERO TO GETDBKEY-DBCONV-DBKEY *
* DISPLAY 'DB-KEY =' GETDBKEY-DBCONV-DISPLAY-DBKEY. *
* CALL "SISR084" USING GETDBKEY-DBCONV-DISPLAY-DBKEY. *
* CALL "GETDBKEY" USING GETDBKEY-DBCONV-DISPLAY-DBKEY. *
* DISPLAY 'DB-KEY =' GETDBKEY-DBCONV-DBKEY. *
* COMPUTE GETDBKEY-DISPLAY = GETDBKEY-DBCONV-DBKEY. *
* DISPLAY 'DB-KEY =' GETDBKEY-DISPLAY. *
* DISPLAY 'GETDBKEY-DBCONV-X =' GETDBKEY-DBCONV-X. *
* OBTAIN DB-KEY IS GETDBKEY-DBCONV-DBKEY *
* ON ANY-ERROR-STATUS *
* CONTINUE. *
* DISPLAY 'PROGRAM NAME ------ ' PROGRAM-NAME. *
* DISPLAY 'ERROR STATUS ------ ' ERROR-STATUS. *
* DISPLAY 'ERROR RECORD ------ ' ERROR-RECORD. *
* DISPLAY 'ERROR SET --------- ' ERROR-SET. *
* DISPLAY 'ERROR AREA -------- ' ERROR-AREA. *
* DISPLAY 'LAST GOOD RECORD -- ' RECORD-NAME. *
* DISPLAY 'LAST GOOD AREA ---- ' AREA-NAME. *
* DISPLAY 'DML SEQUENCE ------ ' DML-SEQUENCE. *
* *
* MOVE LOW-VALUES TO GETDBKEY-DBCONV-X. *
* ACCEPT GETDBKEY-DBCONV-DBKEY FROM CURRENCY. *
* *
* CALL "SISR084" USING GETDBKEY-DBCONV-DISPLAY-DBKEY. *
* DISPLAY 'DB-KEY =' GETDBKEY-DBCONV-DBKEY. *
* DISPLAY 'GETDBKEY-DBCONV-DISPLAY-DBKEY="' *
* GETDBKEY-DBCONV-DISPLAY-DBKEY '"'. *
* *
******************************************************************
ENVIRONMENT DIVISION.

CONFIGURATION SECTION.
SOURCE-COMPUTER.
** IBM-390 WITH DEBUGGING MODE.
IBM-390.

DATA DIVISION.
WORKING-STORAGE SECTION.


01 HOLD-KEYS.
05 HOLD-DBKEY PIC S9(16) COMP.
05 HOLD-DBKEY-A REDEFINES HOLD-DBKEY PIC X(8).
/
LINKAGE SECTION.

COPY IDMS RECORD PASSED-DBCONV-RECORD.

01 DBKEY-DBCONV-DISPLAY PIC -9(15).

PROCEDURE DIVISION USING PASSED-DBCONV-RECORD.

000-MAIN.

IF PASSED-DBCONV-PAGE IS NUMERIC
AND PASSED-DBCONV-POS IS NUMERIC
PERFORM 200-DISPLAY-TO-KEY
ELSE
PERFORM 100-KEY-TO-DISPLAY
END-IF.
GOBACK.

100-KEY-TO-DISPLAY.
MOVE '-' TO PASSED-DBCONV-DASH
MOVE PASSED-DBCONV-X TO HOLD-KEYS
IF HOLD-DBKEY > ZERO
CONTINUE
ELSE
MOVE ZERO TO HOLD-DBKEY
END-IF.
DIVIDE HOLD-DBKEY BY 256 GIVING PASSED-DBCONV-PAGE-N
REMAINDER PASSED-DBCONV-POS-N.

200-DISPLAY-TO-KEY.

COMPUTE HOLD-DBKEY = 256 * PASSED-DBCONV-PAGE-N
+ PASSED-DBCONV-POS-N.
MOVE HOLD-KEYS TO PASSED-DBCONV-X.

END PROGRAM SISR084.
.