DRDA example: ILE RPG program
This example program is written in the ILE RPG programming language.
Note: By using the code examples, you agree to the terms
of the Code license and disclaimer information.
...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 .
//***************************************************************
// *
// DESCRIPTIVE NAME = D-DB sample application *
// Reorder point processing *
// IBM i *
// ILE RPG *
// *
// FUNCTION = This module processes the PART_STOCK table and *
// for each part below the ROP (reorder point) *
// creates a supply order and prints a report. *
// *
// *
// INPUT = Parameters explicitly passed to this function: *
// *
// local_db Local db name *
// remote_db Remote db name *
// *
// TABLES = PART_STOCK - Local *
// PART_ORDER - Remote *
// PART_ORDLN - Remote *
// SHIPMENTLN - Remote *
// *
// To be compiled with COMMIT(*CHG) RDB(remotedbname) *
// *
// Invoke by : CALL DDBPT6RG PARM(localdbname remotedbname) *
// *
// Cursors will be closed implicitly (by connect) because *
// there is no reason to do it explicitly *
// *
//***************************************************************
// Parameters
dcl-pi *n;
local_db char(18); // Sample local database
remote_db char(18); // Sample remote database
end-pi;
dcl-f QPRINT printer(40) oflind(*INOF);
dcl-s short_t int(5) template;
dcl-s long_t int(10) template;
dcl-s loc char(4) inz('SQLA'); // dealer's database name
dcl-s part_table char(5); // part number in table part_stock
dcl-s quant_table like(long_t); // quantity in stock, tbl part_stock
dcl-s rop_table like(long_t); // reorder point , tbl part_stock
dcl-s eoq_table like(long_t); // reorder quantity , tbl part_stock
dcl-s next_num like(short_t); // next order nbr,table part_order
dcl-s contl like(short_t); // continuation line, tbl order_line
dcl-s ord_table like(short_t); // order nbr. , tbl order_line
dcl-s orl_table like(short_t); // order line , tbl order_line
dcl-s qty_table like(long_t); // ordered quantity , tbl order_line
dcl-s ind_null like(short_t); // null indicator for qty_table
dcl-s qty_req like(long_t);
dcl-s qty_rec like(long_t); dcl-s rtCod1 like(short_t);
dcl-s rtCod2 like(short_t);
dcl-s first_order ind;
dcl-s abnormal_end ind;
//***************************************************************
// SQL cursor declarations *
//***************************************************************
// Next part which stock quantity is under reorder points qty
EXEC SQL DECLARE NEXT_PART CURSOR FOR
SELECT PART_NUM,
PART_QUANT,
PART_ROP,
PART_EOQ
FROM PART_STOCK
WHERE PART_ROP > PART_QUANT
AND PART_NUM > :part_table
ORDER BY PART_NUM ASC;
// Orders which are already made for current part
EXEC SQL DECLARE NEXT_ORDER_LINE CURSOR FOR
SELECT A.ORDER_NUM,
ORDER_LINE,
QUANT_REQ
FROM PART_ORDLN A,
PART_ORDER B
WHERE PART_NUM = :part_table
AND LINE_STAT <> 'C'
AND A.ORDER_NUM = B.ORDER_NUM
AND ORDER_TYPE = 'R';
//***************************************************************
// SQL return code handling *
//***************************************************************
EXEC SQL WHENEVER SQLERROR GO TO db_error;
EXEC SQL WHENEVER SQLWARNING CONTINUE;
//****************************************************************
// Process - Main program logic *
// Main procedure works with local database *
//****************************************************************
// Clean up to permit re-running of test data
exsr cleanup;
EXEC SQL DISCONNECT ALL;
dou rtCod1 = 100;
EXEC SQL CONNECT TO :local_db;
EXEC SQL OPEN NEXT_PART;
EXEC SQL FETCH NEXT_PART
INTO :part_table,
:quant_table,
:rop_table,
:eoq_table; rtCod1 = SQLCOD;
EXEC SQL COMMIT;
if rtCod1 <> 100;
exsr check_order;
endif;
enddo;
exsr finish;
return; // Normal return from program
//****************************************************************
// SQL return code handling on error situations *
//****************************************************************
C db_error TAG
except err_lines;
abnormal_end = *ON;
EXEC SQL WHENEVER SQLERROR CONTINUE;
EXEC SQL ROLLBACK;
EXEC SQL WHENEVER SQLERROR GO TO db_error;
exsr finish;
return; // Return after db_error processing
//**************************************************************
// The end of the main procedure *
//**************************************************************
//**************************************************************
// Subroutines *
//**************************************************************
begsr finish;
EXEC SQL CONNECT RESET;
if not abnormal_end;
except end_info;
endif;
*INLR = *ON;
endsr;
begsr check_order;
//****************************************************************
// Checks what is current order and shipment status for the part.*
// if ordered and shipped is less than reorder point of part, *
// performs a subroutine which makes an order. *
//****************************************************************
rtCod2 = 0;
qty_req = 0; qty_rec = 0;
EXEC SQL CONNECT TO :remote_db;
EXEC SQL OPEN NEXT_ORDER_LINE;
dow rtCod2 <> 100;
EXEC SQL FETCH NEXT_ORDER_LINE
INTO :ord_table,
:orl_table,
:qty_table;
if SQLCOD = 100;
rtCod2 = 100;
else;
qty_req += qty_table;
EXEC SQL SELECT SUM(QUANT_RECV)
INTO :qty_table:ind_null
FROM SHIPMENTLN
WHERE ORDER_LOC = :loc
AND ORDER_NUM = :ord_table
AND ORDER_LINE = :orl_table;
if ind_null >= 0;
qty_rec += qty_table;
endif;
endif;
enddo;
EXEC SQL CLOSE NEXT_ORDER_LINE;
qty_table = quant_table + qty_req;
qty_rec -= qty_table;
if rop_table > qty_table;
exsr make_order;
endif;
EXEC SQL COMMIT;
endsr; // check_order
begsr make_order;
//****************************************************************
// Makes an order. If first time, performs the subroutine, which *
// searches for new order number and makes the order header. *
// after that, makes order lines using reorder quantity for the *
// part. For every ordered part, writes a line on report. *
//****************************************************************
if first_order = *OFF;
exsr start_order;
first_order = *ON;
except header;
endif;
contl += 1;
EXEC SQL INSERT
INTO PART_ORDLN
(ORDER_NUM,
ORDER_LINE,
PART_NUM,
QUANT_REQ,
LINE_STAT)
VALUES (:next_num,
:contl,
:part_table,
:eoq_table,
'O');
if *INOF;
except header;
endif;
except detail;
endsr; // make_order
begsr start_order;
//****************************************************************
// Searches for next order number and makes an order header *
// using that number. Writes also headers on report. *
//****************************************************************
EXEC SQL SELECT (MAX(ORDER_NUM) + 1)
INTO :next_num
FROM PART_ORDER;
EXEC SQL INSERT
INTO PART_ORDER
(ORDER_NUM,
ORIGIN_LOC,
ORDER_TYPE,
ORDER_STAT,
CREAT_TIME)
VALUES (:next_num,
:loc,
'R',
'O',
CURRENT TIMESTAMP);
endsr; // start_order
begsr cleanup;
//****************************************************************
// This subroutine is only required in a test environment
// to reset the data to permit re-running of the test
//****************************************************************
EXEC SQL CONNECT TO :remote_db;
EXEC SQL DELETE
FROM PART_ORDLN
WHERE ORDER_NUM IN
(SELECT ORDER_NUM
FROM PART_ORDER
WHERE ORDER_TYPE = 'R');
EXEC SQL DELETE
FROM PART_ORDER
WHERE ORDER_TYPE = 'R';
EXEC SQL COMMIT;
endsr; // cleanup
O* Output lines for the report *
O*****************************************************************
O*
OQPRINT E header 2
O + 0 '***** ROP PROCESSING'
O + 1 'REPORT *****'
O*
OQPRINT E header 2
O + 0 ' ORDER NUMBER = '
O next_num Z + 0
O*
OQPRINT E header 1
O + 0 '------------------------'
O + 0 '---------'
O*
OQPRINT E header 1
O + 0 ' LINE '
O + 0 'PART '
O + 0 'QTY '
O*
OQPRINT E header 1
O + 0 ' NUMBER '
O + 0 'NUMBER '
O + 0 'REQUESTED '
O*
OQPRINT E header 1 1
O + 0 '------------------------'
O + 0 '---------'
O*
OQPRINT EF detail 1
O contl Z + 4
O part_table + 3
O eoq_table 1 + 3
O*
OQPRINT E end_info 2
O + 0 '------------------------'
O + 0 '---------'
OQPRINT E end_info 1
O + 0 'NUMBER OF LINES ' O + 0 'CREATED = '
O contl Z + 0
O*
OQPRINT E end_info 1
O + 0 '------------------------'
O + 0 '---------'
O*
OQPRINT E end_info 2
O + 0 '*********'
O + 0 ' END OF PROGRAM '
O + 0 '********'
O*
OQPRINT E err_lines 2
O + 0 '** ERROR **'
O + 0 '** ERROR **'
O + 0 '** ERROR **'
OQPRINT E err_lines 1
O + 0 '* SQLCOD:'
O SQLCOD M + 0
O 33 '*'
OQPRINT E err_lines 1
O + 0 '* SQLSTATE:'
O SQLSTT + 2
O 33 '*'
OQPRINT E err_lines 1
O + 0 '** ERROR **'
O + 0 '** ERROR **'
O + 0 '** ERROR **'