17.00 - Sample 2PC Program Listing (COBOL) - IBM IMS Interface for Teradata

IBM IMS Interface for Teradata® Reference

prodname
IBM IMS Interface for Teradata
vrm_release
17.00
created_date
June 2020
category
Programming Reference
featnum
B035-2447-220K

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.