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.