Example: COBOL program
This example program is written in the COBOL programming language.
By using the code examples, you agree to the terms of the Code license and disclaimer information. Figure 1. COBOL program example
5738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 1 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 100 IDENTIFICATION DIVISION. 200 *------------------------ 300 PROGRAM-ID. DDBPT6CB. 00/00/00 400 **************************************************************** 00/00/00 500 * MODULE NAME = DDBPT6CB 00/00/00 600 * 700 * DESCRIPTIVE NAME = D-DB SAMPLE APPLICATION 800 * REORDER POINT PROCESSING 900 * i5/OS 00/00/00 1000 * COBOL 1100 * 1200 * FUNCTION = THIS MODULE PROCESSES THE PART_STOCK TABLE AND 1300 * FOR EACH PART BELOW THE ROP (REORDER POINT) 1400 * CHECKS THE EXISTING ORDERS AND SHIPMENTS, 00/00/00 1500 * CREATES A SUPPLY ORDER AND PRINTS A REPORT. 00/00/00 1600 * 1700 * DEPENDENCIES = NONE 00/00/00 1800 * 1900 * INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION: 2000 * 2100 * LOCAL-DB LOCAL DB NAME 00/00/00 2200 * REMOTE-DB REMOTE DB NAME 00/00/00 2300 * 2400 * TABLES = PART-STOCK - LOCAL 00/00/00 2500 * PART_ORDER - REMOTE 00/00/00 2600 * PART_ORDLN - REMOTE 00/00/00 2700 * SHIPMENTLN - REMOTE 00/00/00 2800 * 00/00/00 2900 * CRTSQLCBL SPECIAL PARAMETERS 00/00/00 3000 * PGM(DDBPT6CB) RDB(remotedbname) OPTION(*APOST *APOSTSQL) 00/00/00 3100 * 00/00/00 3200 * INVOKE BY : CALL DDBPT6CB PARM(localdbname remotedbname) 00/00/00 3300 * 00/00/00 3400 **************************************************************** 00/00/00 3500 ENVIRONMENT DIVISION. 3600 *--------------------- 3700 INPUT-OUTPUT SECTION. 3800 FILE-CONTROL. 3900 SELECT RELAT ASSIGN TO PRINTER-QPRINT. 00/00/00 4000 DATA DIVISION. 4100 *-------------- 4200 FILE SECTION. 4300 *------------- 00/00/00 4400 FD RELAT 4500 RECORD CONTAINS 33 CHARACTERS 4600 LABEL RECORDS ARE OMITTED 4700 DATA RECORD IS REPREC. 4800 01 REPREC PIC X(33). 4900 WORKING-STORAGE SECTION. 5000 *------------------------ 00/00/00 5100 * PRINT LINE DEFINITIONS 00/00/00 5200 01 LINE0 PIC X(33) VALUE SPACES. 5300 01 LINE1 PIC X(33) VALUE5738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 2 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 5400 '***** ROP PROCESSING REPORT *****'. 5500 01 LINE2. 5600 05 FILLER PIC X(18) VALUE ' ORDER NUMBER = '. 5700 05 MASK0 PIC ZZZ9. 5800 05 FILLER PIC X(11) VALUE SPACES. 5900 01 LINE3 PIC X(33) VALUE 6000 '---------------------------------'. 6100 01 LINE4 PIC X(33) VALUE 6200 ' LINE PART QTY '. 6300 01 LINE5 PIC X(33) VALUE 6400 ' NUMBER NUMBER REQUESTED '. 6500 01 LINE6. 6600 05 FILLER PIC XXXX VALUE SPACES. 6700 05 MASK1 PIC ZZZ9. 6800 05 FILLER PIC XXXX VALUE SPACES. 6900 05 PART-TABLE PIC XXXXX. 7000 05 FILLER PIC XXXX VALUE SPACES. 7100 05 MASK2 PIC Z,ZZZ,ZZZ.ZZ. 7200 01 LINE7. 7300 05 FILLER PIC X(26) VALUE 7400 'NUMBER OF LINES CREATED = '. 7500 05 MASK3 PIC ZZZ9. 7600 05 FILLER PIC XXX VALUE SPACES. 7700 01 LINE8 PIC X(33) VALUE 7800 '********* END OF PROGRAM ********'. 7900 * MISCELLANEOUS DEFINITIONS 00/00/00 8000 01 WHAT-TIME PIC X VALUE '1'. 8100 88 FIRST-TIME VALUE '1'. 8200 01 CONTL PIC S9999 COMP-4 VALUE ZEROS. 00/00/00 8300 01 CONTD PIC S9999 COMP-4 VALUE ZEROS. 00/00/00 8400 01 RTCODE1 PIC S9999 COMP-4 VALUE ZEROS. 00/00/00 8500 01 RTCODE2 PIC S9999 COMP-4. 00/00/00 8600 01 NEXT-NUM PIC S9999 COMP-4. 00/00/00 8700 01 IND-NULL PIC S9999 COMP-4. 00/00/00 8800 01 LOC-TABLE PIC X(16). 8900 01 ORD-TABLE PIC S9999 COMP-4. 00/00/00 9000 01 ORL-TABLE PIC S9999 COMP-4. 00/00/00 9100 01 QUANT-TABLE PIC S9(9) COMP-4. 00/00/00 9200 01 QTY-TABLE PIC S9(9) COMP-4. 00/00/00 9300 01 ROP-TABLE PIC S9(9) COMP-4. 00/00/00 9400 01 EOQ-TABLE PIC S9(9) COMP-4. 00/00/00 9500 01 QTY-REQ PIC S9(9) COMP-4. 00/00/00 9600 01 QTY-REC PIC S9(9) COMP-4. 00/00/00 9700 * CONSTANT FOR LOCATION NUMBER 00/00/00 9800 01 XPARM. 00/00/00 9900 05 LOC PIC X(4) VALUE 'SQLA'. 00/00/00 10000 * DEFINITIONS FOR ERROR MESSAGE HANDLING 00/00/00 10100 01 ERROR-MESSAGE. 00/00/00 10200 05 MSG-ID. 00/00/00 10300 10 MSG-ID-1 PIC X(2) 00/00/00 10400 VALUE 'SQ'. 00/00/00 10500 10 MSG-ID-2 PIC 99999. 00/00/005738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 3 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 10600 ****************************** 00/00/00 10700 * SQLCA INCLUDE * 00/00/00 10800 ****************************** 00/00/00 10900 EXEC SQL INCLUDE SQLCA END-EXEC. 11000 00/00/00 11100 LINKAGE SECTION. 00/00/00 11200 *---------------- 00/00/00 11300 01 LOCAL-DB PIC X(18). 00/00/00 11400 01 REMOTE-DB PIC X(18). 00/00/00 11500 00/00/00 11600 PROCEDURE DIVISION USING LOCAL-DB REMOTE-DB. 00/00/00 11700 *------------------ 00/00/00 11800 ***************************** 00/00/00 11900 * SQL CURSOR DECLARATION * 00/00/00 12000 ***************************** 00/00/00 12100 * RE-POSITIONABLE CURSOR : POSITION AFTER LAST PART_NUM 00/00/00 12200 EXEC SQL DECLARE NEXT_PART CURSOR FOR 12300 SELECT PART_NUM, 12400 PART_QUANT, 12500 PART_ROP, 12600 PART_EOQ 12700 FROM PART_STOCK 12800 WHERE PART_ROP > PART_QUANT 12900 AND PART_NUM > :PART-TABLE 00/00/00 13000 ORDER BY PART_NUM ASC 00/00/00 13100 END-EXEC. 13200 * CURSOR FOR ORDER LINES 00/00/00 13300 EXEC SQL DECLARE NEXT_ORDER_LINE CURSOR FOR 13400 SELECT A.ORDER_NUM, 13500 ORDER_LINE, 13600 QUANT_REQ 13700 FROM PART_ORDLN A, 00/00/00 13800 PART_ORDER B 13900 WHERE PART_NUM = :PART-TABLE 14000 AND LINE_STAT <> 'C' 00/00/00 14100 AND A.ORDER_NUM = B.ORDER_NUM 14200 AND ORDER_TYPE = 'R' 14300 END-EXEC. 14400 ****************************** 00/00/00 14500 * SQL RETURN CODE HANDLING* 00/00/00 14600 ****************************** 00/00/00 14700 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC. 14800 EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC. 00/00/00 14900 00/00/00 15000 MAIN-PROGRAM-PROC. 00/00/00 15100 *------------------ 00/00/00 15200 PERFORM START-UP THRU START-UP-EXIT. 00/00/00 15300 PERFORM MAIN-PROC THRU MAIN-EXIT UNTIL RTCODE1 = 100. 00/00/00 15400 END-OF-PROGRAM. 00/00/005738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 4 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 15500 *--------------- 00/00/00 15600 **** 00/00/00 15700 EXEC SQL CONNECT RESET END-EXEC. 00/00/00 15800 **** 15900 CLOSE RELAT. 16000 GOBACK. 16100 MAIN-PROGRAM-EXIT. EXIT. 00/00/00 16200 *------------------ 00/00/00 16300 00/00/00 16400 START-UP. 00/00/00 16500 *---------- 00/00/00 16600 OPEN OUTPUT RELAT. 00/00/00 16700 **** 00/00/00 16800 EXEC SQL COMMIT END-EXEC. 00/00/00 16900 **** 00/00/00 17000 PERFORM CLEAN-UP THRU CLEAN-UP-EXIT. 00/00/00 17100 ******************************** 00/00/00 17200 * CONNECT TO LOCAL DATABASE * 00/00/00 17300 ******************************** 00/00/00 17400 **** 00/00/00 17500 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 00/00/00 17600 **** 00/00/00 17700 START-UP-EXIT. EXIT. 00/00/00 17800 *------------ 00/00/00 17900 EJECT 18000 MAIN-PROC. 18100 *--------- 18200 EXEC SQL OPEN NEXT_PART END-EXEC. 00/00/00 18300 EXEC SQL 18400 FETCH NEXT_PART 18500 INTO :PART-TABLE, 18600 :QUANT-TABLE, 18700 :ROP-TABLE, 18800 :EOQ-TABLE 18900 END-EXEC. 19000 IF SQLCODE = 100 19100 MOVE 100 TO RTCODE1 00/00/00 19200 PERFORM TRAILER-PROC THRU TRAILER-EXIT 00/00/00 19300 ELSE 19400 MOVE 0 TO RTCODE2 19500 MOVE 0 TO QTY-REQ 19600 MOVE 0 TO QTY-REC 19700 * --- IMPLICIT "CLOSE" CAUSED BY COMMIT --- 00/00/00 19800 **** 00/00/00 19900 EXEC SQL COMMIT END-EXEC 00/00/00 20000 **** 00/00/00 20100 ********************************* 00/00/00 20200 * CONNECT TO REMOTE DATABASE * 00/00/00 20300 ********************************* 00/00/005738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 5 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 20400 **** 00/00/00 20500 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC 00/00/00 20600 **** 00/00/00 20700 EXEC SQL OPEN NEXT_ORDER_LINE END-EXEC 00/00/00 20800 PERFORM UNTIL RTCODE2 = 100 20900 EXEC SQL 00/00/00 21000 FETCH NEXT_ORDER_LINE 21100 INTO :ORD-TABLE, 21200 :ORL-TABLE, 21300 :QTY-TABLE 21400 END-EXEC 21500 IF SQLCODE = 100 21600 MOVE 100 TO RTCODE2 21700 EXEC SQL CLOSE NEXT_ORDER_LINE END-EXEC 21800 ELSE 21900 ADD QTY-TABLE TO QTY-REQ 22000 EXEC SQL 22100 SELECT SUM(QUANT_RECV) 00/00/00 22200 INTO :QTY-TABLE:IND-NULL 22300 FROM SHIPMENTLN 00/00/00 22400 WHERE ORDER_LOC = :LOC 22500 AND ORDER_NUM = :ORD-TABLE 22600 AND ORDER_LINE = :ORL-TABLE 22700 END-EXEC 22800 IF IND-NULL NOT < 0 22900 ADD QTY-TABLE TO QTY-REC 23000 END-IF 23100 END-IF 23200 END-PERFORM 23300 IF ROP-TABLE > QUANT-TABLE + QTY-REQ - QTY-REC 23400 PERFORM ORDER-PROC THRU ORDER-EXIT 23500 END-IF 23600 END-IF. 23700 **** 00/00/00 23800 EXEC SQL COMMIT END-EXEC. 00/00/00 23900 **** 00/00/00 24000 ********************************** 00/00/00 24100 * RECONNECT TO LOCAL DATABASE * 00/00/00 24200 ********************************** 00/00/00 24300 **** 00/00/00 24400 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 00/00/00 24500 **** 00/00/00 24600 MAIN-EXIT. EXIT. 24700 *--------------- 24800 ORDER-PROC. 24900 *---------- 25000 IF FIRST-TIME 25100 MOVE '2' TO WHAT-TIME 25200 PERFORM CREATE-ORDER-PROC THRU CREATE-ORDER-EXIT. 00/00/00 25300 ADD 1 TO CONTL.5738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 7 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 25400 EXEC SQL 25500 INSERT 25600 INTO PART_ORDLN 00/00/00 25700 (ORDER_NUM, 25800 ORDER_LINE, 25900 PART_NUM, 26000 QUANT_REQ, 26100 LINE_STAT) 26200 VALUES (:NEXT-NUM, 26300 :CONTL, 26400 :PART-TABLE, 26500 :EOQ-TABLE, 26600 'O') 26700 END-EXEC. 26800 PERFORM DETAIL-PROC THRU DETAIL-EXIT. 26900 ORDER-EXIT. EXIT. 27000 *---------------- 27100 00/00/00 27200 CREATE-ORDER-PROC. 00/00/00 27300 *------------------ 00/00/00 27400 *GET NEXT ORDER NUMBER 00/00/00 27500 EXEC SQL 00/00/00 27600 SELECT (MAX(ORDER_NUM) + 1) 00/00/00 27700 INTO :NEXT-NUM:IND-NULL 00/00/00 27800 FROM PART_ORDER 00/00/00 27900 END-EXEC. 00/00/00 28000 IF IND-NULL < 0 00/00/00 28100 MOVE 1 TO NEXT-NUM. 00/00/00 28200 EXEC SQL 00/00/00 28300 INSERT 00/00/00 28400 INTO PART_ORDER 00/00/00 28500 (ORDER_NUM, 00/00/00 28600 ORIGIN_LOC, 00/00/00 28700 ORDER_TYPE, 00/00/00 28800 ORDER_STAT, 00/00/00 28900 CREAT_TIME) 00/00/00 29000 VALUES (:NEXT-NUM, 00/00/00 29100 :LOC, 'R', 'O', 00/00/00 29200 CURRENT TIMESTAMP) 00/00/00 29300 END-EXEC. 00/00/00 29400 MOVE NEXT-NUM TO MASK0. 00/00/00 29500 PERFORM HEADER-PROC THRU HEADER-EXIT. 00/00/00 29600 CREATE-ORDER-EXIT. EXIT. 00/00/00 29700 *------------------ 00/00/00 29800 00/00/00 29900 DB-ERROR. 00/00/00 30000 *-------- 00/00/00 30100 PERFORM ERROR-MSG-PROC THRU ERROR-MSG-EXIT. 00/00/00 30200 *********************** 00/00/00 30300 * ROLLBACK THE LUW * 00/00/005738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 8 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 30400 *********************** 00/00/00 30500 EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC. 00/00/00 30600 **** 00/00/00 30700 EXEC SQL ROLLBACK WORK END-EXEC. 00/00/00 30800 **** 00/00/00 30900 PERFORM END-OF-PROGRAM THRU MAIN-PROGRAM-EXIT. 00/00/00 31000 * -- NEXT LINE INCLUDED TO RESET THE "GO TO" DEFAULT -- 00/00/00 31100 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC. 00/00/00 31200 00/00/00 31300 ERROR-MSG-PROC. 00/00/00 31400 *---------- 00/00/00 31500 MOVE SQLCODE TO MSG-ID-2. 00/00/00 31600 DISPLAY 'SQL STATE =' SQLSTATE ' SQLCODE =' MSG-ID-2. 00/00/00 31700 * -- ADD HERE ANY ADDITIONAL ERROR MESSAGE HANDLING -- 00/00/00 31800 ERROR-MSG-EXIT. EXIT. 00/00/00 31900 *---------------- 00/00/00 32000 00/00/00 32100 ******************* 00/00/00 32200 * REPORT PRINTING * 00/00/00 32300 ******************* 00/00/00 32400 HEADER-PROC. 00/00/00 32500 *----------- 00/00/00 32600 WRITE REPREC FROM LINE1 AFTER ADVANCING PAGE. 32700 WRITE REPREC FROM LINE2 AFTER ADVANCING 3 LINES. 32800 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 32900 WRITE REPREC FROM LINE4 AFTER ADVANCING 1 LINES. 33000 WRITE REPREC FROM LINE5 AFTER ADVANCING 1 LINES. 33100 WRITE REPREC FROM LINE3 AFTER ADVANCING 1 LINES. 33200 WRITE REPREC FROM LINE0 AFTER ADVANCING 1 LINES. 33300 HEADER-EXIT. EXIT. 33400 *----------------- 33500 DETAIL-PROC. 33600 *----------- 33700 ADD 1 TO CONTD. 33800 IF CONTD > 50 33900 MOVE 1 TO CONTD 34000 PERFORM HEADER-PROC THRU HEADER-EXIT 34100 END-IF 34200 MOVE CONTL TO MASK1. 34300 MOVE EOQ-TABLE TO MASK2. 34400 WRITE REPREC FROM LINE6 AFTER ADVANCING 1 LINES. 34500 DETAIL-EXIT. EXIT. 34600 *----------------- 34700 TRAILER-PROC. 34800 *------------ 34900 MOVE CONTL TO MASK3. 35000 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 35100 WRITE REPREC FROM LINE7 AFTER ADVANCING 2 LINES. 35200 WRITE REPREC FROM LINE3 AFTER ADVANCING 2 LINES. 35300 WRITE REPREC FROM LINE8 AFTER ADVANCING 1 LINES. 35400 TRAILER-EXIT. EXIT. 35500 *------------------5738PW1 V5R4M0 000000 SEU SOURCE LISTING 00/00/00 17:12:35 PAGE 8 SOURCE FILE . . . . . . . DRDA/QLBLSRC MEMBER . . . . . . . . . DDBPT6CB SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 35600 ******************************************************** 00/00/00 35700 * THIS PARAGRAPH IS ONLY REQUIRED IN A TEST ENVIRONMENT* 00/00/00 35800 * TO RESET THE DATA TO PERMIT RE-RUNNING OF THE TEST * 00/00/00 35900 ******************************************************** 00/00/00 36000 CLEAN-UP. 00/00/00 36100 *--------- 00/00/00 36200 ********************************* 00/00/00 36300 * CONNECT TO REMOTE DATABASE * 00/00/00 36400 ********************************* 00/00/00 36500 **** 00/00/00 36600 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC. 00/00/00 36700 **** 00/00/00 36800 *---------------------DELETE ORDER ROWS FOR RERUNABILITY 00/00/00 36900 EXEC SQL 00/00/00 37000 DELETE 00/00/00 37100 FROM PART_ORDLN 00/00/00 37200 WHERE ORDER_NUM IN 00/00/00 37300 (SELECT ORDER_NUM 00/00/00 37400 FROM PART_ORDER 00/00/00 37500 WHERE ORDER_TYPE = 'R') 00/00/00 37600 END-EXEC. 00/00/00 37700 EXEC SQL 00/00/00 37800 DELETE 00/00/00 37900 FROM PART_ORDER 00/00/00 38000 WHERE ORDER_TYPE = 'R' 00/00/00 38100 END-EXEC. 00/00/00 38200 **** 00/00/00 38300 EXEC SQL COMMIT END-EXEC. 00/00/00 38400 **** 00/00/00 38500 CLEAN-UP-EXIT. EXIT. 00/00/00 38600 *------------- 00/00/00 * * * * E N D O F S O U R C E * * * *
Parent topic:
Examples: Application programming