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.
Comments
Post a Comment