分散トランザクション処理機能 OpenTP1 プロトコル TP1/NET/OSAS-NIF編

[目次][用語][索引][前へ][次へ]

3.4.2 COBOL言語

 
***************************************************************
*    MHP SERVICE PROGRAM                                      *
***************************************************************
 
 IDENTIFICATION DIVISION.
 
 PROGRAM-ID. SVRA.
 
 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 
***************************************************************
*   WORKING STORAGE                                           *
***************************************************************
 
 DATA DIVISION.
 WORKING-STORAGE SECTION.
 
***************************************************************
*    DATA AREA FOR MCF-RECEIVE                                *
***************************************************************
 
 01  RECV-PARM1.
   02  RECV-A            PIC X(8) VALUE 'RECEIVE '.
   02  RECV-B            PIC X(5).
   02  FILLER            PIC X(3).
   02  RECV-C            PIC X(4) VALUE 'FRST'.
   02  RECV-D            PIC X(4) VALUE SPACE.
   02  RECV-E            PIC 9(8).
   02  RECV-F            PIC 9(8).
   02  RECV-G            PIC 9(9) COMP VALUE 1024.
   02  RECV-H            PIC X(4) VALUE SPACE.
   02  RECV-I            PIC X(4) VALUE SPACE.
   02  RECV-J            PIC X(4) VALUE SPACE.
   02  RECV-K            PIC X(4) VALUE SPACE.
   02  RECV-L            PIC X(8) VALUE SPACE.
   02  RECV-M1           PIC X(4) VALUE SPACE.
   02  RECV-M2           PIC X(8) VALUE SPACE.
   02  RECV-M3           PIC X(4) VALUE SPACE.
   02  RECV-M4           PIC 9(9) COMP VALUE ZERO.
   02  RECV-M5           PIC 9(9) COMP VALUE ZERO.
   02  RECV-M6           PIC X(1) VALUE SPACE.
   02  RECV-M7           PIC X(1) VALUE SPACE.
   02  RECV-N            PIC X(14) VALUE LOW-VALUE.
 01  RECV-PARM2.
   02  RECV-O            PIC X(4) VALUE SPACE.
   02  RECV-P            PIC X(8).
   02  RECV-Q            PIC X(8) VALUE SPACE.
   02  RECV-R            PIC X(8) VALUE SPACE.
   02  RECV-T            PIC X(28) VALUE LOW-VALUE.
 01  RECV-PARM3.
   02  RECV-U            PIC 9(9) COMP.
   02  RECV-V            PIC X(8).
   02  RECV-W            PIC X(1024).
 
***************************************************************
*    DATA AREA FOR MCF-EXECAP                                 *
***************************************************************
 
 01  EXEC-PARM1.
   02  EXEC-A            PIC X(8) VALUE 'EXECAP  '.
   02  EXEC-B            PIC X(5).
   02  FILLER            PIC X(3).
   02  EXEC-C            PIC X(4) VALUE SPACE.
   02  EXEC-D            PIC X(4) VALUE SPACE.
   02  EXEC-E            PIC 9(8).
   02  EXEC-F            PIC 9(8).
   02  EXEC-G            PIC 9(9) COMP VALUE ZERO.
   02  EXEC-H            PIC X(4) VALUE 'EMI '.
   02  EXEC-I            PIC X(4) VALUE SPACE.
   02  EXEC-J            PIC X(4) VALUE SPACE.
   02  EXEC-K            PIC X(4) VALUE SPACE.
   02  EXEC-L            PIC X(8) VALUE '00000000'.
   02  EXEC-M            PIC X(4) VALUE SPACE.
   02  EXEC-N            PIC X(8) VALUE 'APL01   '.
   02  EXEC-O1           PIC X(4) VALUE 'JUST'.
   02  EXEC-O2           PIC 9(9) COMP VALUE ZERO.
   02  EXEC-O3           PIC 9(9) COMP VALUE ZERO.
   02  EXEC-O4           PIC X(1) VALUE SPACE.
   02  EXEC-O5           PIC X(1) VALUE SPACE.
   02  EXEC-P            PIC X(14) VALUE LOW-VALUE.
 01  EXEC-PARM2.
   02  EXEC-Q            PIC X(4) VALUE SPACE.
   02  EXEC-R            PIC X(8) VALUE SPACE.
   02  EXEC-S            PIC X(8) VALUE SPACE.
   02  EXEC-T            PIC X(6) VALUE SPACE.
   02  EXEC-U            PIC X(2) VALUE SPACE. 
   02  EXEC-V            PIC X(28) VALUE LOW-VALUE.
 01  EXEC-PARM3.
   02  EXEC-W            PIC 9(9) COMP VALUE 25.
   02  EXEC-X            PIC X(8).
   02  EXEC-Y1           PIC X(9) VALUE SPACE.
   02  EXEC-Y2           PIC X(16) VALUE 'SVRA EXECAP DATA'.
 
***************************************************************
*    DATA AREA FOR MCF-SEND                                   *
***************************************************************
 
 01  SEND-PARM1.
   02  SEND-A            PIC X(8) VALUE 'SEND    '.
   02  SEND-B            PIC X(5).
   02  FILLER            PIC X(3).
   02  SEND-C            PIC X(4) VALUE SPACE.
   02  SEND-D            PIC X(4) VALUE SPACE.
   02  SEND-E            PIC 9(8).
   02  SEND-F            PIC 9(8).
   02  SEND-G            PIC 9(9) COMP VALUE ZERO.
   02  SEND-H            PIC X(4) VALUE 'EMI '.
   02  SEND-I            PIC X(4) VALUE SPACE.
   02  SEND-J            PIC X(4) VALUE SPACE.
   02  SEND-K            PIC X(4) VALUE SPACE.
   02  SEND-L            PIC X(8) VALUE SPACE.
   02  SEND-M1           PIC X(4) VALUE SPACE.
   02  SEND-M2           PIC X(8) VALUE SPACE.
   02  SEND-M3           PIC X(4) VALUE SPACE.
   02  SEND-M4           PIC 9(9) COMP VALUE ZERO.
   02  SEND-M5           PIC 9(9) COMP VALUE ZERO.
   02  SEND-M6           PIC X(1) VALUE SPACE.
   02  SEND-M7           PIC X(1) VALUE SPACE.
   02  SEND-N            PIC X(14) VALUE LOW-VALUE.
 01  SEND-PARM2.
   02  SEND-O            PIC X(4) VALUE 'OUT '.
   02  SEND-P            PIC X(8) VALUE 'NFLE02  '.
   02  SEND-Q            PIC X(8) VALUE SPACE.
   02  SEND-R            PIC X(8) VALUE SPACE.
   02  SEND-T            PIC X(28) VALUE LOW-VALUE.
 01  SEND-PARM3.
   02  SEND-U            PIC 9(9) COMP VALUE 25.
   02  SEND-V            PIC X(8).
   02  SEND-W1           PIC X(9) VALUE X'C1D7D3F0F240404040'.
   02  SEND-W2           PIC X(16) VALUE 'SVRA SEND   DATA'.
 
***************************************************************
*    DATA AREA FOR MCF-ROLLBACK                               *
***************************************************************
 
 01  RBK-PARM1.
   02  RBK-A            PIC X(8) VALUE 'ROLLBACK'.
   02  RBK-B            PIC X(5).
   02  FILLER           PIC X(3).
   02  RBK-C            PIC X(4) VALUE 'NRTN'.
   02  RBK-D            PIC X(12) VALUE LOW-VALUE.
 
 PROCEDURE DIVISION.
 
***************************************************************
*    MCF-RECEIVE(RECEIVE OF MESSAGE)                          *
***************************************************************
 
   CALL 'CBLDCMCF' USING RECV-PARM1 RECV-PARM2 RECV-PARM3.
   IF RECV-B IS NOT EQUAL TO '00000'
 
***************************************************************
*    MCF-ROLLBACK(ERROR PROCESSING)                           *
***************************************************************
 
   CALL 'CBLDCMCF' USING RBK-PARM1.
 
***************************************************************
*    MCF-EXECAP(APPLICATION PROGRAM BOOTING)                  *
***************************************************************
 
   CALL 'CBLDCMCF' USING EXEC-PARM1 EXEC-PARM2 EXEC-PARM3.
   IF EXEC-B IS NOT EQUAL TO '00000'
 
***************************************************************
*    MCF-ROLLBACK(ERROR PROCESSING)                           *
***************************************************************
 
   CALL 'CBLDCMCF' USING RBK-PARM1.
 
***************************************************************
*    MCF-SEND(SEND OF MESSAGE)                                *
***************************************************************
 
   CALL 'CBLDCMCF' USING SEND-PARM1 SEND-PARM2 SEND-PARM3.
   IF SEND-B IS NOT EQUAL TO '00000'
 
***************************************************************
*    MCF-ROLLBACK(ERROR PROCESSING)                           *
***************************************************************
 
   CALL 'CBLDCMCF' USING RBK-PARM1.
 
***************************************************************
*    END PROCESSING                                           *
***************************************************************
 
   EXIT PROGRAM.