IBMi (AS400) fans only : Rpg Free Program Sample: How to manage a table through a program with two or more video formats
#IBMiSample
Typically we have a table and we need to perform read, write, update operations.
This simple program is an example of how.
Typically we have a table and we need to perform read, write, update operations.
This simple program is an example of how.
This is the display file.
OT01UPV.DSPF
DSPSIZ(27 132 *DS4)
REF(*LIBL/OTORD00F OTORD)
CHGINPDFT(UL)
PRINT
CF03(03)
CF04(04)
CF06(06)
CF12(12)
****************************************************************
* H00 INTESTAZIONE
****************************************************************
R H00
OVERLAY
WMODE 3A O 1 2DSPATR(HI)
+47'Customer Orders'
2 2'Type information, press Enter.'
DSPATR(BL)
COLOR(BLU)
****************************************************************
* F01
* 61 Codice cliente errato
****************************************************************
R F01
RTNCSRLOC(&RCD &FLD &POS)
OVERLAY
FLD 10A H
RCD 10A H
POS 4S 0H
3 10'Order Number'
OTCOR0 R B + 1CHGINPDFT(HI)
EDTCDE(Z)
DSPATR(PR)
* CHECK(LC)
4 12'Guest code'
OTCCL0 R B + 1COLOR(YLW)
75 DSPATR(PR)
61 DSPATR(PC)
61 DSPATR(RI)
F1DES0 R O + 1REFFLD(CLANA/CLNOM0 *LIBL/CLANA00F)
COLOR(BLU)
F1ERR1 130A O 22 2COLOR(RED)
F1ERR2 130A O 23 2COLOR(RED)
***************************************************************
* F02
* 61 Data errata
***************************************************************
R F02
RTNCSRLOC(&RCD &FLD &POS)
OVERLAY
FLD 10A H
RCD 10A H
POS 4S 0H
4 3'Check-In'
OTDTAD R B + 1REFFLD(OTDTA0)
EDTCDE(Y)
75 DSPATR(PR)
61 DSPATR(PC)
61 DSPATR(RI)
F2ERR1 130A O 22 1COLOR(RED)
F2ERR2 130A O 23 1COLOR(RED)
*******************************************************
* P00
*******************************************************
R P00
24 3'F3=Exit'
+ 3'F12=Prev.'
This is the RPG file.
OT01UP.RPGLE
**FREE
//*****************************************************************
// Managing a table with 2 or more video formats *
// Try with: *
// Try with: *
// CALL PGM(OT01UP) PARM('2' '0000001') *
// be shure exist customer record 0000001 *
// be shure exist customer record 0000001 *
//*****************************************************************
ctl-opt option(*nodebugio:*srcstmt:*nounref) dftactgrp(*no);
// files declaration
dcl-f OTORD01L Keyed usage (*input:*output:*update); // Main file
dcl-f CLANA01L Keyed usage (*input); // Customers
dcl-f CNCON01L Keyed usage (*input:*update); // Progressive numbering of orders
dcl-f ot01UPV workstn; // Workstation file
// Command Keys, error indicators, mode indicators
dcl-s IndPntr pointer inz(%addr(*in));
dcl-ds dspf based(IndPntr);
// Command
F03exit ind pos(03);
F04Find ind pos(04);
F12Prev ind pos(12);
// Error
In61FieldError ind pos(61);
// mode
In75DSPmode ind pos(75);
end-ds;
// Standalone
dcl-s errorFormat01 char(01); // Flag Error on format 01
dcl-s errorFormat02 char(01); // Flag Error on format 02
dcl-s activeVideoFormat zoned(02); // Active video format pointer
//
dcl-s otcor0prv like(otcor0); // Previous value of otcor0
dcl-s ottip0prv like(ottip0); // Previous value of ottip0
dcl-s otccl0prv like(otccl0); // Previous value of otccl0
dcl-s otann0prv like(otANN0); // Previous value of otANN0
dcl-s otdtaDprv like(otdta0); // Previous value of otdta0
//
dcl-s genericError char(1);
dcl-s p_error char(1); // Error indicator for Date Check
dcl-s p_zero char(1); // Y=allows MyDate=000000
* called pgm
dcl-pr CHKDATA extpgm('CHKDATA'); // Date Check
p_data packed(6);
p_error char(1);
p_zero char(1); // Y=allows MyDate=000000
END-PR;
dcl-pr CL01RC extpgm('CL01RC'); // Customer Search program
*n like(otccl0);
END-PR;
// Input parameters
Dcl-pi OT01UP;
P_OPTI char(1); // P_OPTI = 2 Update record
// P_OPTI = 5 Display record
// P_OPTI = N new record
P_COR0 zoned(7); // Order number
End-pi;
//*********************************************
// start working
//*********************************************
if P_OPTI <> 'N'; // N=Create, The record the rec doesn't exist yet
chain (otcor0) otord;
if %found(OTORD01L);
OTDTAD = %dec(%date(OTDTA0:*ymd):*dmy); // yymmdd to ddmmyy
else;
OTDTAD = *zeros;
endif;
endif;
activeVideoFormat = 01; // Start from first video format
dow (F03Exit = *off);
if (F03Exit = *off);
In75DSPmode = *off;
wMode = '???';
if (P_OPTI = '2');
wMode = 'UPD';
In75DSPmode = *off;
endif;
if (P_OPTI = '5');
wMode = 'DSP';
In75DSPmode = *on;
endif;
if (P_OPTI = 'N');
wMode = 'WRT';
P_OPTI = '2'; // from now I behave as if P_OPTI value were 2
In75DSPmode = *off;
endif;
if (P_OPTI = '2' or P_OPTI = '5');
write h00;
if (activeVideoFormat = 01);
exsr gesf01;
if (F12Prev = *off);
activeVideoFormat = 02;
else;
activeVideoFormat = 99;
endif;
endif;
if (activeVideoFormat = 02 and F03Exit = *off);
exsr gesf02;
if (F12Prev = *off);
activeVideoFormat = 99;
else;
activeVideoFormat = 01;
endif;
endif;
if (activeVideoFormat = 99 and F03Exit = *off);
if wMode = 'WRT';
// CNCON00F record 'ORD'stores the last Order number used.
// I'am writing a new Order, so I retrieve the new record Number
chain ('ORD') CNCON;
OTDTA0 = %dec(%date(OTDTAD:*ymd):*dmy); // yymmdd to ddmmyy
otcor0 = CNPRG0 + 1;
write otord;
CNPRG0 = otcor0;
update CNCON;
else;
if P_OPTI = '2';
OTDTA0 = %dec(%date(OTDTAD:*ymd):*dmy); // yymmdd to ddmmyy
update otord;
endif;
endif;
F03Exit = *on;
endif;
endif;
if (P_OPTI <> '2' and P_OPTI <> '5' and F03Exit = *off);
leave;
endif;
endif;
enddo;
*inlr = *on;
//************************************************************
// Managing format 01 *
//************************************************************
begsr gesf01;
if %found or not %found;
errorFormat01 = 'Y';
dow (errorFormat01 = 'Y');
exsr storeFieldsValues;
exsr decf01;
if errorFormat01 = 'Y'; // if some error occours
*in99 = *on;
else;
*in99 = *off;
endif;
write p00;
write h00;
exfmt f01;
if F03Exit = *on;
leavesr;
endif;
if F12Prev = *on;
leavesr;
endif;
if (F04Find = *on and wMode = 'UPD')
or (F04Find = *on and wMode = 'WRT');
errorFormat01 = 'Y';
// ricerca
if FLD = 'OTCCL0 ';
exsr f4ccl;
endif;
endif;
if errorFormat01 = 'N';
exsr FieldsValuesChanged;
endif;
if errorFormat01 = 'N';
exsr decf01;
endif;
enddo;
else;
F03Exit = *on;
leavesr;
endif;
endsr;
//
//****************************************************************
// Decoding format 01 *
//****************************************************************
begsr decf01;
// since the decodings MUST be successful, I already set
// errorFormat01 = 'Y', then, if the decodings are all successful,
// I exit with errorFormat01 = 'N'
//
errorFormat01 = 'Y';
//* Customer decoding
clccl0 = otccl0;
chain (clccl0) CLANA;
if %found;
errorFormat01 = 'N';
f1des0 = CLNOM0;
f1err1 = *blanks;
f1err2 = *blanks;
In61FieldError = *off; // turns off field on the screen
else;
errorFormat01 = 'Y';
f1des0 = 'Wrong Customer code';
f1err1 = 'Wrong Customer code';
f1err2 = 'F4=Customer search';
In61FieldError = *on; // turns on field on the screen
endif;
if (errorFormat01 = 'Y');
leavesr;
endif;
// in display mode it is not necessary
// for the decoding to be successful
if wMode = 'DSP';
errorFormat01 = 'N';
In61FieldError = *off;
endif;
if (errorFormat01 = 'Y');
leavesr;
endif;
endsr;
//
//****************************************************************
// Managing format 02 *
//****************************************************************
begsr gesf02;
errorFormat02 = 'Y';
dow (errorFormat02 = 'Y');
exsr storeFieldsValues;
exsr decf02;
if errorFormat02 = 'Y'; // if some error occours
*in99 = *on;
else;
*in99 = *off;
endif;
write h00;
exfmt f02;
if F03Exit = *on;
leavesr;
endif;
if F12Prev = *on;
leavesr;
endif;
if (F04Find = *on and wMode = 'UPD')
or (F04Find = *on and wMode = 'WRT');
errorFormat02 = 'Y';
// ricerca
endif;
if errorFormat02 = 'N';
exsr FieldsValuesChanged;
endif;
if errorFormat02 = 'N';
exsr decf02;
endif;
enddo;
endsr;
//
//****************************************************************
// Decoding format 02 *
//****************************************************************
begsr decf02;
// since the decodings MUST be successful, I already set
// errorFormat02 = 'Y', then, if the decodings are all successful,
// I exit with errorFormat02 = 'N'
//
errorFormat02 = 'Y';
// check arrival date
//
// RECEIVES DATE IN D/M/Y FORMAT OF 6 DIGITS WITH 0 DECIMALS
//
// RETURNS THE CODE OF AN ALPHANUMERIC CHARACTER CONTAINING:
// 0 = DATE AT ZERO
// 1 = FORMALLY WRONG DATE
// 2 = DATE GREATER THAN UDATE
// 3 = DATE LESS THAN UDATE
// 4 = DATE EQUAL TO UDATE
genericError = '0';
p_error = *blanks;
p_zero = 'N';
CHKDATA(OTDTAD:p_error:p_zero);
if p_error = 'E';
genericError = '1';
else;
genericError = '0';
endif;
if genericError = '0';
errorFormat02 = 'N';
f2err1 = *blanks;
f2err2 = *blanks;
In61FieldError = *off; // turns off field on the screen
else;
errorFormat02 = 'Y';
f2err1 = 'Wrong check-in date';
f2err2 = 'mandatory field';
In61FieldError = *on; // turns on field on the screen
endif;
if (errorFormat02 = 'Y');
leavesr;
endif;
// in display mode it is not necessary
// for the decoding to be successful
if wMode = 'DSP';
errorFormat02 = 'N';
In61FieldError = *off;
endif;
endsr;
//
//****************************************************************
// Store previous field values *
//****************************************************************
begsr storeFieldsValues;
// saves the data of all video formats to check
// if the user has changed anything.
otcor0prv = otcor0;
ottip0prv = ottip0;
otccl0prv = otccl0;
otann0prv = otANN0;
otdtaDprv = otdtaD;
endsr;
//
//****************************************************************
// Check if something has changed *
//****************************************************************
begsr FieldsValuesChanged;
// if at least one field on the screen has changed I MUST reissue
// the current video format.
// errorFormat01 = 'Y' reissues the current format video.
//
// Format 01 fields
if (
otcor0prv <> otcor0
or ottip0prv <> ottip0
or otccl0prv <> otccl0
or otann0prv <> otANN0
);
errorFormat01 = 'Y';
else;
errorFormat01 = 'N';
endif;
//
// Format 02 fields
if (
otdtaDprv <> otdtaD
);
errorFormat02 = 'Y';
else;
errorFormat02 = 'N';
endif;
endsr;
//
//****************************************************************
// On F4 pressed, search customer *
//****************************************************************
begsr f4ccl;
// F4=Customer search
//
callp CL01RC (otccl0);
endsr;
//
//****************************************************************
// Initial routine *
//****************************************************************
begsr *inzsr;
eval otcor0 = p_cor0;
eval F03Exit = *off;
endsr;
The called PGM CHKDATA is described hier.
Don't forget to set the screen to 132 columns!
I appreciate all the comments made on this blog.
Hello! I tried to compile and test this program, but many compilation errors raises, because there are missing index logical files, like OTORD01L and CNCON01L. If you create the files, only creates this 3 files: CLANA00F, CLANA01L and OTORD00F, so the program can not be compiled. Can you please give the SQL definitions of the missing files? Thank you in advance.
ReplyDelete
DeleteHello, thank you for your message!
Please make sure to click on the link provided at the beginning of the post, where you will find all the instructions to create the necessary files (including the logical files).
Here it is again for your convenience:
https://rpgfreeibm.blogspot.com/2021/02/files-for-my-sample-clana00f-customers.html
Once you follow that, the program should compile correctly.