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.