This subsection shows a coding example for an SUP that uses the X/Open TX interface. This SUP uses TX-interfaced transaction control for processing that was described in 6.1 Coding samples for client/server UAPs (SUP, SPP DAM access). See 6.1 Coding samples for client/server UAPs (SUP, SPP DAM access) for the process configuration and details of the SPP to which the service request is addressed. However, TX-RETURN-STATUS at line numbers 460 and 470 are redefined as RS REDEFINES TX-RETURN-STATUS because it cannot be correctly referenced if it is directly invoked from the process.

  10  *
  20  ***************************************************
  30  * SUP01                                           *
  40  ***************************************************
  50  *
  60   IDENTIFICATION DIVISION.
  70  *
  80   PROGRAM-ID. MAIN.
  90  *
 100  ***************************************************
 110  * Set the data area                          *
 120  ***************************************************
 130  *
 140   DATA DIVISION.
 150   WORKING-STORAGE SECTION.
 160   01  RPC-ARG1.
 170       02 REQUEST      PIC X(8) VALUE SPACE.
 180       02 STATUS-CODE  PIC X(5) VALUE SPACE.
 190       02 FILLER       PIC X(3).
 200       02 FLAGS        PIC S9(9) COMP VALUE ZERO.
 210  *
 220   01  RPC-ARG2.
 230       02 REQUEST      PIC X(8) VALUE SPACE.
 240       02 STATUS-CODE  PIC X(5) VALUE SPACE.
 250       02 FILLER       PIC X(3).
 260       02 FLAGS        PIC S9(9) COMP VALUE ZERO.
 270       02 DESCRIPTOR   PIC S9(9) COMP VALUE ZERO.
 280       02 S-NAME       PIC X(32) VALUE SPACE.
 290       02 G-NAME       PIC X(32) VALUE SPACE.
 300  *
 310   01  RPC-ARG3.
 320       02  SEND-DATA-LENG  PIC S9(9) COMP VALUE ZERO.
 330       02  SEND-DATA       PIC X(32) VALUE SPACE.
 340  *
 350   01  RPC-ARG4.
 360       02  RECEIVE-DATA-LENG PIC S9(9) COMP VALUE ZERO.
 370       02  RECEIVE-DATA      PIC X(32) VALUE SPACE.
 380  *
 390   01  ADM-ARG1.
 400       02  REQUEST      PIC X(8) VALUE SPACE.
 410       02  STATUS-CODE  PIC X(5) VALUE SPACE.
 420       02  FILLER       PIC X(3).
 430       02  FLAGS        PIC S9(9) COMP VALUE ZERO.
 440       02  FILLER       PIC X(3).
 450  *
 460   01  TX-RETURN-STATUS.
 470       COPY TXSTATUS.
 480  *
 490   01  RS REDEFINES TX-RETURN-STATUS.
 500       05 RSVAL         PIC S9(9) COMP-5.
 510  *
 520   01  TX-INFO-AREA.
 530       COPY TXINFDEF.
 540  *
 550   PROCEDURE DIVISION.
 560  *
 570  ***************************************************
 580  * RPC-OPEN (start the UAP)                        *
 590  ***************************************************
 600  *
 610   MOVE 'OPEN' TO REQUEST OF RPC-ARG1.
 620   MOVE ZERO   TO FLAGS  OF RPC-ARG1.
 630   CALL 'CBLDCRPC' USING RPC-ARG1.
 640       IF STATUS-CODE OF RPC-ARG1 NOT = '00000' THEN
 650         DISPLAY 'SUP01:RPC-OPEN FAILED. CODE = '
 660         STATUS-CODE OF RPC-ARG1
 670         GO TO PROG-END
 680       END-IF.
 690  *
 700  ***************************************************
 710  * TX-OPEN (open the resource manager)             *
 720  ***************************************************
 730  *
 740   CALL 'TXOPEN' USING TX-RETURN-STATUS.
 750       IF RSVAL OF RS NOT = 0 THEN
 760         DISPLAY 'SUP01:TX-OPEN FAILED. CODE = '
 770         RSVAL OF RS
 780         GO TO PROG-END
 790       END-IF.
 800  *
 810  ***************************************************
 820  * TX-SET-TRANSACTION-TIMEOUT                      *
      * (set the transaction monitoring interval)       *
 830  ***************************************************
 840  *
 850   MOVE 180 TO TRANSACTION-TIMEOUT OF TX-INFO-AREA.
 860   CALL 'TXSETTIMEOUT' USING TX-INFO-AREA TX-RETURN-STATUS.
 870       IF RSVAL OF RS NOT = 0 THEN
 880         DISPLAY 'SUP01:TX-SET-TRANSACTION-TIMEOUT FAILED. CODE = '
 890         RSVAL OF RS
 900         GO TO PROG-END
 910       END-IF.
 920  *
 930  ***************************************************
 940  * ADM-COMPLETE (report completion of user         *
      * server start processing)                        *
 950  ***************************************************
 960  *
 970   MOVE 'COMPLETE' TO REQUEST OF ADM-ARG1.
 980   CALL 'CBLDCADM' USING ADM-ARG1.
 990       IF STATUS-CODE OF ADM-ARG1 NOT = '00000' THEN
1000         DISPLAY 'SUP01:ADM-COMPLETE FAILED. CODE = '
1010         STATUS-CODE OF ADM-ARG1
1020         GO TO PROG-END
1030       END-IF.
1040  *
1050  ***************************************************
1060  * TX-BEGIN (start the transaction)                *
1070  ***************************************************
1080  *
1090   CALL 'TXBEGIN' USING TX-RETURN-STATUS.
1100       IF RSVAL OF RS NOT = 0 THEN
1110         DISPLAY 'SUP01:TX-BEGIN FAILED. CODE = '
1120         RSVAL OF RS
1130         GO TO TRAN-END
1140       END-IF.
1150  *
1160  ***************************************************
1170  * TX-INFO (acquire transaction information)       *
1180  ***************************************************
1190  *
1200   CALL 'TXINFORM' USING TX-INFO-AREA TX-RETURN-STATUS.
1210       IF RSVAL OF RS <= 0 THEN
1220         DISPLAY 'SUP01:NOT IN TRANSACTION. CODE = '
1230         RSVAL OF RS
1240         GO TO PROG-END
1250       ELSE
1260         IF RSVAL OF RS = 1 THEN
1270           DISPLAY 'SUP01:RETURN = ' COMMIT-RETURN
1280           DISPLAY 'SUP01:CONTROL = ' TRANSACTION-CONTROL
1290           DISPLAY 'SUP01:TIMEOUT = ' TRANSACTION-TIMEOUT
1300           DISPLAY 'SUP01:STATE = ' TRANSACTION-STATE
1310         END-IF
1320       END-IF.
1330  ***************************************************
1340  * RPC-CALL (request a remote service)             *
1350  ***************************************************
1360  *
1370   MOVE 'CALL' TO REQUEST OF RPC-ARG2.
1380   MOVE 'SVR01' TO G-NAME OF RPC-ARG2.
1390   MOVE 'SVR01' TO S-NAME OF RPC-ARG2.
1400   MOVE 'SUP01:DATA OpenTP1' TO SEND-DATA OF RPC-ARG3.
1410   MOVE 32 TO SEND-DATA-LENG OF RPC-ARG3.
1420   MOVE 32 TO RECEIVE-DATA-LENG OF RPC-ARG4.
1430   CALL 'CBLDCRPC' USING RPC-ARG2 RPC-ARG3 RPC-ARG4.
1440       IF STATUS-CODE OF RPC-ARG2 NOT = '00000' THEN
1450         DISPLAY 'SUP01:RPC-CALL RETURN CODE = '
1460         STATUS-CODE OF RPC-ARG2
1470  *       GO TO TRAN-END
1480       END-IF.
1490   DISPLAY 'SERVICE FUNCTION RETURN = ' RECEIVE-DATA.
1500   TRAN-END.
1510  *
1520  ***************************************************
1530  * TX-SET-TRANSACTION-CONTROL (set the unchained    *
1535  * mode)                                           *
1540  ***************************************************
1550  *
1560   MOVE 0 TO TRANSACTION-CONTROL OF TX-INFO-AREA.
1570   CALL 'TXSETTRANCTL' USING TX-INFO-AREA TX-RETURN-STATUS.
1580       IF RSVAL OF RS NOT = 0 THEN
1590         DISPLAY 'SUP01:TX-SET-TRANSACTION-CONTROL FAILED. CODE = '
1600         RSVAL OF RS
1610       END-IF.
1620  *
1630  ***************************************************
1640  * TX-COMMIT (commit in unchained mode)            *
1650  ***************************************************
1660  *
1670   CALL 'TXCOMMIT' USING TX-RETURN-STATUS.
1680       IF RSVAL OF RS NOT = 0 THEN
1690         DISPLAY 'SUP01:TX-COMMIT FAILED. CODE = '
1700         RSVAL OF RS
1710       END-IF.
1720   PROG-END.
1730  *
1740  ***************************************************
1750  * RPC-CLOSE (terminate the UAP)                   *
1760  ***************************************************
1770  *
1780   MOVE 'CLOSE' TO REQUEST OF RPC-ARG1.
1790   MOVE ZERO    TO FLAGS  OF RPC-ARG1.
1800   CALL 'CBLDCRPC' USING RPC-ARG1.
1810   DISPLAY 'SUP01:SUP PROCESS ENDED'.
1820   STOP RUN.