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.