The following IMS Preprocessor2 sample is written in COBOL. It uses 2PC processing.
************************************************************** * TITLE: SAMPLE PROGRAM IN COBOL FOR 2PC PROTOCOL IN * * THE IMS ENVIRONMENT. * * * * PROGRAM: THIS SAMPLE PROGRAM SHOWS ONE POSSIBLE METHOD * * FOR CODING A COBOL APPLICATION THAT UTILIZES * * THE TWO PHASE COMMIT PROTOCOL FOR PERFORMING * * UPDATES TO EITHER A TERADATA DBS BY ITSELF OR * * TO OTHER ADDITIONAL DBMS SYSTEMS IN THE SAME * * LUW WITHIN THE IMS ONLINE ENVIRONMENT. * * * * TABLES: EMPLOYEE TABLE SUPPLIED WITH SAMPLES. * * * * IMS DEFS: DBD NONE REQUIRED FOR DBC * * PSB PSBGEN LANG=COBOL,PSBNAME=PPC2PC * * ACB BUILD PSB=(PPC2PC) * * * ************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. PPC2PC02. AUTHOR. TERADATA STV. ENVIRONMENT DIVISION. DATA DIVISION. ************************************************************** WORKING-STORAGE SECTION. ************************************************************** EXEC SQL INCLUDE SQLCA END-EXEC. 01 LOGON-STRING. 49 FILLER PIC S9(4) COMP VALUE +80. 49 FILLER PIC X(80) VALUE ’tdpid/userid,pswd’. 01 UPD-STATEMENT. 49 STMT-LEN PIC S9(4) COMP VALUE +72. 49 FILLER PIC X(44) VALUE ’UPDATE EMPLOYEE SET SALARY_AMOUNT = 2010210 ’. 49 FILLER PIC X(28) VALUE ’WHERE EMPLOYEE_NUMBER = 1021’. ************************************************************** * * * * * * ADDITIONS FOR IMS VERSION * * * * * * * * DLI CALL FUNCTIONS * * ************************************************************** 77 GU-FUNC PIC X(4) VALUE ’GU ’. 77 GN-FUNC PIC X(4) VALUE ’GN ’. 77 ISRT-FUNC PIC X(4) VALUE ’ISRT’. 77 CHKP-FUNC PIC X(4) VALUE ’CHKP’. 77 ROLB-FUNC PIC X(4) VALUE ’ROLB’. ************************************************************** * * INPUT MESSAGE AREA * * ************************************************************** 01 INPUT-MESSAGE. 05 IN-LL1 PIC S9(3) COMP. 05 IN-ZZ1 PIC S9(3) COMP. 05 IN-TEXT. 10 IN-TRAN-CODE PIC X(8). 10 IN-LOGSTRING. 15 IN-TEXT2 PIC X(2). 15 FILLER PIC X(12). 10 FILLER PIC X(8) VALUE SPACES. 05 FILLER PIC X(50). ************************************************************** * * OUTPUT MESSAGE AREA * * ************************************************************** 01 OUTPUT-MESSAGE. 05 OUT-LL PIC S9(3) COMP VALUE +79. 05 OUT-ZZ PIC S9(3) COMP VALUE +0. 05 OUT-TEXT PIC X(132) VALUE SPACES. ************************************************************** * * OTHER WORK AREAS * * ************************************************************** 01 ERROR-MSG. 49 ERROR-MSG-LEN PIC S9(4) COMP. 49 ERROR-TXT PIC X(255). 01 ERROR-CODE PIC S9(9) COMP. 01 MAX-LENGTH PIC S9(4) COMP VALUE +255. 01 OUT-CODE PIC -(15)9. 01 REQUEST-TYPE PIC X(8). 01 TYPE-FUNC PIC X(4). 01 LTERM-SAVE PIC X(8). 01 SWITCHES. 05 SW-ERROR PIC X(3). 88 SW-ERROR-ON VALUE ’ON ’. 88 SW-ERROR-OFF VALUE ’OFF’. ************************************************************** LINKAGE SECTION. ************************************************************** 01 IOPCB. 05 LTERM PIC X(8). 05 FILLER PIC X(2). 05 IOPCB-STATUS PIC X(2). 05 PREFIX. 10 FILLER PIC X. 10 JULIAN-DATE PIC S9(9) COMP-3. 10 TIME-O-DAY PIC S9(9) COMP-3. 10 FILLER PIC XXX. ************************************************************** PROCEDURE DIVISION. ************************************************************** 000-MAIN SECTION. ENTRY ’DLITCBL’ USING IOPCB. DISPLAY IOPCB. MOVE SPACES TO IN-TEXT. CALL ’CBLTDLI’ USING GU-FUNC, IOPCB, INPUT-MESSAGE. IF IOPCB-STATUS = SPACES OR ’QC’ NEXT SENTENCE ELSE MOVE GU-FUNC TO TYPE-FUNC PERFORM 830-STATUS-ERROR GO TO 000-MAIN-EXIT. MOVE ’EXECUTING 2PC IMS COBOL SAMPLE PROGRAM.’ TO OUT-TEXT. MOVE LTERM TO LTERM-SAVE. DISPLAY OUTPUT-MESSAGE. PERFORM 800-SEND-MSG. PERFORM 100-LOGON. PERFORM 200-UPDATE. PERFORM 810-COMMIT-SYNCPOINT. PERFORM 900-LOGOFF. MOVE ’2PC IMS COBOL SAMPLE PROGRAM COMPLETED.’ TO OUT-TEXT. PERFORM 800-SEND-MSG. 000-MAIN-EXIT. GOBACK. ************************************************************** 100-LOGON SECTION. ************************************************************** MOVE ’LOGON’ TO REQUEST-TYPE. EXEC SQL LOGON :LOGON-STRING END-EXEC. PERFORM 820-ERROR-CHECK. IF (SQLCODE = 0) NEXT SENTENCE ELSE MOVE ’ERROR IN LOGON...’ TO OUT-TEXT PERFORM 800-SEND-MSG. 100-LOGON-EXIT. EXIT. ************************************************************** 200-UPDATE SECTION. ************************************************************** MOVE ’STARTING TO UPDATE...’ TO OUT-TEXT. PERFORM 800-SEND-MSG. MOVE ’UPDATE’ TO REQUEST-TYPE. PERFORM 210-UPDATE-OTHER-DBMS. EXEC SQL EXECUTE IMMEDIATE :UPD-STATEMENT END-EXEC. PERFORM 820-ERROR-CHECK. IF (SQLCODE = 0) THEN MOVE ’EMPLOYEE UPDATED...’ TO OUT-TEXT PERFORM 800-SEND-MSG. 200-UPDATE-EXIT. EXIT. ************************************************************** * UPDATE-OTHER-DBMS * ADD CODE TO UPDATE OTHER DBMS SUCH AS, DLI, ETC. ************************************************************** 210-UPDATE-OTHER-DBMS SECTION. MOVE ’UPDATE2’ TO REQUEST-TYPE. MOVE ’ADD CODE FOR UPDATING OTHER DBMS...’ TO OUT-TEXT PERFORM 800-SEND-MSG. 210-UPDATE-OTHER-DBMS-EXIT. EXIT. ************************************************************** * LOGOFF * PGM MUST TAKE AN IMS COMMIT POINT BEFORE LOGGING OFF DBC ************************************************************** 900-LOGOFF SECTION. MOVE ’LOGOFF’ TO REQUEST-TYPE. EXEC SQL LOGOFF END-EXEC. PERFORM 820-ERROR-CHECK. 900-LOGOFF-EXIT. EXIT. ************************************************************** * SEND MSG TO IMS TERMINAL ************************************************************** 800-SEND-MSG SECTION. MOVE +79 TO OUT-LL. CALL ’CBLTDLI’ USING ISRT-FUNC, IOPCB, OUTPUT-MESSAGE. IF IOPCB-STATUS = SPACES NEXT SENTENCE ELSE DISPLAY ’THE IOPCB IS AS FOLLOWS: ’ DISPLAY IOPCB MOVE ISRT-FUNC TO TYPE-FUNC PERFORM 830-STATUS-ERROR. 800-SEND-MSG-EXIT. EXIT. ************************************************************** * COMMIT LOGIC ************************************************************** 810-COMMIT-SYNCPOINT SECTION. MOVE SPACES TO IN-TEXT. IF SW-ERROR-ON THEN MOVE ROLB-FUNC TO TYPE-FUNC CALL ’CBLTDLI’ USING ROLB-FUNC, IOPCB, INPUT-MESSAGE MOVE ’OFF’ TO SW-ERROR ELSE MOVE CHKP-FUNC TO TYPE-FUNC CALL ’CBLTDLI’ USING CHKP-FUNC, IOPCB, INPUT-MESSAGE. IF IOPCB-STATUS = ’QC’ OR SPACES NEXT SENTENCE ELSE PERFORM 830-STATUS-ERROR. 810-COMMIT-SYNCPOINT-EXIT. EXIT. ************************************************************** * ERROR CHECK ************************************************************** 820-ERROR-CHECK SECTION. IF (SQLCODE NOT = 0) THEN MOVE SPACES TO ERROR-TXT CALL ’PPRTEXT’ USING SQL-RDTRTCON, ERROR-CODE, ERROR-MSG, MAX-LENGTH MOVE ’ON ’ TO SW-ERROR MOVE ERROR-MSG TO OUT-TEXT PERFORM 800-SEND-MSG. 820-ERROR-CHECK-EXIT. EXIT. ************************************************************** * STATUS ERROR ************************************************************** 830-STATUS-ERROR SECTION. MOVE SPACES TO OUT-TEXT. STRING ’STATUS-ERROR, IOPCB-STATUS IS ’, IOPCB-STATUS DELIMITED BY SIZE INTO OUT-TEXT. DISPLAY OUT-TEXT. MOVE SPACES TO OUT-TEXT. STRING ’BAD IOPCB-STATUS - ’, IOPCB-STATUS, ’ FUNCTION = ’, TYPE-FUNC DELIMITED BY SIZE INTO OUT-TEXT. DISPLAY OUTPUT-MESSAGE. DISPLAY OUT-TEXT UPON CONSOLE. GOBACK. 830-STATUS-ERROR-EXIT. EXIT.