6.3.2 MHPの例（サービスプログラム）
MHPのサービスプログラムのコーディング例を次に示します。
10 * 20 ******************************************************** 30 * MHPサービスプログラム * 40 ******************************************************** 50 * 60 IDENTIFICATION DIVISION. 70 80 PROGRAM-ID. SVRA. 90 100 ENVIRONMENT DIVISION. 110 CONFIGURATION SECTION. 120 * 130 ******************************************************** 140 * ワーク変数 * 150 ******************************************************** 160 * 170 DATA DIVISION. 180 WORKING-STORAGE SECTION. 190 * 200 ******************************************************** 210 * MCF-RECEIVEデータ領域 * 220 ******************************************************** 230 * 240 01 RECV-PARM1. 250 02 RECV-NAME PIC X(8) VALUE 'RECEIVE '. 260 02 RECV-STATUS PIC X(5). 270 02 FILLER PIC X(3). 280 02 FRST-ID PIC X(4) VALUE 'FRST' 290 02 RE-RSV1 PIC X(4) VALUE SPACE. 300 02 DATE-ID PIC 9(8). 310 02 TIME-ID PIC 9(8). 320 02 RE-LENG PIC 9(9) COMP VALUE 1024. 330 02 RE-RSV2 PIC X(4) VALUE SPACE. 340 02 RE-RSV3 PIC X(4) VALUE SPACE. 350 02 RE-RSV4 PIC X(4) VALUE SPACE. 360 02 RE-RSV5 PIC X(4) VALUE SPACE. 370 02 RE-RSV6 PIC X(8) VALUE SPACE. 380 02 RE-RSV7 PIC X(4) VALUE SPACE. 390 02 RE-RSV8 PIC X(8) VALUE SPACE. 400 02 RE-RSV9 PIC X(4) VALUE SPACE. 410 02 RE-RSV10 PIC 9(9) COMP VALUE ZERO. 420 02 RE-RSV11 PIC 9(9) COMP VALUE ZERO. 430 02 RE-RSV12 PIC X(1) VALUE SPACE. 440 02 RE-RSV13 PIC X(1) VALUE '1'. 450 02 RE-RSV14 PIC X(14) VALUE LOW-VALUE. 460 01 RECV-PARM2. 470 02 RE-RSV15 PIC X(4) VALUE SPACE. 480 02 TERM-ID PIC X(8). 490 02 RE-RSV16 PIC X(8) VALUE SPACE. 500 02 RE-RSV17 PIC X(8) VALUE SPACE. 510 02 RE-RSV18 PIC X(28) VALUE LOW-VALUE. 520 01 RECV-PARM3. 530 02 RE-DATALENG PIC 9(9) COMP. 540 02 RE-RSV19 PIC X(8). 550 02 RE-DATA PIC X(1024). 560 * 570 ******************************************************** 580 * MCF-EXECAP データ領域 * 590 ******************************************************** 600 * 610 01 EXEC-PARM1. 620 02 EXEC-NAME PIC X(8) VALUE 'EXECAP '. 630 02 EXEC-STATUS PIC X(5). 640 02 FILLER PIC X(3). 650 02 EX-RSV1 PIC X(4) VALUE SPACE. 660 02 EX-RSV2 PIC X(4) VALUE SPACE. 670 02 EX-RSV3 PIC 9(8). 680 02 EX-RSV4 PIC 9(8). 690 02 EX-RSV5 PIC 9(9) COMP VALUE ZERO. 700 02 EX-EMI PIC X(4) VALUE 'EMI '. 710 02 EX-RSV6 PIC X(4) VALUE SPACE. 720 02 EX-RSV7 PIC X(4) VALUE SPACE. 730 02 EX-RSV8 PIC X(4) VALUE SPACE. 740 02 EX-TIME PIC X(8) VALUE '00000000'. 750 02 EX-RSV9 PIC X(4) VALUE SPACE. 760 02 EX-RSV10 PIC X(8) VALUE 'aprepB '. 770 02 EX-EXEC PIC X(4) VALUE 'JUST'. 780 02 EX-RSV11 PIC 9(9) COMP VALUE ZERO. 790 02 EX-RSV12 PIC 9(9) COMP VALUE ZERO. 800 02 EX-RSV13 PIC X(1) VALUE SPACE. 810 02 EX-RSV14 PIC X(1) VALUE '1'. 820 02 EX-RSV15 PIC X(14) VALUE LOW-VALUE. 830 01 EXEC-PARM2. 840 02 EX-RSV16 PIC X(4) VALUE SPACE. 850 02 EX-RSV17 PIC X(8) VALUE SPACE. 860 02 EX-RSV18 PIC X(8) VALUE SPACE. 870 02 EX-RSV19 PIC X(8) VALUE SPACE. 880 02 EX-RSV20 PIC X(28) VALUE LOW-VALUE. 890 01 EXEC-PARM3. 900 02 EX-DATALENG PIC 9(9) COMP VALUE 16. 910 02 EX-RSV21 PIC X(8). 920 02 EX-DATA PIC X(16) VALUE 'SVRA EXECAP DATA'. 930 * 940 ******************************************************** 950 * MCF-REPLY データ領域 * 960 ******************************************************** 970 * 980 01 RPLY-PARM1. 990 02 RPLY-NAME PIC X(8) VALUE 'REPLY '. 1000 02 RPLY-STATUS PIC X(5). 1010 02 FILLER PIC X(3). 1020 02 RP-RSV1 PIC X(4) VALUE SPACE. 1030 02 RP-RSV2 PIC X(4) VALUE SPACE. 1040 02 RP-RSV3 PIC 9(8). 1050 02 RP-RSV4 PIC 9(8). 1060 02 RP-RSV5 PIC 9(9) COMP VALUE ZERO. 1070 02 RP-EMI PIC X(4) VALUE'EMI '. 1080 02 RP-RSV6 PIC X(4) VALUE SPACE. 1090 02 RP-RSV7 PIC X(4) VALUE SPACE. 1100 02 RP-RSV8 PIC X(4) VALUE SPACE. 1110 02 RP-RSV9 PIC X(8) VALUE SPACE. 1120 02 RP-RSV10 PIC X(4) VALUE SPACE. 1130 02 RP-RSV11 PIC X(8) VALUE SPACE. 1140 02 RP-RSV12 PIC X(4) VALUE SPACE. 1150 02 RP-RSV13 PIC 9(9) COMP VALUE ZERO. 1160 02 RP-RSV14 PIC 9(9) COMP VALUE ZERO. 1170 02 RP-RSV15 PIC X(1) VALUE SPACE. 1180 02 RP-RSV16 PIC X(1) VALUE '1'. 1190 02 RP-RSV17 PIC X(14) VALUE LOW-VALUE. 1200 01 RPLY-PARM2. 1210 02 RP-RSV18 PIC X(4) VALUE SPACE. 1220 02 RP-RSV19 PIC X(8) VALUE SPACE. 1230 02 RP-RSV20 PIC X(8) VALUE SPACE. 1240 02 RP-RSV21 PIC X(8) VALUE SPACE. 1250 02 RP-RSV22 PIC X(28) VALUE LOW-VALUE. 1260 01 RPLY-PARM3. 1270 02 RP-DATALENG PIC 9(9) COMP VALUE 16. 1280 02 RP-RSV23 PIC X(8). 1290 02 RP-DATA PIC X(16) VALUE 'SVRA REPLY DATA1'. 1300 * 1310 ******************************************************** 1320 * MCF-ROLLBACK データ領域 * 1330 ******************************************************** 1340 * 1350 01 RBK-PARM1. 1360 02 RBK-NAME PIC X(8) VALUE 'ROLLBACK'. 1370 02 RBK-STATUS PIC X(5). 1380 02 FILLER PIC X(3). 1390 02 RBK-ACTION PIC X(4) VALUE 'NRTN'. 1400 02 RBK-RSV1 PIC X(12) VALUE LOW-VALUE. 1410 1420 PROCEDURE DIVISION. 1430 * 1440 ******************************************************** 1450 * MCF-RECEIVE (メッセージの受信) * 1460 ******************************************************** 1470 * 1480 CALL 'CBLDCMCF' USING RECV-PARM1 RECV-PARM2 RECV-PARM3. 1490 IF RECV-STATUS IS NOT EQUAL TO '00000' 1500 * 1510 ******************************************************** 1520 * MCF-ROLLBACK (エラー処理) * 1530 ******************************************************** 1540 * 1550 CALL 'CBLDCMCF' USING RBK-PARM1. 1560 * 1570 ******************************************************** 1580 * MCF-EXECAP (アプリケーションプログラム起動) * 1590 ******************************************************** 1600 * 1610 CALL 'CBLDCMCF' USING EXEC-PARM1 EXEC-PARM2 EXEC-PARM3. 1620 IF EXEC-STATUS IS NOT EQUAL TO '00000' 1630 * 1640 ******************************************************** 1650 * MCF-ROLLBACK (エラー処理) * 1660 ******************************************************** 1670 * 1680 CALL 'CBLDCMCF' USING RBK-PARM1. 1690 * 1700 ******************************************************** 1710 * MCF-REPLY (応答メッセージの送信) * 1720 ******************************************************** 1730 * 1740 CALL 'CBLDCMCF' USING RPLY-PARM1 RPLY-PARM2 RPLY-PARM3. 1750 IF RPLY-STATUS IS NOT EQUAL TO '00000' 1760 * 1770 ******************************************************** 1780 * MCF-ROLLBACK (エラー処理) * 1790 ******************************************************** 1800 * 1810 CALL 'CBLDCMCF' USING RBK-PARM1. 1820 * 1830 ******************************************************** 1840 * 終了処理 * 1850 ******************************************************** 1860 * 1870 EXIT PROGRAM.