DRDA example: COBOL program
This example program is written in the COBOL programming language.
Note: By using the code examples, you agree to the terms
of the Code license and disclaimer information.
Figure 1. COBOL program example
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) VALUE5400 '***** 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/0010600 ****************************** 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/0015500 *--------------- 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/0020400 **** 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.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/0030400 *********************** 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 *------------------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 * * * *