475 lines
35 KiB
HTML
475 lines
35 KiB
HTML
|
<?xml version="1.0" encoding="UTF-8"?>
|
||
|
|
<!DOCTYPE html
|
||
|
|
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
||
|
|
<html lang="en-us" xml:lang="en-us">
|
||
|
|
<head>
|
||
|
|
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
|
||
|
|
<meta name="security" content="public" />
|
||
|
|
<meta name="Robots" content="index,follow" />
|
||
|
|
<meta http-equiv="PICS-Label" content='(PICS-1.1 "http://www.icra.org/ratingsv02.html" l gen true r (cz 1 lz 1 nz 1 oz 1 vz 1) "http://www.rsac.org/ratingsv01.html" l gen true r (n 0 s 0 v 0 l 0) "http://www.classify.org/safesurf/" l gen true r (SS~~000 1))' />
|
||
|
|
<meta name="DC.Type" content="reference" />
|
||
|
|
<meta name="DC.Title" content="Example: COBOL program" />
|
||
|
|
<meta name="DC.subject" content="example, programming, COBOL/400 language, COBOL/400, examples" />
|
||
|
|
<meta name="keywords" content="example, programming, COBOL/400 language, COBOL/400, examples" />
|
||
|
|
<meta name="DC.Relation" scheme="URI" content="rbal1progxmp.htm" />
|
||
|
|
<meta name="copyright" content="(C) Copyright IBM Corporation 1998, 2006" />
|
||
|
|
<meta name="DC.Rights.Owner" content="(C) Copyright IBM Corporation 1998, 2006" />
|
||
|
|
<meta name="DC.Format" content="XHTML" />
|
||
|
|
<meta name="DC.Identifier" content="rbal1excobolprogram" />
|
||
|
|
<meta name="DC.Language" content="en-us" />
|
||
|
|
<!-- All rights reserved. Licensed Materials Property of IBM -->
|
||
|
|
<!-- US Government Users Restricted Rights -->
|
||
|
|
<!-- Use, duplication or disclosure restricted by -->
|
||
|
|
<!-- GSA ADP Schedule Contract with IBM Corp. -->
|
||
|
|
<link rel="stylesheet" type="text/css" href="./ibmdita.css" />
|
||
|
|
<link rel="stylesheet" type="text/css" href="./ic.css" />
|
||
|
|
<title>Example: COBOL program</title>
|
||
|
|
</head>
|
||
|
|
<body id="rbal1excobolprogram"><a name="rbal1excobolprogram"><!-- --></a>
|
||
|
|
<!-- Java sync-link --><script language="Javascript" src="../rzahg/synch.js" type="text/javascript"></script>
|
||
|
|
<h1 class="topictitle1">Example: COBOL program</h1>
|
||
|
|
<div><div class="section"> <div class="note"><span class="notetitle">Note:</span> By using the code examples, you agree to the terms of the <a href="codedisclaimer.htm">Code license and disclaimer information</a>.</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"> <div class="fignone" id="rbal1excobolprogram__rbal1cblxmp"><a name="rbal1excobolprogram__rbal1cblxmp"><!-- --></a><span class="figcap">Figure 1. COBOL program example</span><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 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. 03/29/92
|
||
|
|
400 **************************************************************** 03/29/92
|
||
|
|
500 * MODULE NAME = DDBPT6CB 03/29/92
|
||
|
|
600 *
|
||
|
|
700 * DESCRIPTIVE NAME = D-DB SAMPLE APPLICATION
|
||
|
|
800 * REORDER POINT PROCESSING
|
||
|
|
900 * AS/400 03/29/92
|
||
|
|
1000 * COBOL
|
||
|
|
1100 *
|
||
|
|
1200 * FUNCTION = THIS MODULE PROCESS THE PART_STOCK TABLE AND
|
||
|
|
1300 * FOR EACH PART BELOW THE ROP (REORDER POINT)
|
||
|
|
1400 * CHECKS THE EXISTING ORDERS AND SHIPMENTS, 03/29/92
|
||
|
|
1500 * CREATES A SUPPLY ORDER AND PRINTS A REPORT. 03/29/92
|
||
|
|
1600 *
|
||
|
|
1700 * DEPENDENCIES = NONE 03/29/92
|
||
|
|
1800 *
|
||
|
|
1900 * INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION:
|
||
|
|
2000 *
|
||
|
|
2100 * LOCAL-DB LOCAL DB NAME 03/29/92
|
||
|
|
2200 * REMOTE-DB REMOTE DB NAME 03/29/92
|
||
|
|
2300 *
|
||
|
|
2400 * TABLES = PART-STOCK - LOCAL 03/29/92
|
||
|
|
2500 * PART_ORDER - REMOTE 03/29/92
|
||
|
|
2600 * PART_ORDLN - REMOTE 03/29/92
|
||
|
|
2700 * SHIPMENTLN - REMOTE 03/29/92
|
||
|
|
2800 * 03/29/92
|
||
|
|
2900 * CRTSQLCBL SPECIAL PARAMETERS 03/29/92
|
||
|
|
3000 * PGM(DDBPT6CB) RDB(remotedbname) OPTION(*APOST *APOSTSQL) 03/29/92
|
||
|
|
3100 * 03/29/92
|
||
|
|
3200 * INVOKE BY : CALL DDBPT6CB PARM(localdbname remotedbname) 03/29/92
|
||
|
|
3300 * 03/29/92
|
||
|
|
3400 **************************************************************** 03/29/92
|
||
|
|
3500 ENVIRONMENT DIVISION.
|
||
|
|
3600 *---------------------
|
||
|
|
3700 INPUT-OUTPUT SECTION.
|
||
|
|
3800 FILE-CONTROL.
|
||
|
|
3900 SELECT RELAT ASSIGN TO PRINTER-QPRINT. 03/29/92
|
||
|
|
4000 DATA DIVISION.
|
||
|
|
4100 *--------------
|
||
|
|
4200 FILE SECTION.
|
||
|
|
4300 *------------- 03/29/92
|
||
|
|
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 *------------------------ 03/29/92
|
||
|
|
5100 * PRINT LINE DEFINITIONS 03/29/92
|
||
|
|
5200 01 LINE0 PIC X(33) VALUE SPACES.
|
||
|
|
5300 01 LINE1 PIC X(33) VALUE</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 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 03/29/92
|
||
|
|
8000 01 WHAT-TIME PIC X VALUE '1'.
|
||
|
|
8100 88 FIRST-TIME VALUE '1'.
|
||
|
|
8200 01 CONTL PIC S9999 COMP-4 VALUE ZEROS. 03/29/92
|
||
|
|
8300 01 CONTD PIC S9999 COMP-4 VALUE ZEROS. 03/29/92
|
||
|
|
8400 01 RTCODE1 PIC S9999 COMP-4 VALUE ZEROS. 03/29/92
|
||
|
|
8500 01 RTCODE2 PIC S9999 COMP-4. 03/29/92
|
||
|
|
8600 01 NEXT-NUM PIC S9999 COMP-4. 03/29/92
|
||
|
|
8700 01 IND-NULL PIC S9999 COMP-4. 03/29/92
|
||
|
|
8800 01 LOC-TABLE PIC X(16).
|
||
|
|
8900 01 ORD-TABLE PIC S9999 COMP-4. 03/29/92
|
||
|
|
9000 01 ORL-TABLE PIC S9999 COMP-4. 03/29/92
|
||
|
|
9100 01 QUANT-TABLE PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9200 01 QTY-TABLE PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9300 01 ROP-TABLE PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9400 01 EOQ-TABLE PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9500 01 QTY-REQ PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9600 01 QTY-REC PIC S9(9) COMP-4. 03/29/92
|
||
|
|
9700 * CONSTANT FOR LOCATION NUMBER 03/29/92
|
||
|
|
9800 01 XPARM. 03/29/92
|
||
|
|
9900 05 LOC PIC X(4) VALUE 'SQLA'. 03/29/92
|
||
|
|
10000 * DEFINITIONS FOR ERROR MESSAGE HANDLING 03/29/92
|
||
|
|
10100 01 ERROR-MESSAGE. 03/29/92
|
||
|
|
10200 05 MSG-ID. 03/29/92
|
||
|
|
10300 10 MSG-ID-1 PIC X(2) 03/29/92
|
||
|
|
10400 VALUE 'SQ'. 03/29/92
|
||
|
|
10500 10 MSG-ID-2 PIC 99999. 03/29/92</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 3
|
||
|
|
SOURCE FILE . . . . . . . DRDA/QLBLSRC
|
||
|
|
MEMBER . . . . . . . . . DDBPT6CB
|
||
|
|
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
|
||
|
|
10600 ****************************** 03/29/92
|
||
|
|
10700 * SQLCA INCLUDE * 03/29/92
|
||
|
|
10800 ****************************** 03/29/92
|
||
|
|
10900 EXEC SQL INCLUDE SQLCA END-EXEC.
|
||
|
|
11000 03/29/92
|
||
|
|
11100 LINKAGE SECTION. 03/29/92
|
||
|
|
11200 *---------------- 03/29/92
|
||
|
|
11300 01 LOCAL-DB PIC X(18). 03/29/92
|
||
|
|
11400 01 REMOTE-DB PIC X(18). 03/29/92
|
||
|
|
11500 03/29/92
|
||
|
|
11600 PROCEDURE DIVISION USING LOCAL-DB REMOTE-DB. 03/29/92
|
||
|
|
11700 *------------------ 03/29/92
|
||
|
|
11800 ***************************** 03/29/92
|
||
|
|
11900 * SQL CURSOR DECLARATION * 03/29/92
|
||
|
|
12000 ***************************** 03/29/92
|
||
|
|
12100 * RE-POSITIONABLE CURSOR : POSITION AFTER LAST PART_NUM 03/29/92
|
||
|
|
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 03/29/92
|
||
|
|
13000 ORDER BY PART_NUM ASC 03/29/92
|
||
|
|
13100 END-EXEC.
|
||
|
|
13200 * CURSOR FOR ORDER LINES 03/29/92
|
||
|
|
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, 03/29/92
|
||
|
|
13800 PART_ORDER B
|
||
|
|
13900 WHERE PART_NUM = :PART-TABLE
|
||
|
|
14000 AND LINE_STAT <> 'C' 03/29/92
|
||
|
|
14100 AND A.ORDER_NUM = B.ORDER_NUM
|
||
|
|
14200 AND ORDER_TYPE = 'R'
|
||
|
|
14300 END-EXEC.
|
||
|
|
14400 ****************************** 03/29/92
|
||
|
|
14500 * SQL RETURN CODE HANDLING* 03/29/92
|
||
|
|
14600 ****************************** 03/29/92
|
||
|
|
14700 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC.
|
||
|
|
14800 EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC. 03/29/92
|
||
|
|
14900 03/29/92
|
||
|
|
15000 MAIN-PROGRAM-PROC. 03/29/92
|
||
|
|
15100 *------------------ 03/29/92
|
||
|
|
15200 PERFORM START-UP THRU START-UP-EXIT. 03/29/92
|
||
|
|
15300 PERFORM MAIN-PROC THRU MAIN-EXIT UNTIL RTCODE1 = 100. 03/29/92
|
||
|
|
15400 END-OF-PROGRAM. 03/29/92</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 4
|
||
|
|
SOURCE FILE . . . . . . . DRDA/QLBLSRC
|
||
|
|
MEMBER . . . . . . . . . DDBPT6CB
|
||
|
|
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
|
||
|
|
15500 *--------------- 03/29/92
|
||
|
|
15600 **** 03/29/92
|
||
|
|
15700 EXEC SQL CONNECT RESET END-EXEC. 03/29/92
|
||
|
|
15800 ****
|
||
|
|
15900 CLOSE RELAT.
|
||
|
|
16000 GOBACK.
|
||
|
|
16100 MAIN-PROGRAM-EXIT. EXIT. 03/29/92
|
||
|
|
16200 *------------------ 03/29/92
|
||
|
|
16300 03/29/92
|
||
|
|
16400 START-UP. 03/29/92
|
||
|
|
16500 *---------- 03/29/92
|
||
|
|
16600 OPEN OUTPUT RELAT. 03/29/92
|
||
|
|
16700 **** 03/29/92
|
||
|
|
16800 EXEC SQL COMMIT END-EXEC. 03/29/92
|
||
|
|
16900 **** 03/29/92
|
||
|
|
17000 PERFORM CLEAN-UP THRU CLEAN-UP-EXIT. 03/29/92
|
||
|
|
17100 ******************************** 03/29/92
|
||
|
|
17200 * CONNECT TO LOCAL DATABASE * 03/29/92
|
||
|
|
17300 ******************************** 03/29/92
|
||
|
|
17400 **** 03/29/92
|
||
|
|
17500 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 03/29/92
|
||
|
|
17600 **** 03/29/92
|
||
|
|
17700 START-UP-EXIT. EXIT. 03/29/92
|
||
|
|
17800 *------------ 03/29/92
|
||
|
|
17900 EJECT
|
||
|
|
18000 MAIN-PROC.
|
||
|
|
18100 *---------
|
||
|
|
18200 EXEC SQL OPEN NEXT_PART END-EXEC. 03/29/92
|
||
|
|
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 03/29/92
|
||
|
|
19200 PERFORM TRAILER-PROC THRU TRAILER-EXIT 03/29/92
|
||
|
|
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 --- 03/29/92
|
||
|
|
19800 **** 03/29/92
|
||
|
|
19900 EXEC SQL COMMIT END-EXEC 03/29/92
|
||
|
|
20000 **** 03/29/92
|
||
|
|
20100 ********************************* 03/29/92
|
||
|
|
20200 * CONNECT TO REMOTE DATABASE * 03/29/92
|
||
|
|
20300 ********************************* 03/29/92</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 5
|
||
|
|
SOURCE FILE . . . . . . . DRDA/QLBLSRC
|
||
|
|
MEMBER . . . . . . . . . DDBPT6CB
|
||
|
|
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
|
||
|
|
20400 **** 03/29/92
|
||
|
|
20500 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC 03/29/92
|
||
|
|
20600 **** 03/29/92
|
||
|
|
20700 EXEC SQL OPEN NEXT_ORDER_LINE END-EXEC 03/29/92
|
||
|
|
20800 PERFORM UNTIL RTCODE2 = 100
|
||
|
|
20900 EXEC SQL 03/29/92
|
||
|
|
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) 03/29/92
|
||
|
|
22200 INTO :QTY-TABLE:IND-NULL
|
||
|
|
22300 FROM SHIPMENTLN 03/29/92
|
||
|
|
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 **** 03/29/92
|
||
|
|
23800 EXEC SQL COMMIT END-EXEC. 03/29/92
|
||
|
|
23900 **** 03/29/92
|
||
|
|
24000 ********************************** 03/29/92
|
||
|
|
24100 * RECONNECT TO LOCAL DATABASE * 03/29/92
|
||
|
|
24200 ********************************** 03/29/92
|
||
|
|
24300 **** 03/29/92
|
||
|
|
24400 EXEC SQL CONNECT TO :LOCAL-DB END-EXEC. 03/29/92
|
||
|
|
24500 **** 03/29/92
|
||
|
|
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. 03/29/92
|
||
|
|
25300 ADD 1 TO CONTL.</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 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 03/29/92
|
||
|
|
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 03/29/92
|
||
|
|
27200 CREATE-ORDER-PROC. 03/29/92
|
||
|
|
27300 *------------------ 03/29/92
|
||
|
|
27400 *GET NEXT ORDER NUMBER 03/29/92
|
||
|
|
27500 EXEC SQL 03/29/92
|
||
|
|
27600 SELECT (MAX(ORDER_NUM) + 1) 03/29/92
|
||
|
|
27700 INTO :NEXT-NUM:IND-NULL 03/29/92
|
||
|
|
27800 FROM PART_ORDER 03/29/92
|
||
|
|
27900 END-EXEC. 03/29/92
|
||
|
|
28000 IF IND-NULL < 0 03/29/92
|
||
|
|
28100 MOVE 1 TO NEXT-NUM. 03/29/92
|
||
|
|
28200 EXEC SQL 03/29/92
|
||
|
|
28300 INSERT 03/29/92
|
||
|
|
28400 INTO PART_ORDER 03/29/92
|
||
|
|
28500 (ORDER_NUM, 03/29/92
|
||
|
|
28600 ORIGIN_LOC, 03/29/92
|
||
|
|
28700 ORDER_TYPE, 03/29/92
|
||
|
|
28800 ORDER_STAT, 03/29/92
|
||
|
|
28900 CREAT_TIME) 03/29/92
|
||
|
|
29000 VALUES (:NEXT-NUM, 03/29/92
|
||
|
|
29100 :LOC, 'R', 'O', 03/29/92
|
||
|
|
29200 CURRENT TIMESTAMP) 03/29/92
|
||
|
|
29300 END-EXEC. 03/29/92
|
||
|
|
29400 MOVE NEXT-NUM TO MASK0. 03/29/92
|
||
|
|
29500 PERFORM HEADER-PROC THRU HEADER-EXIT. 03/29/92
|
||
|
|
29600 CREATE-ORDER-EXIT. EXIT. 03/29/92
|
||
|
|
29700 *------------------ 03/29/92
|
||
|
|
29800 03/29/92
|
||
|
|
29900 DB-ERROR. 03/29/92
|
||
|
|
30000 *-------- 03/29/92
|
||
|
|
30100 PERFORM ERROR-MSG-PROC THRU ERROR-MSG-EXIT. 03/29/92
|
||
|
|
30200 *********************** 03/29/92
|
||
|
|
30300 * ROLLBACK THE LUW * 03/29/92</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 8
|
||
|
|
SOURCE FILE . . . . . . . DRDA/QLBLSRC
|
||
|
|
MEMBER . . . . . . . . . DDBPT6CB
|
||
|
|
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
|
||
|
|
30400 *********************** 03/29/92
|
||
|
|
30500 EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC. 03/29/92
|
||
|
|
30600 **** 03/29/92
|
||
|
|
30700 EXEC SQL ROLLBACK WORK END-EXEC. 03/29/92
|
||
|
|
30800 **** 03/29/92
|
||
|
|
30900 PERFORM END-OF-PROGRAM THRU MAIN-PROGRAM-EXIT. 03/29/92
|
||
|
|
31000 * -- NEXT LINE INCLUDED TO RESET THE "GO TO" DEFAULT -- 03/29/92
|
||
|
|
31100 EXEC SQL WHENEVER SQLERROR GO TO DB-ERROR END-EXEC. 03/29/92
|
||
|
|
31200 03/29/92
|
||
|
|
31300 ERROR-MSG-PROC. 03/29/92
|
||
|
|
31400 *---------- 03/29/92
|
||
|
|
31500 MOVE SQLCODE TO MSG-ID-2. 03/29/92
|
||
|
|
31600 DISPLAY 'SQL STATE =' SQLSTATE ' SQLCODE =' MSG-ID-2. 03/29/92
|
||
|
|
31700 * -- ADD HERE ANY ADDITIONAL ERROR MESSAGE HANDLING -- 03/29/92
|
||
|
|
31800 ERROR-MSG-EXIT. EXIT. 03/29/92
|
||
|
|
31900 *---------------- 03/29/92
|
||
|
|
32000 03/29/92
|
||
|
|
32100 ******************* 03/29/92
|
||
|
|
32200 * REPORT PRINTING * 03/29/92
|
||
|
|
32300 ******************* 03/29/92
|
||
|
|
32400 HEADER-PROC. 03/29/92
|
||
|
|
32500 *----------- 03/29/92
|
||
|
|
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 *------------------</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div class="example"><div class="fignone"><pre>5738PW1 V2R1M1 920327 SEU SOURCE LISTING 03/29/92 17:12:35 PAGE 8
|
||
|
|
SOURCE FILE . . . . . . . DRDA/QLBLSRC
|
||
|
|
MEMBER . . . . . . . . . DDBPT6CB
|
||
|
|
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
|
||
|
|
35600 ******************************************************** 03/29/92
|
||
|
|
35700 * THIS PARAGRAPH IS ONLY REQUIRED IN A TEST ENVIRONMENT* 03/29/92
|
||
|
|
35800 * TO RESET THE DATA TO PERMIT RE-RUNNING OF THE TEST * 03/29/92
|
||
|
|
35900 ******************************************************** 03/29/92
|
||
|
|
36000 CLEAN-UP. 03/29/92
|
||
|
|
36100 *--------- 03/29/92
|
||
|
|
36200 ********************************* 03/29/92
|
||
|
|
36300 * CONNECT TO REMOTE DATABASE * 03/29/92
|
||
|
|
36400 ********************************* 03/29/92
|
||
|
|
36500 **** 03/29/92
|
||
|
|
36600 EXEC SQL CONNECT TO :REMOTE-DB END-EXEC. 03/29/92
|
||
|
|
36700 **** 03/29/92
|
||
|
|
36800 *---------------------DELETE ORDER ROWS FOR RERUNABILITY 03/29/92
|
||
|
|
36900 EXEC SQL 03/29/92
|
||
|
|
37000 DELETE 03/29/92
|
||
|
|
37100 FROM PART_ORDLN 03/29/92
|
||
|
|
37200 WHERE ORDER_NUM IN 03/29/92
|
||
|
|
37300 (SELECT ORDER_NUM 03/29/92
|
||
|
|
37400 FROM PART_ORDER 03/29/92
|
||
|
|
37500 WHERE ORDER_TYPE = 'R') 03/29/92
|
||
|
|
37600 END-EXEC. 03/29/92
|
||
|
|
37700 EXEC SQL 03/29/92
|
||
|
|
37800 DELETE 03/29/92
|
||
|
|
37900 FROM PART_ORDER 03/29/92
|
||
|
|
38000 WHERE ORDER_TYPE = 'R' 03/29/92
|
||
|
|
38100 END-EXEC. 03/29/92
|
||
|
|
38200 **** 03/29/92
|
||
|
|
38300 EXEC SQL COMMIT END-EXEC. 03/29/92
|
||
|
|
38400 **** 03/29/92
|
||
|
|
38500 CLEAN-UP-EXIT. EXIT. 03/29/92
|
||
|
|
38600 *------------- 03/29/92
|
||
|
|
* * * * E N D O F S O U R C E * * * *</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div>
|
||
|
|
<div class="familylinks">
|
||
|
|
<div class="parentlink"><strong>Parent topic:</strong> <a href="rbal1progxmp.htm" title="This example application for distributed relational database use is written in RPG/400, COBOL/400, Java and ILE C/400 programming languages. This example shows how to use a distributed relational database for functional specification tasks.">Examples: Application programming</a></div>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
</body>
|
||
|
|
</html>
|