Calling IDMSIN01 from a PL/I Program

The following is an example of calling IDMSIN01 functions from a PL/I program:
idmscu19
The following is an example of calling IDMSIN01 functions from a PL/I program:
/* Declare IDMSIN01 entry */  DCL IDMSIN01 ENTRY OPTIONS(INTER,ASSEMBLER); /* Definition of IDMSIN01 variables: */ DCL 1 REQ_WK,      2 REQUEST_CODE   FIXED BINARY(31),      2 REQUEST_RETURN FIXED BINARY(31);    /* Definition of IDMSIN01 functions: */  DCL IN01_FN_TRACE    FIXED BINARY(31)  VALUE(00);  DCL IN01_FN_NOTRACE  FIXED BINARY(31)  VALUE(01);  DCL IN01_FN_GETPROF  FIXED BINARY(31)  VALUE(02);  DCL IN01_FN_SETPROF  FIXED BINARY(31)  VALUE(03);  DCL IN01_FN_GETMSG   FIXED BINARY(31)  VALUE(04);  DCL IN01_FN_GETDATE  FIXED BINARY(31)  VALUE(05);  DCL IN01_FN_GETUSER  FIXED BINARY(31)  VALUE(08);  DCL IN01_FN_SYSCTL   FIXED BINARY(31)  VALUE(10);  DCL IN01_FN_TRINFO   FIXED BINARY(31)  VALUE(16);  DCL IN01_FN_TXNSON   FIXED BINARY(31)  VALUE(28);  DCL IN01_FN_TXNSOFF  FIXED BINARY(31)  VALUE(29);  DCL IN01_FN_RRSCTX   FIXED BINARY(31)  VALUE(30);  DCL IN01_FN_STRCONV  FIXED BINARY(31)  VALUE(34);  DCL IN01_FN_ENVINFO  FIXED BINARY(31)  VALUE(36);  DCL IN01_FN_FRMTDBK  FIXED BINARY(31)  VALUE(40);    /* The following work fields are used by a variety of */  /* IDMSIN01 calls */  DCL 1 WORK_FIELDS,       2 WK_DTS_FORMAT      FIXED BINARY(31) INIT(0),       2 LINE_CNT           FIXED BINARY(31),       2 WK_DTS             CHAR(8),       2 WK_CDTS            CHAR(26),       2 WK_KEYWD           CHAR(8),       2 WK_VALUE           CHAR(32),       2 WK_DBNAME          CHAR(8),       2 WK_SYSCTL          CHAR(8),       2 WK_TIME_INTERNAL   CHAR(8),       2 WK_TIME_EXTERNAL   CHAR(8),       2 WK_DATE_INTERNAL   CHAR(8),       2 WK_DATE_EXTERNAL   CHAR(10),       2 WK_USERID          CHAR(32);       2 WK_DBKEY_OUTPUT    CHAR(12);    DCL 1 WK_RRS_FUNCTION     FIXED BINARY (7);    /* Definition of WK_RRS_FUNCTION functions: */    DCL  IN01_FN_RRSCTX_GET   FIXED BINARY (7)  VALUE (1);  DCL  IN01_FN_RRSCTX_SET   FIXED BINARY (7)  VALUE (2);      DCL 1 WK_RRS_CONTEXT      BIT (128);  DCL 1 WK_STRING_FUNCTION  CHAR (4);    /* Definition of WK_STRING_FUNCTION functions: */    DCL  CONVERT_EBCDIC_TO_ASCII  CHAR (4) VALUE ('ETOA');  DCL  CONVERT_ASCII_TO_EBCDIC  CHAR (4) VALUE ('ATOE');    DCL 1 WK_STRING           CHAR (17) INIT('String to convert');  DCL 1 WK_STRING_LENGTH    FIXED BINARY(31) INIT(17);    DCL 1 SNAP_TITLE,      3 SNAP_TITLE_TEXT CHAR (14) INIT (' PLIIN01 snap '),      3 SNAP_TITLE_END  CHAR (1)  INIT (' ');    /* **************************************************************** */  /* The following group item is only used by the call that           */  /* retrieves runtime environment information.                       */  /* **************************************************************** */    DCL 1 EVBLOCK,       2 EV$SIZE   FIXED BINARY(15) INIT(31),       2 EV$MODE   CHAR(1),       2 EV$TAPE#  CHAR(6),       2 EV$REL#   CHAR(6),       2 EV$SPACK  CHAR(2),       2 EV$DMCL   CHAR(8),       2 EV$NODE   CHAR(8);    /* **************************************************************** */  /* The following group item is only used by the call that           */  /* retrieves SQL error messages.                                    */  /* **************************************************************** */    DCL 1 SQLMSGB,       2 SQLMMAX  FIXED BINARY(31) INIT(6),       2 SQLMSIZE FIXED BINARY(31) INIT(80),       2 SQLMCNT  FIXED BINARY(31),       2 SQLMLINE (6) CHAR(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 ;  /* **************************************************************** */  /* BEGIN MAINLINE ...                                               */  /* **************************************************************** */    /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_NOTRACE;    CALL IDMSIN01 ( RPB,                    REQ_WK);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETPROF;    WK_KEYWD = 'DBNAME';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_KEYWD,                    WK_VALUE);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    WK_DBNAME = SUBSTR(WK_VALUE,1,8);  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_TXNSON;    CALL IDMSIN01 ( RPB,                    REQ_WK);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_TXNSOFF;    CALL IDMSIN01 ( RPB,                    REQ_WK);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_SETPROF;    WK_KEYWD = 'SCHEMA';    WK_VALUE = 'SYSTEM';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_KEYWD,                    WK_VALUE);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETUSER;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_USERID);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_SYSCTL;    WK_SYSCTL = 'SYSCTL73';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_SYSCTL);  /*       ****************************************************************       * Call IDMSIN01 to retrieve the current RRS context token.       * Note: this call requires an operating mode of IDMS_DC       * Note: use of SNAP requires an operating mode of IDMS_DC       ****************************************************************  */    REQUEST_CODE = IN01_FN_RRSCTX;    WK_RRS_FUNCTION = IN01_FN_RRSCTX_GET;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_RRS_FUNCTION,                    WK_RRS_CONTEXT);    IF (REQUEST_RETURN = 0)    THEN      SNAP TITLE (SNAP_TITLE)           FROM (WK_RRS_CONTEXT) LENGTH (16);    ELSE      IF (REQUEST_RETURN = 4)      THEN        DISPLAY ('No RRS context active yet.');      ELSE GO TO IN01_ERROR;  /*       ****************************************************************       * Call IDMSIN01 to convert WK_STRING from EBCDIC to ASCII.       * Note: use of SNAP requires an operating mode of IDMS_DC       ****************************************************************  */    REQUEST_CODE = IN01_FN_STRCONV;    WK_STRING_FUNCTION = CONVERT_EBCDIC_TO_ASCII;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_STRING_FUNCTION,                    WK_STRING,                    WK_STRING_LENGTH);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    SNAP TITLE (SNAP_TITLE)         FROM (WK_STRING) LENGTH (WK_STRING_LENGTH);  /*       ****************************************************************       * Call IDMSIN01 to convert WK_STRING from ASCII to EBCDIC.       ****************************************************************  */    REQUEST_CODE = IN01_FN_STRCONV;    WK_STRING_FUNCTION = CONVERT_ASCII_TO_EBCDIC;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_STRING_FUNCTION,                    WK_STRING,                    WK_STRING_LENGTH);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 0;    WK_CDTS = 'UNKNOWN';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_DTS,                    WK_CDTS);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 1;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_CDTS);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 2;    WK_CDTS = '1994-07-18-12.01.18.458382';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_CDTS,                    WK_DTS);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 4;    WK_TIME_EXTERNAL = '13.58.11';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_TIME_EXTERNAL,                    WK_TIME_INTERNAL);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 3;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_TIME_INTERNAL,                    WK_TIME_EXTERNAL);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 6;    WK_DATE_EXTERNAL = '2003-03-10';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_DATE_EXTERNAL,                    WK_DATE_INTERNAL);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 5;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_DATE_INTERNAL,                    WK_DATE_EXTERNAL);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    DISPLAY ('THE EXTERNAL DATE IS --> ' || WK_DATE_EXTERNAL); /*       ****************************************************************       *  Call IDMSIN01 to have an 8 byte internal DATETIME stamp       *  converted from UTC to local 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 (0).       *    Parm 4 is the address of the 8 byte internal       *              UTC formatted DATETIME stamp.       *    Parm 5 is the address of the 26 byte local       *              DATE/TIME returned.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETDATE;    WK_DTS_FORMAT = 7;    WK_CDTS = 'UNKNOWN';    CALL IDMSIN01 ( RPB,                    REQ_WK,                    WK_DTS_FORMAT,                    WK_DTS,                    WK_CDTS);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    DISPLAY ('THE LOCAL DATE AND TIME IS --> ' || WK_CDTS);  /*       ****************************************************************       * 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_GETMSG;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    SQLCA,                    SQLMSGB);    IF (REQUEST_RETURN = 4)    THEN      DO;      DISPLAY ('No SQL error message');      END;    ELSE      IF ((REQUEST_RETURN = 0) | (REQUEST_RETURN = 8))      THEN        DO LINE_CNT=1 TO SQLMCNT;          DISPLAY (SQLMLINE(LINE_CNT));        END;      ELSE GO TO IN01_ERROR;  /*       ****************************************************************       * 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 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.       ****************************************************************  */    REQUEST_CODE = IN01_FN_TRACE;    CALL IDMSIN01 ( RPB,                    REQ_WK);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    /*       ****************************************************************       * Call IDMSIN01 to retrieve the 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 runtime environment returned       * information.       ****************************************************************  */    REQUEST_CODE = IN01_FN_ENVINFO;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    EVBLOCK);    IF (REQUEST_RETURN ¬= 0) THEN GO TO IN01_ERROR;    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.       *       * 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 DBKEY.       * Parm 4 is the address of the database-key format.       * Parm 5 is the address of output field for formatted dbkey.       ****************************************************************  */        REQUEST_CODE = IN01_FN_FRMTDBK;    CALL IDMSIN01 ( RPB,                    REQ_WK,                    DBKEY,                    PAGE_INFO_DBK_FORMAT,                    WK_DBKEY_OUTPUT);      RETURN;    IN01_ERROR:     DISPLAY ('IDMSIN01 function' || REQUEST_CODE);     DISPLAY ('IDMSIN01 return code ' || REQUEST_RETURN);    RETURN;