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 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;
|
Copyright © 2014 CA.
All rights reserved.
|
|