COBOL programs can use standard calling conventions. The following is an example of calling all IDMSIN01 functions from a COBOL program.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
**************************************************************
* The following is the 1st parameter on all IDMSIN01 calls
**************************************************************
01 RPB.
02 FILLER PIC X(36).
**************************************************************
* The following is the 2nd parameter on all IDMSIN01 calls
**************************************************************
01 REQ-WK.
02 REQUEST-CODE PIC S9(8) COMP.
88 IN01-FN-TRACE VALUE 00.
88 IN01-FN-NOTRACE VALUE 01.
88 IN01-FN-GETPROF VALUE 02.
88 IN01-FN-SETPROF VALUE 03.
88 IN01-FN-GETMSG VALUE 04.
88 IN01-FN-GETDATE VALUE 05.
88 IN01-FN-GETUSER VALUE 08.
88 IN01-FN-SYSCTL VALUE 10.
88 IN01-FN-TRINFO VALUE 16.
88 IN01-FN-TXNSON VALUE 28.
88 IN01-FN-TXNSOFF VALUE 29.
88 IN01-FN-RRSCTX VALUE 30.
88 IN01-FN-STRCONV VALUE 34.
88 IN01-FN-ENVINFO VALUE 36.
88 IN01-FN-FRMTDBK VALUE 40.
02 REQUEST-RETURN PIC S9(8) COMP.
**************************************************************
* The following work fields are used by a variety of
* IDMSIN01 calls
**************************************************************
01 WORK-FIELDS.
02 WK-DTS-FORMAT PIC S9(8) COMP VALUE 0.
02 LINE-CNT PIC S9(4) COMP.
02 WK-DTS PIC X(8).
02 WK-CDTS PIC X(26).
02 WK-KEYWD PIC X(8).
02 WK-VALUE PIC X(32).
02 WK-DBNAME PIC X(8).
02 WK-USERID PIC X(32).
02 WK-SYSCTL PIC X(8).
02 WK-TIME-INTERNAL PIC X(8).
02 WK-TIME-EXTERNAL PIC X(8).
02 WK-DATE-INTERNAL PIC X(8).
02 WK-DATE-EXTERNAL PIC X(10).
02 WK-RRS-FAKE-FUNCTION PIC S9(4) COMP.
88 IN01-FN-RRSCTX-GET VALUE 01.
88 IN01-FN-RRSCTX-SET VALUE 02.
02 WK-RRS-FUNCTION-REDEF REDEFINES WK-RRS-FAKE-FUNCTION.
03 WK-RRS-FAKE-FILLER PIC X.
03 WK-RRS-FUNCTION PIC X.
02 WK-RRS-CONTEXT PIC X(16).
02 WK-STRING-FUNCTION PIC X(4).
88 CONVERT-EBCDIC-TO-ASCII VALUE 'ETOA'.
88 CONVERT-ASCII-TO-EBCDIC VALUE 'ATOE'.
02 WK-STRING PIC X(17)
VALUE 'String to convert'.
02 WK-STRING-LENGTH PIC S9(8) COMP VALUE 17.
02 WK-DBKEY-OUTPUT PIC X(12).
**************************************************************
* The following group item is only used by the call that
* returns runtime environment information.
**************************************************************
01 EVBLOCK.
02 EV$SIZE PIC S9(4) COMP VALUE +31.
02 EV$MODE PIC X.
02 EV$TAPE# PIC X(6).
02 EV$REL# PIC X(6).
02 EV$SPACK PIC X(2).
02 EV$DMCL PIC X(8).
02 EV$NODE PIC X(8).
**************************************************************
* The following group item is only used by the call that
* retrieves SQL error messages
**************************************************************
01 SQLMSGB.
02 SQLMMAX PIC S9(8) COMP VALUE +6.
02 SQLMSIZE PIC S9(8) COMP VALUE +80.
02 SQLMCNT PIC S9(8) COMP.
02 SQLMLINE OCCURS 6 TIMES PIC X(80).
**************************************************************
* The following SQL include statement is needed only for
* the call that retrieves SQL error messages, and is only
* required if the program contains no other SQL statements.
**************************************************************
EXEC SQL
INCLUDE SQLCA
END-EXEC.
*********************************************************
PROCEDURE DIVISION.
*********************************************************
*********************************************************
* Call IDMSIN01 to deactivate the DML trace or SQL trace
* which was originally activated by the corresponding
* SYSIDMS parm (DMLTRACE=ON or SQLTRACE=ON).
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
*********************************************************
SET IN01-FN-NOTRACE TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK.
*********************************************************
* Call IDMSIN01 to request a 'GETPROF' to get the user
* profile default DBNAME, which was established by the
* SYSIDMS parm DBNAME=xxxxxxxx when running batch, or
* by the DCUF SET DBNAME xxxxxxxx when running under CV.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 8 byte GETPROF keyword.
* Parm 4 is the address of the 32 byte GETPROF returned value.
*********************************************************
SET IN01-FN-GETPROF TO TRUE.
MOVE 'DBNAME' TO WK-KEYWD
CALL 'IDMSIN01' USING RPB REQ-WK WK-KEYWD
WK-VALUE.
MOVE WK-VALUE TO WK-DBNAME.
IF WK-DBNAME = SPACES
DISPLAY 'DBNAME is set to BLANKS'
ELSE
DISPLAY 'DBNAME is set to ' WK-DBNAME.
*********************************************************
* Call IDMSIN01 to activate Transaction Sharing for this
* task.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
*********************************************************
SET IN01-FN-TXNSON TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK.
*********************************************************
* Call IDMSIN01 to deactivate Transaction Sharing for this
* task.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
*********************************************************
SET IN01-FN-TXNSOFF TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK.
*********************************************************
* Call IDMSIN01 to request a 'SETPROF' to set the user
* profile default SCHEMA to the value 'SYSTEM'.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 8 byte SETPROF keyword.
* Parm 4 is the address of the 32 byte SETPROF value.
*********************************************************
SET IN01-FN-SETPROF TO TRUE.
MOVE 'SCHEMA' TO WK-KEYWD
MOVE 'SYSTEM' TO WK-VALUE
CALL 'IDMSIN01' USING RPB REQ-WK WK-KEYWD
WK-VALUE.
IF REQUEST-RETURN NOT = 0
DISPLAY 'SETPROF returned error ' REQUEST-RETURN.
*********************************************************
* Call IDMSIN01 to request the current USERID established
* by the executed JCL information when running batch, or
* by the SIGNON USER xxxxxxxx when running under CV.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 32 byte USERID returned value.
*********************************************************
SET IN01-FN-GETUSER TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK WK-USERID.
IF WK-USERID = SPACES
DISPLAY 'USERID is set to BLANKS'
ELSE
DISPLAY 'USERID is set to ' WK-USERID.
*********************************************************
* Call IDMSIN01 to establish the SYSCTL DDNAME to be used
* when running a Batch/CV job.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 8 byte SYSCTL DDNAME passed.
*********************************************************
SET IN01-FN-SYSCTL TO TRUE.
MOVE 'SYSCTL73' TO WK-SYSCTL.
CALL 'IDMSIN01' USING RPB REQ-WK WK-SYSCTL.
******************************************************************
* Call IDMSIN01 to retrieve the current RRS context token.
* Uses an alternate method to set the function by using the
* SET statement, which allows exploiting the LEVEL 88 definitions.
******************************************************************
SET IN01-FN-RRSCTX TO TRUE.
SET IN01-FN-RRSCTX-GET TO TRUE.
CALL 'IDMSIN01' USING RPB,
REQ-WK,
WK-RRS-FUNCTION,
WK-RRS-CONTEXT.
******************************************************************
* Call IDMSIN01 to request string conversion from EBCDIC to ASCII.
******************************************************************
SET IN01-FN-STRCONV TO TRUE.
SET CONVERT-EBCDIC-TO-ASCII TO TRUE.
CALL 'IDMSIN01' USING RPB,
REQ-WK,
WK-STRING-FUNCTION,
WK-STRING,
WK-STRING-LENGTH.
******************************************************************
* Call IDMSIN01 to request string conversion from ASCII to EBCDIC.
******************************************************************
SET IN01-FN-STRCONV TO TRUE.
SET CONVERT-ASCII-TO-EBCDIC TO TRUE.
CALL 'IDMSIN01' USING RPB,
REQ-WK,
WK-STRING-FUNCTION,
WK-STRING,
WK-STRING-LENGTH.
*********************************************************
* Call IDMSIN01 to have an 8 byte internal DATETIME stamp
* returned as a displayable 26 character DATE/TIME display.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (0).
* Parm 4 is the address of the 8 byte internal DATETIME stamp.
* Parm 5 is the address of the 26 byte DATE/TIME returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 0 TO WK-DTS-FORMAT
MOVE 'UNKNOWN' TO WK-CDTS
CALL 'IDMSIN01' USING RPB REQ-WK
WK-DTS-FORMAT WK-DTS WK-CDTS.
DISPLAY 'THE DATE AND TIME IS --> ' WK-CDTS.
*********************************************************
* Call IDMSIN01 to have the current DATE and TIME
* returned as a displayable 26 character DATE/TIME display.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (1).
* Parm 4 is the address of the 26 byte DATE/TIME returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 1 TO WK-DTS-FORMAT
CALL 'IDMSIN01' USING RPB REQ-WK
WK-DTS-FORMAT WK-CDTS.
DISPLAY 'THE DATE AND TIME IS --> ' WK-CDTS.
*********************************************************
* Call IDMSIN01 to have a 26 byte external DATE/TIME display
* returned as an 8 byte DATETIME stamp.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (2).
* Parm 4 is the address of the 26 byte DATE/TIME.
* Parm 5 is the address of the 8 byte DATETIME stamp returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 2 TO WK-DTS-FORMAT
MOVE '1994-07-18-12.01.18.458382' TO WK-CDTS
CALL 'IDMSIN01' USING RPB REQ-WK
WK-DTS-FORMAT WK-CDTS WK-DTS.
*********************************************************
* Call IDMSIN01 to have a 8 byte external TIME display
* returned as an 8 byte TIME stamp.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (4).
* Parm 4 is the address of the 8 byte external TIME.
* Parm 5 is the address of the 8 byte TIME stamp returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 4 TO WK-DTS-FORMAT
MOVE '13.58.11' TO WK-TIME-EXTERNAL
CALL 'IDMSIN01' USING RPB REQ-WK WK-DTS-FORMAT
WK-TIME-EXTERNAL WK-TIME-INTERNAL.
*********************************************************
* Call IDMSIN01 to have an 8 byte internal TIME stamp
* returned as a displayable 8 character TIME display.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (3).
* Parm 4 is the address of the 8 byte internal TIME stamp.
* Parm 5 is the address of the 8 byte external TIME returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 3 TO WK-DTS-FORMAT
CALL 'IDMSIN01' USING RPB REQ-WK WK-DTS-FORMAT
WK-TIME-INTERNAL WK-TIME-EXTERNAL.
DISPLAY 'THE EXTERNAL TIME IS --> ' WK-TIME-EXTERNAL.
*********************************************************
* Call IDMSIN01 to have a 10 byte external DATE display
* returned as an 8 byte DATE stamp.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (6).
* Parm 4 is the address of the 10 byte external DATE.
* Parm 5 is the address of the 8 byte DATE stamp returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 6 TO WK-DTS-FORMAT
MOVE '2003-03-10' TO WK-DATE-EXTERNAL
CALL 'IDMSIN01' USING RPB REQ-WK WK-DTS-FORMAT
WK-DATE-EXTERNAL WK-DATE-INTERNAL.
*********************************************************
* Call IDMSIN01 to have an 8 byte internal DATE stamp
* returned as a displayable 10 character DATE display.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the 4 byte format indicator (5).
* Parm 4 is the address of the 8 byte internal DATE stamp.
* Parm 5 is the address of the 10 byte external DATE returned.
*********************************************************
SET IN01-FN-GETDATE TO TRUE.
MOVE 5 TO WK-DTS-FORMAT
CALL 'IDMSIN01' USING RPB REQ-WK WK-DTS-FORMAT
WK-DATE-INTERNAL WK-DATE-EXTERNAL.
DISPLAY 'THE EXTERNAL DATE IS --> ' WK-DATE-EXTERNAL.
*********************************************************
* Call IDMSIN01 to retrieve SQL error messages into a user
* buffer that will then be displayed back to the user.
* Whats passed is the SQLCA block and a message control
* block consisting of the following fields:
*
* - Maximum number of lines in user buffer.
* - The size (width) of one line in the user buffer.
* - The actual number of lines returned from IDMSIN01.
* - The user buffer where the message lines are returned.
*
* A return code of 4 means that there were no SQL error messages.
* A return code of 8 means that there were more SQL error lines
* in the SQLCA than could fit into the user buffer, meaning
* truncation has occurred.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the SQLCA block.
* Parm 4 is the address of the message control block.
*********************************************************
SET IN01-FN-GETMSG TO TRUE.
CALL 'IDMSIN01' USING RPB, REQ-WK,
SQLCA, SQLMSGB.
IF REQUEST-RETURN NOT = 4
MOVE 1 TO LINE-CNT
PERFORM DISP-MSG UNTIL LINE-CNT > SQLMCNT.
DISP-MSG SECTION.
DISPLAY SQLMLINE (LINE-CNT).
ADD 1 TO LINE-CNT.
*********************************************************
* Call IDMSIN01 to reactivate the DML trace or SQL trace
* which was originally activated by the corresponding
* SYSIDMS parm (DMLTRACE=ON or SQLTRACE=ON), that has
* been previously deactivated earlier on in this job.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
*********************************************************
SET IN01-FN-TRACE TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK.
*********************************************************
* Call IDMSIN01 to request that it return runtime
* environment information.
*
* Parm 1 is the address of the RPB.
* Parm 2 is the address of the REQUEST-CODE and RETURN-CODE.
* Parm 3 is the address of the ENVINFO return area.
*********************************************************
SET IN01-FN-ENVINFO TO TRUE.
CALL 'IDMSIN01' USING RPB REQ-WK EVBLOCK.
DISPLAY 'Runtime mode is ' EV$MODE.
DISPLAY 'CA IDMS tape volser is ' EV$TAPE#.
DISPLAY 'CA IDMS release number is ' EV$REL#.
DISPLAY 'CA IDMS service pack number is ' EV$SPACK.
DISPLAY 'DMCL name is ' EV$DMCL.
DISPLAY 'System node name is ' EV$NODE.
*********************************************************
* Call IDMSIN01 to format dbkey stored in SUBSCHEMA-CTRL
*********************************************************
SET IN01-FN-FRMTDBK TO TRUE.
CALL 'IDMSIN01' USING RPB,
REQ-WK,
DBKEY,
PAGE-INFO-DBK-FORMAT,
WK-DBKEY-OUTPUT.
DISPLAY ‘DBKEY = ‘ WK-DBKEY-OUTPUT.
|
Copyright © 2014 CA.
All rights reserved.
|
|