Sample Data Capture exit routine
A Data Capture exit routine can receive control whenever a segment, for which the exit routine is defined, is updated.
This topic provides examples of the Data Capture exit routine in COBOL and PL/I. The exit routine can also be written in assembler or C.
Subsections:
COBOL
The following example is the Data Capture exit routine in COBOL.
IDENTIFICATION DIVISION.
PROGRAM-ID. DLICDCE.
*---------------------------------------------------------------*
*REMARKS. *
*---------------------------------------------------------------*
* DESCRIPTIVE NAME : HOSPITAL DATA BASE SEGMENT EXIT *
*---------------------------------------------------------------*
* THIS IS A SAMPLE IMS EXIT. THIS WILL BE CALLED BY IMS. *
* THIS PROGRAM PROPAGATES DATA FROM IMS TO DB2 SYNCHRONOUSLY.*
* THE NAME OF THIS PROGRAM LOAD MODULE IS SPECIFIED *
* ON SEGM MACRO DURING DBDGEN FOR THE HOSPITAL DATA BASE. *
* *
* THE DATA OPTIONS SELECTED FOR THIS EXIT : *
* EXIT=(KEY,DATA,NOPATH,CASCADE) *
*---------------------------------------------------------------*
* INPUT FOR THIS PROGRAM : XPCB, XSDB. *
* *
* OUTPUT: DISPLAY A MESSAGE WHEN THE IMS UPDATE IS NOT *
* ISRT, REPL, DELE, CASC. DISPLAY 'SQLERRM' WHEN *
* SQLERROR OCCURS. *
* *
* UPDATES: UPDATES DB2 ILLNESS TABLE *
*---------------------------------------------------------------*
* LOGIC: THIS PROGRAM IS CALLED BY IMS AFTER THE IMS UPDATE*
* TO ILLNESS SEGMENT AND BEFORE IMS RETURNS TO THE *
* IMS APPLICATION PROGRAM. *
* *
* XPCB IS RECEIVED AS INPUT TO THIS PROGRAM. *
* IF THERE IS NO ADDRESS OF XSDB IN XPCB THIS *
* PROGRAM WILL RETURNS TO IMS OTHERWISE - *
* *
* LOGIC: THIS PROGRAM IS CALLED BY IMS AFTER THE IMS UPDATE*
* WE GET THE ADDRESS OF XSDB FROM XPCB, FROM XSDB *
* WE GET THE ADDRESS OF ILLNESS SEGMENT CONCATENATED*
* KEY, AND ADDRESS OF THE PHYSICAL SEGMENT DATA *
* *
* UPDATE THE DB2 ILLNESS TABLE WITH THE UPDATED IMS *
* SEGMENT DATA. *
* --------------------------------------------------------------*
INSTALLATION. IBM - SANTA TERESA LABORATORY.
DATE-WRITTEN. JANUARY 1990.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-3090.
OBJECT-COMPUTER. IBM-3090.
DATA DIVISION.
WORKING-STORAGE SECTION.
EXEC SQL
INCLUDE SQLCA
END-EXEC. *--- DB2 ILLNESS TABLE DECLARATION
EXEC SQL
DECLARE SYSADM.ILLNESS TABLE
(ILLDATE VARCHAR (6) NOT NULL,
PATNO VARCHAR (5) NOT NULL,
ILLNAME VARCHAR (10) NOT NULL)
END-EXEC.
*---
01 W-POINTER POINTER.
01 W-POINTER-R REDEFINES W-POINTER PIC 9(8) COMP.
LINKAGE SECTION.
*--- EXIT SEGMENT CONTROL BLOCK
01 XPCB.
05 EYECATCHER PIC X(04).
05 VERSION PIC X(02).
05 RELEASE-ID PIC X(02).
05 EXIT-NAME PIC X(08).
05 EXIT-RETURN-CODE PIC 9(04) COMP.
05 EXIT-REASON-CODE PIC 9(04) COMP.
05 DATABASE-NAME PIC X(08).
05 DBD-VERSION-PTR POINTER.
05 SEGMENT-NAME PIC X(08).
05 CALL-FUNCTION PIC X(04).
05 PHYSICAL-FUNCTION PIC X(04).
05 FILLER PIC 9(08) COMP.
05 DB-PCB-PTR POINTER.
05 DB-PCB-NAME PIC X(08).
05 INQY-OUTPUT-PTR POINTER.
05 IO-PCB-PTR POINTER.
05 ENVIRONMENT-FLAGS PIC X.
88 IMS-ENH-SUPPORT VALUE X'80'.
* RRS SUPPORT IS AVAILABLE IN SYSTEM
88 IMS-RRS-ENABLED VALUE X'40'.
* RRS=Y WAS SPECIFIED
88 CALL_AT_COMMIT VALUE X'20'.
* SET BY EXIT - CALL DURING COMMIT
88 XPCB_LOGX_FORMAT VALUE X'10'.
* REDUCED 9904 FORMAT
88 XPCB_EXIT_WAS_CALLED VALUE X'08'.
* INTERNAL FLAG USED BY IMS
88 XPCB_DPROP_EXIT VALUE X'04'.
* SET BY DPROP EXIT ROUTINE
05 FILLER PIC X.
* RESERVED
05 CONC-KEY-LENGTH PIC 9(04) COMP.
05 CONC-KEY-PTR POINTER.
05 DATA-XSDB-PTR POINTER.
05 BEFORE-XSDB-PTR POINTER.
05 PATH-XSDB-PTR POINTER.
05 FILLER POINTER.
05 FILLER POINTER.
05 FILLER POINTER.
05 EXIT-WORK-PTR POINTER.
05 NULL-PTR POINTER.
05 FILLER POINTER.
05 TIMESTAMP PIC X(08).
*--- EXIT SEGMENT DATA BLOCK
01 DATA-XSDB.
05 EYECATCHER PIC X(4).
05 VERSION PIC X(2).
05 RELEASE-ID PIC X(2).
05 NEXT-PTR POINTER.
05 DATABASE-NAME PIC X(8).
05 SEGMENT-NAME PIC X(8).
05 FILLER PIC X(4).
05 SEGMENT-LEVEL PIC 9(4) COMP.
05 KEY-LENGTH PIC 9(4) COMP.
05 KEY-PTR POINTER.
05 FILLER PIC 9(4) COMP.
05 SEGMENT-LENGTH PIC 9(4) COMP.
05 SEGMENT-DATA-PTR POINTER.
05 FILLER POINTER.
05 FILLER POINTER.
*--- ILLNESS SEGMENT DATA
01 LS-SEGMENT.
03 LS-ILLDATE PIC X(6).
03 LS-ILLNAME PIC X(10).
*--- ILLNESS SEGMENT CONCATENATED KEY
01 XPCB-CONCKEY.
02 LS-PATNO PIC X(5).
02 LS-ILLDT PIC X(6).
PROCEDURE DIVISION USING XPCB.
SET W-POINTER TO DATA-XSDB-PTR.
*--- LENGTH ZERO IF NOT CAPTURED
* IF W-POINTER-R EQUAL ZEROES GOBACK
* GOBACK
* END-IF
*----
SET ADDRESS OF DATA-XSDB TO DATA-XSDB-PTR.
SET ADDRESS OF XPCB-CONCKEY TO CONC-KEY-PTR.
SET ADDRESS OF LS-SEGMENT TO SEGMENT-DATA-PTR.
*----
EXEC SQL
WHENEVER SQLWARNING CONTINUE
END-EXEC
EXEC SQL
WHENEVER SQLERROR GO TO BADSQL
END-EXEC
EXEC SQL
WHENEVER NOT FOUND GO TO BADSQL
END-EXEC
*----
IF PHYSICAL-FUNCTION OF XPCB = "ISRT"
EXEC SQL
INSERT INTO SYSADM.ILLNESS
VALUES (::LS-ILLDATE,::LS-PATNO,
::LS-ILLNAME)
END-EXEC ELSE
IF PHYSICAL-FUNCTION OF XPCB = "CASC" OR
PHYSICAL-FUNCTION OF XPCB = "DLET"
EXEC SQL
DELETE FROM SYSADM.ILLNESS
WHERE (PATNO = ::LS-PATNO AND
ILLDATE = ::LS-ILLDATE)
END-EXEC
ELSE
IF PHYSICAL-FUNCTION OF XPCB = "REPL"
EXEC SQL
UPDATE SYSADM.ILLNESS
SET ILLNAME = ::LS-ILLNAME
WHERE (ILLDATE = ::LS-ILLDATE AND
PATNO = ::LS-PATNO)
END-EXEC
ELSE
DISPLAY "FUNCTION WASNT ISRT, REPL, DLET, OR CASC"
DISPLAY "--- NO SQL ACTION WAS TAKEN"
DISPLAY "PHYS FUNCTION IS "
DISPLAY PHYSICAL-FUNCTION OF XPCB
END-IF
END-IF
END-IF.
DISPLAY "SQLCODE " SQLCODE.
GOBACK.
BADSQL.
DISPLAY "SQLERRM".
MOVE 8 TO EXIT-RETURN-CODE OF XPCB.
MOVE SQLCODE TO EXIT-REASON-CODE OF XPCB.
GOBACK.PL/I
The following example is the Data Capture exit routine in PL/I.
DLI2DB2: PROCEDURE(XPCB_PTR) OPTIONS(MAIN);
/*
*---------------------------------------------------------------*
*REMARKS. *
*---------------------------------------------------------------*
* DESCRIPTIVE NAME : HOSPITAL DATA BASE SEGMENT EXIT *
*---------------------------------------------------------------*
* THIS IS A SAMPLE IMS EXIT THAT WILL BE CALLED BY IMS. *
* THIS PROGRAM PROPAGATES DATA FROM IMS TO DB2 SYNCHRONOUSLY.*
* THE NAME OF THIS PROGRAM LOAD MODULE IS SPECIFIED *
* ON SEGM MACRO DURING DBDGEN FOR THE HOSPITAL DATA BASE. *
* *
* THE DATA OPTIONS SELECTED FOR THIS EXIT ARE: *
* EXIT=(DLI2DB2,PATH,DATA,(CASCADE,PATH,DATA,NOKEY) *
*---------------------------------------------------------------*
* *
* INPUT FOR THIS PROGRAM : XPCB, XSDB. *
* *
* OUTPUT: DISPLAY 'SQLERRM' WHEN SQLERROR OCCURS. *
* UPDATES: UPDATES DB2 TREATMT TABLE *
* *
* : RETURNS REASON CODE 14 RETURN CODE 16 WHEN PATH *
* NOT SPECIFIED ON THE DBDGEN EXIT STATEMENT, *
* RESULTING IN AN ABEND U3314. *
* *
*---------------------------------------------------------------*
* LOGIC: THIS PROGRAM IS CALLED BY IMS AFTER AN UPDATE TO *
* THE TREATMT SEGMENT AND BEFORE IMS RETURNS TO *
* IMS APPLICATION PROGRAM. *
* *
* THE ADDRESS OF AN XPCB IS PASSED TO THIS PROGRAM *
* FROM IMS. THE XPCB WILL PROVIDE THE ADDRESSES OF *
* THE XSDB FOR DATA, PATH DATA AND BEFORE DATA. *
* *
* UPDATE THE DB2 TREATMT TABLE WITH THE UPDATED IMS *
* SEGMENT DATA. *
* *
* HOSPITAL *********** *
* DATA BASE * * *
* * PATIENT * KEY FIELD IS PATNO *
* * * *
* *********** *
* * *
* * *
* *********** *
* * * *
* * ILLNESS * KEY FIELD IS ILLDATE *
* * * *
* *********** *
* * *
* * *
* *********** KEY FIELD IS TRTDATE *
* * * FIELD, MEDICINE *
* * TREATMT * FIELD, QUANTITY *
* * * FIELD, DOCTOR (NOT IN DB2 TABLE) *
* *********** *
* *
* *
* TREATMENT TABLE *
* *
* *************************************************** *
* * PATNUMB * DATEILL * DATETRT * MEDICAT * AMOUNT * *
* *************************************************** *
* *
* --------------------------------------------------------------*
*/
/* *************************************************************** */
/* */
/* E X T E N D E D D A T A B A S E P C B -- X P C B */
/* */
/* **************************************************************** */
DECLARE
1 XPCB BASED(XPCB_PTR),
3 EYECATCHER CHAR(4), /* "XPCB" EYECATCHER */
3 VERSION CHAR(2), /* XPCB VERSION INDICATOR */
3 RELEASE CHAR(2), /* XPCB RELEASE INDICATOR */
3 EXIT_NAME CHAR(8), /* SEGMENT EXIT NAME */
3 EXIT_RETURN_CODE FIXED BINARY (15), /* RETURN CODE */
3 EXIT_REASON_CODE FIXED BINARY (15), /* REASON CODE */
3 ATABASE_NAME CHAR(8), /* PHYSICAL DATA BASE NAME */
3 DBD_VERSION_PTR POINTER, /* ADDRESS OF DBD VERSION ID */
3 SEGMENT_NAME CHAR(8), /* PHYSICAL SEGMENT NAME */
3 CALL_FUNCTION CHAR(4), /* CALL FUNCTION */
3 PHYSICAL_FUNCTION CHAR(4), /* DL/I PHYSICAL FUNCTION */
3 FILLER1 FIXED BINARY (31), /* RESERVED */
3 DB_PCB_PTR POINTER, /* ADDRESS OF DB PCB */
3 DB_PCB_NAME CHAR(8), /* NAME OF DB PCB */
3 INQY_OUTPUT_PTR POINTER, /* ADDRESS OF "INQY" OUTPUT */
3 IO_PCB_PTR POINTER, /* ADDRESS OF I/O PCB */
3 ENVIRONMENT-FLAGS CHAR(1), /* Environment Flags */
/* IMS-ENH-SUPPORT X'80' RRS SUPPORT AVAILABLE IN SYSTEM */
/* IMS-RRS-ENABLED X'40' RRS=Y WAS SPECIFIED */
/* CALL_AT_COMMIT X'20' SET BY EXIT-CALL DURING COMMIT */
/* XPCB_LOGX_FORMAT X'10' REDUCED 9904 FORMAT */
/* XPCB_EXIT_WAS_CALLED X'08' INTERNAL FLAG USED BY IMS */
/* XPCB_DPROP_EXIT X'04' SET BY DPROP EXIT ROUTINE */
3 NEWFILLER CHAR(1), /* Reserved */
3 CONC_KEY_LENGTH FIXED BINARY (15), /* LENGTH OF FULLY */
/* CONCATENATED KEY FOR SEGM */
3 CONC_KEY_PTR POINTER, /* ADDRESS OF PHYSICAL FULLY */
/* CONCATENATED KEY FOR SEGM */
3 DATA_XSDB_PTR POINTER, /* ADDRESS OF XSDB FOR */
/* PHYSICAL SEGMENT DATA */
3 BEFORE_XSDB_PTR POINTER, /* ADDRESS OF XSDB FOR */
/* PHYSICAL BEFORE DATA */
3 PATH_XSDB_PTR POINTER, /* ADDRESS OF XSDB FOR */
/* PHYSICAL PATH DATA */
3 FILLER3 POINTER, /* RESERVED */
3 FILLER4 POINTER, /* RESERVED */
3 FILLER5 POINTER, /* RESERVED */
3 EXIT_WORK_PTR POINTER, /* ADDRESS OF 256 BYTE AREA */
/* FOR THE EXIT */
3 NULL_PTR POINTER, /* NULL POINTER VALUE */
3 FILLER6 POINTER, /* RESERVED */
3 CALL_TIMESTAMP CHAR(8), /* TIMESTAMP OF CALL */
3 FILLER7 POINTER; /* RESERVED FOR NULLS AT END */
DECLARE XPCB_PTR POINTER;
/* **************************************************************** */
/* */
/* E X T E N D E D S E G M E N T D A T A -- X S D B */
/* */
/* **************************************************************** */
DECLARE
1 XSDB BASED(XSDB_PTR),
3 EYECATCHER CHAR(4), /* "XSDB" EYECATCHER */
3 VERSION CHAR(2), /* XSDB VERSION INDICATOR */
3 RELEASE CHAR(2), /* XSDB RELEASE INDICATOR */
3 NEXT_PTR POINTER, /* NEXT XSDB POINTER */
3 DATABASE_NAME CHAR(8), /* PHYSICAL DATA BASE NAME */
3 SEGMENT_NAME CHAR(8), /* PHYSICAL SEGMENT NAME */
3 FILLER1 CHAR(4), /* RESERVED */
3 SEGMENT_LEVEL FIXED BINARY (15), /* SEGMENT DATA BASE LEVEL */
3 KEY_LENGTH FIXED BINARY (15), /* LENGTH OF PHYSICAL KEY */
3 KEY_PTR POINTER, /* ADDRESS OF PHYSICAL KEY */
3 FILLER2 FIXED BINARY (15), /* RESERVED */
3 SEGMENT_LENGTH FIXED BINARY (15), /* LENGTH OF SEGMENT DATA */
3 SEGMENT_DATA_PTR POINTER, /* ADDRESS OF SEGMENT DATA */
3 FILLER3 POINTER, /* RESERVED */
3 FILLER4 POINTER, /* RESERVED */
3 FILLER5 POINTER; /* RESERVED FOR NULLS AT END */
DECLARE XSDB_PTR POINTER;
DECLARE
1 SEGMENT_XSDB LIKE XSDB BASED(XPCB.DATA_XSDB_PTR);
DECLARE /* TREATMENT SEGMENT */
1 SEGMENT_DATA BASED(SEGMENT_XSDB.SEGMENT_DATA_PTR),
3 SEGMENT_DATA_TRTDATE CHAR(6), /* SEGMENT KEY */
3 SEGMENT_DATA_MEDICINE CHAR(10),
3 SEGMENT_DATA_QUANTITY CHAR(4),
3 SEGMENT_DATA_DOCTOR CHAR(10);
DECLARE
1 BEFORE_XSDB LIKE XSDB BASED(XPCB.BEFORE_XSDB_PTR);
DECLARE /* BEFORE TREATMENT SEGMENT */
1 BEFORE_DATA BASED(BEFORE_XSDB.SEGMENT_DATA_PTR),
3 BEFORE_DATA_TRTDATE CHAR(6), /* SEGMENT KEY */
3 BEFORE_DATA_MEDICINE CHAR(10),
3 BEFORE_DATA_QUANTITY CHAR(4),
3 BEFORE_DATA_DOCTOR CHAR(10);
DECLARE
1 PATH_XSDB LIKE XSDB BASED(PATH_XSDB_PTR);
DECLARE /* PATIENT SEGMENT */
1 PATH_DATA BASED(PATH_XSDB.SEGMENT_DATA_PTR),
3 PATHSEG_PATNO CHAR(5), /* SEGMENT KEY */
3 PATHSEG_NAME CHAR(10),
3 PATHSEG_ADDR CHAR(30); DECLARE
1 PATH2_XSDB LIKE XSDB BASED(PATH2_XSDB_PTR);
DECLARE /* PATIENT SEGMENT */
1 PATH2_DATA BASED(PATH2_XSDB.SEGMENT_DATA_PTR),
3 PATH2SEG_ILLDATE CHAR(6), /* SEGMENT KEY */
3 PATH2SEG_ILLNAME CHAR(10);
DECLARE PATH2_XSDB_PTR POINTER;
DECLARE /* TREATMENT TABLE ROW */
1 TREATROW BASED(XPCB.EXIT_WORK_PTR),
3 COL_PATNUM CHAR(5), /* FROM LEVEL 1 KEY */
3 COL_ILLDATE CHAR(6), /* FROM LEVEL 2 KEY */
3 COL_TRTDATE CHAR(6), /* FROM LEVEL 3 KEY */
3 COL_MEDICINE CHAR(10), /* FROM LEVEL 3 */
3 COL_QUANTITY CHAR(4); /* FROM LEVEL 3 */
EXEC SQL
INCLUDE SQLCA;
/* - DB2 TREATMENT TABLE DECLARATION */
EXEC SQL
DECLARE SYSADM.TREATMNT TABLE
(PATNUMB VARCHAR (5) NOT NULL,
DATEILL VARCHAR (6) NOT NULL,
DATETRT VARCHAR (6) NOT NULL,
MEDICAT VARCHAR (10) NOT NULL,
AMOUNT VARCHAR (4) NOT NULL);
DECLARE /* CALL FUNCTIONS */
INSERT_FUNCTION CHAR(4) STATIC INIT('ISRT'),
DELETE_FUNCTION CHAR(4) STATIC INIT('DLET'),
REPLACE_FUNCTION CHAR(4) STATIC INIT('REPL'),
CASCADE_FUNCTION CHAR(4) STATIC INIT('CASC');
DECLARE ZERO FIXED BINARY (31) STATIC
INIT(0);
DECLARE SIXTEEN FIXED BINARY (31) STATIC
INIT(16);
PATH2_XSDB_PTR = PATH_XSDB.NEXT_PTR;
TREATROW.COL_PATNUM = PATH_DATA.PATHSEG_PATNO;
TREATROW.COL_ILLDATE = PATH2_DATA.PATH2SEG_ILLDATE;
TREATROW.COL_TRTDATE = SEGMENT_DATA.SEGMENT_DATA_TRTDATE;
TREATROW.COL_MEDICINE = SEGMENT_DATA.SEGMENT_DATA_MEDICINE;
TREATROW.COL_QUANTITY = SEGMENT_DATA.SEGMENT_DATA_QUANTITY;
EXEC SQL
WHENEVER SQLWARNING CONTINUE;
EXEC SQL
WHENEVER SQLERROR GOTO BADSQL;
EXEC SQL
WHENEVER NOT FOUND GOTO BADSQL;
IF XPCB.PATH_XSDB_PTR = XPCB.NULL_PTR
THEN DO;
GOTO BADPATH; /* PATH NOT SPECIFIED */
END; ELSE DO; /* PRE-SET CODES TO ZERO */
XPCB.EXIT_RETURN_CODE = ZERO;
XPCB.EXIT_REASON_CODE = ZERO;
END;
/*====================================*/
/* IF CALLED FOR DELETE OR CASCADE, */
/* PERFORM THE DB2 DELETE. */
/*====================================*/
IF XPCB.PHYSICAL_FUNCTION = DELETE_FUNCTION
THEN DO;
EXEC SQL
DELETE FROM SYSADM.TREATMNT
WHERE PATNUMB = ::TREATROW.COL_PATNUM AND
DATEILL = ::TREATROW.COL_ILLDATE AND
DATETRT = ::TREATROW.COL_TRTDATE;
END;
/*==========================================*/
/* IF CALLED FOR INSERT, DO DB2 INSERT CALL */
/*==========================================*/
IF XPCB.CALL_FUNCTION = INSERT_FUNCTION
THEN DO;
EXEC SQL
INSERT INTO SYSADM.TREATMNT
VALUES(::TREATROW.COL_PATNUM,
::TREATROW.COL_ILLDATE,
::TREATROW.COL_TRTDATE,
::TREATROW.COL_MEDICINE,
::TREATROW.COL_QUANTITY);
END;
/*=====================================*/
/* IF CALLED FOR REPLACE, UPDATE THE */
/* THE DB2 ROW, IF A FIELD DESTINED TO */
/* THE DB2 DATA BASE HAS BEEN CHANGED. */
/*=====================================*/
IF XPCB.CALL_FUNCTION = REPLACE_FUNCTION
THEN DO; /* REPLACE */
IF (SEGMENT_DATA.SEGMENT_DATA_MEDICINE ≠
BEFORE_DATA.BEFORE_DATA_MEDICINE) |
(SEGMENT_DATA.SEGMENT_DATA_QUANTITY ≠
BEFORE_DATA.BEFORE_DATA_QUANTITY)
THEN DO; /* UPDATE */
EXEC SQL
UPDATE SYSADM.TREATMNT
SET MEDICAT = ::SEGMENT_DATA.SEGMENT_DATA_MEDICINE,
AMOUNT = ::SEGMENT_DATA.SEGMENT_DATA_QUANTITY
WHERE PATNUMB = ::TREATROW.COL_PATNUM AND
DATEILL = ::TREATROW.COL_ILLDATE AND
DATETRT = ::TREATROW.COL_TRTDATE;
END; /* OF UPDATE */
END; /* OF REPLACE */
STOP;
BADSQL: DO; DISPLAY(SQLERRM);
XPCB.EXIT_RETURN_CODE = 16;
XPCB.EXIT_REASON_CODE = SQLCODE;
END;
BADPATH: DO;
XPCB.EXIT_RETURN_CODE = 16;
XPCB.EXIT_REASON_CODE = 14;
END;
END DLI2DB2B;