Subfile program using user input validation

Question

I have written a subfile program, which is working as expected. It would be great if the experts here could review it and provide feedback if the RPG or DDS can be improved in any way.

Kindly note that some of the text in the screenshots have been hidden for the sake of privacy.

Requirement:

Present a display file to the user when the program is called with blank input fields.

Inital screen to be presented to the user

Validate the input that is provided by the user and if all validations pass, display the subfile records on the screen matching the input provided as below:

Matching records

DDS code:

 A* INDICATORS USED:
 A* ----------------
 A* 01 - SFILE01 SFLCLR
 A* N01 - SFILE01 SFLDSPCTL
 A* 02 - SFILE01 SFLDSP
 A* 03 - SFILE01 SFLEND
 A* 20 - SSPLNT (RI,PC)
 A* 21 - SSURSC (RI,PC)
 A* 22 - FROM DATE FIELDS (RI,PC)
 A* 23 - TO DATE FIELDS (RI,PC)
 A*
 A* 90 - ERRORSF SFLCLR
 A* N90 - ERRORSF SFLDSPCTL
 A* 91 - ERRORSF SFLDSP
 A* 99 - ERRORSF SFLEND
 A*====================================================================*****
 A*====================================================================*****
 A DSPSIZ(24 80 *DS3)
 A CA05(05)
 A PRINT(*LIBL/QSYSPRT)
 A*====================================================================*****
 A R SFILE01 SFL
 A SSOPT 1A B 11 3VALUES(' ' '5' '7')
 A SSORD# 7A O 11 5
 A SSASRT 3A O 11 13
 A SSSEQN 3S 0O 11 17
 A SSSKU 7A O 11 21
 A SSPTN1 2A O 11 29
 A SSPTN2 14A O 11 32
 A SSMCHN 10A O 11 47
 A SSDATE 6Y 0O 11 58EDTCDE(Y)
 A SSTIME 4Y 0O 11 67EDTWRD(' : ')
 A SSQTY 5Y 0O 11 73EDTCDE(K)
 A SSPLVL 2 H
 A*====================================================================*****
 A R SFCTL01 SFLCTL(SFILE01)
 A SFLSIZ(9999)
 A SFLPAG(0011)
 A CA03
 A OVERLAY
 A 01 SFLCLR
 A N01 SFLDSPCTL
 A 02 SFLDSP
 A 03 SFLEND(*MORE)
 A SF1RRN 4S 0H SFLRCDNBR
 A 1 3DATE
 A EDTCDE(Y)
 A 1 28'WestPoint Home'
 A DSPATR(HI)
 A 1 57SYSNAME
 A 1 69'MF040R25'
 A 2 3TIME
 A 2 21'Work Center Production Inquiry'
 A DSPATR(HI)
 A 2 69USER
 A 4 3'Plant:'
 A COLOR(BLU)
 A SSPLNT 10A B 4 10COLOR(WHT)
 A 20 DSPATR(PC)
 A 20 DSPATR(RI)
 A 4 22'Work Center:'
 A COLOR(BLU)
 A SSURSC 10A B 4 35COLOR(WHT)
 A 21 DSPATR(PC)
 A 21 DSPATR(RI)
 A SSWCDS 30A O 4 46
 A 5 3'From Date:'
 A COLOR(BLU)
 A SSFMON 2Y 0B 5 14COLOR(WHT)
 A 22 DSPATR(PC)
 A 22 DSPATR(RI)
 A SSFDAY 2Y 0B 5 18COLOR(WHT)
 A 22 DSPATR(PC)
 A 22 DSPATR(RI)
 A 6 14'MM'
 A COLOR(BLU)
 A 6 18'DD'
 A COLOR(BLU)
 A SSTMON 2Y 0B 5 42COLOR(WHT)
 A 23 DSPATR(PC)
 A 23 DSPATR(RI)
 A SSFYEAR 4Y 0B 5 22COLOR(WHT)
 A 22 DSPATR(PC)
 A 22 DSPATR(RI)
 A 6 22'YYYY'
 A COLOR(BLU)
 A 5 33'To Date:'
 A COLOR(BLU)
 A SSTDAY 2Y 0B 5 46COLOR(WHT)
 A 23 DSPATR(PC)
 A 23 DSPATR(RI)
 A SSTYEAR 4Y 0B 5 50COLOR(WHT)
 A 23 DSPATR(PC)
 A 23 DSPATR(RI)
 A 6 42'MM'
 A COLOR(BLU)
 A 6 46'DD'
 A COLOR(BLU)
 A 6 50'YYYY'
 A COLOR(BLU)
 A 7 46'Total Produced:'
 A 8 3'Options: 5=MO Inquiry 7=Event Hi-
 A story Inquiry'
 A COLOR(BLU)
 A 9 3'O'
 A COLOR(WHT)
 A 10 3'P'
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 5'Mfg. Order # '
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 21'SKU '
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 47'Machine '
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 58'Date '
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 67'Time '
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 73'Qty '
 A COLOR(WHT)
 A DSPATR(UL)
 A SSTQTY 9Y 0O 7 62EDTCDE(J)
 A 10 29'CL'
 A COLOR(WHT)
 A DSPATR(UL)
 A 10 32'Pattern '
 A COLOR(WHT)
 A DSPATR(UL)
 A*====================================================================*****
 A* ERROR SUBFILE
 A*====================================================================*****
 A R ERRORSF SFL
 A SFLNXTCHG
 A MESG 78 O 24 2DSPATR(RI)
 A COLOR(RED)
 A*====================================================================*****
 A* ERROR SUBFILE CONTROL
 A*====================================================================*****
 A R ERRORSFC SFLCTL(ERRORSF)
 A SFLSIZ(9999)
 A SFLPAG(0001)
 A 90 SFLCLR
 A N90 SFLDSPCTL
 A 91 SFLDSP
 A 99 SFLEND
 A ERRRRN 4S 0H SFLRCDNBR
 A 23 3'F3=Exit'
 A COLOR(BLU)
 A 23 13'F5=Refresh'
 A COLOR(BLU)

RPG code:

 1**********************************************************************
 * File descriptions
 1**********************************************************************
 FMF040D25 CF E Workstn
 F SFILE(SFILE01:SF1RRN)
 F SFILE(ERRORSF:ERRRRN)
 F Infds(Info)
 FQSYSPRT O F 132 Printer
 1**********************************************************************
 * Arrays
 1**********************************************************************
 D Msg s 75 Dim(5) ctdata perrcd(1)
 1**********************************************************************
 * Data structures
 1**********************************************************************
 DInfo ds
 D Cfkey 369 369
 D DS
 D #Ssfdate 1 8 0 inz(0)
 D Ssfyear 1 4 0
 D Ssfmon 5 6 0
 D Ssfday 7 8 0
 D DS
 D #Sstdate 1 8 0 inz(0)
 D Sstyear 1 4 0
 D Sstmon 5 6 0
 D Sstday 7 8 0
 D Dsp_Fields DS
 D SSORD# 7
 D SSASRT 3
 D SSSEQN 3 0 INZ(*Zeros)
 D SSSKU 7
 D SSPTN1 2
 D SSPTN2 14
 D SSMCHN 10
 D SSDATEd 8 0 INZ(*Zeros)
 D SSTIMEd 6 0 INZ(*Zeros)
 D SSQTY 5 0 INZ(*Zeros)
 D SSPLVL 2
 1**********************************************************************
 * Stand Alone Variables
 1**********************************************************************
 D ValidFlag S 1 Inz(*Blanks)
 D ErrorFound S N Inz(*Off)
 D RecordFound S N Inz(*Off)
 D CursorDeclared S N Inz(*Off)
 D Sseqnc S 3
 D Sdatec S 8
 D SavRrn S Like(Sf1Rrn) Inz(1)
 D MOMode S 10 Inz('DISPLAY')
 1**********************************************************************
 * Constants
 1**********************************************************************
 D Moinquiry C Const('5')
 D Hisinquiry C Const('7')
 D ParmCorp C Const('HF')
 D ParmDivi C Const('30')
 D Refresh C Const(X'35')
 D SflSize C Const(9999)
 1**********************************************************************
 1**********************************************************************
 * Procedures
 1**********************************************************************
 // Procedure MOINQUIRY - M.O. MAINTENANCE Display Mode
 D MOINQUIRYPR PR Extpgm('MOHD01')
 D 10a CONST
 D 10a CONST
 D 10a CONST
 D 2a CONST
 D 7a CONST
 D 3a CONST
 D 3 CONST
 D 7a CONST
 D 1a CONST
 // Procedure HISTORYINQPR - Call MF040R01 Program
 D HISTORYINQPR PR Extpgm('MF040R01')
 D 10 CONST
 D 8p 0 CONST
 D 7 CONST
 D 3 CONST
 D 3 CONST
 D 1 CONST
 D 10 CONST
 D 15 CONST
 D 10 CONST
 D 8p 0 CONST
 D 10 CONST
 D 10 CONST
 D 10 CONST
 D 8p 0 CONST
 1**********************************************************************
 * Main program logic
 1**********************************************************************
 Write Errorsfc;
 Exfmt Sfctl01;
 Dow *Inkc = *off;
 Exsr Clrerrsf;
 //Validate input only if Refresh not hit...
 If (Cfkey <> Refresh);
 Exsr Edit_sfl01;
 EndIf;
 //If Errors found in input, Display Error Subfile...
 If (ErrorFound);
 *In91 = *on;
 Errrrn = 1;
 *In02 = *off;
 Else;
 //If no errors found, produce subfile
 Exsr Build_Sfile01;
 //If no records were found and refresh not hit,
 //Display message no records were found...
 If ( (Not RecordFound) and (CfKey <> Refresh) );
 *In91 = *on;
 Mesg = Msg(05);
 Exsr write_error;
 EndIf;
 Endif;
 *In03 = *On;
 Write Errorsfc;
 //Display the subfile record that was last
 //changed by user (SavRrn), else display 1st rec...
 Sf1Rrn = SavRrn;
 Exfmt Sfctl01;
 //If user does not hit refresh after Subfile displyed,
 //Process options taken on subfile records...
 If ( (RecordFound) and (CfKey <> Refresh) );
 Exsr Process_Sfile01;
 Else;
 //If refresh hit by user, Clear all fields and display blank
 //Subfile...
 If (CfKey = Refresh);
 Clear Sfctl01;
 Exsr Clear_Sfile01;
 EndIf;
 EndIf;
 Enddo;
 *Inlr = *On;
 //*******************************************************************
 // Edit Subile Fields -- Validate input entered
 //*******************************************************************
 Begsr Edit_sfl01;
 //Validate Plant entered
 ValidFlag = *Blanks;
 Exec Sql SELECT 'Y' INTO :VALIDFLAG
 FROM SYSIBM.SYSDUMMY1
 WHERE EXISTS (SELECT 1
 FROM AAPAP00
 WHERE PAPLNT = :SSPLNT
 AND PACORP = ''
 AND PADIVI = '');
 Exsr Check_SqlCode;
 If (ValidFlag = *Blanks);
 *In20 = *On;
 Mesg = Msg(01);
 Exsr write_error;
 ErrorFound = *On;
 EndIf;
 //Validate Work Center entered...
 ValidFlag = *Blanks;
 Exec Sql SELECT 'Y' INTO :VALIDFLAG
 FROM SYSIBM.SYSDUMMY1
 WHERE EXISTS (SELECT 1
 FROM PAWMP00
 WHERE WMPLNT = :SSPLNT
 AND WMURSC = :SSURSC
 AND WMAIST = 'A'
 AND WMCORP = ''
 AND WMDIVI = '');
 Exsr Check_SqlCode;
 If (ValidFlag = *Blanks);
 *In21 = *On;
 Mesg = Msg(02);
 Exsr write_error;
 ErrorFound = *On;
 Else;
 //Display Work center description...
 Exec Sql SELECT WMDESC INTO :SSWCDS
 FROM PAWMP00
 WHERE WMPLNT = :SSPLNT
 AND WMURSC = :SSURSC
 AND WMAIST = 'A'
 AND WMCORP = ''
 AND WMDIVI = '';
 Exsr Check_SqlCode;
 EndIf;
 //Validate From date input...
 Test(de) *iso #ssfdate;
 If %Error = '1';
 *In22 = *on;
 Mesg = Msg(03);
 Exsr write_error;
 ErrorFound = *On;
 Endif;
 //Validate To date input...
 Test(de) *iso #sstdate;
 If %Error = '1';
 *In23 = *on;
 Mesg = Msg(03);
 Exsr write_error;
 ErrorFound = *On;
 Endif;
 //Validate that To date > From Date input...
 If (#ssfdate > #sstdate);
 *In23 = *on;
 *In22 = *on;
 Mesg = Msg(04);
 Exsr write_error;
 ErrorFound = *On;
 EndIf;
 Endsr;
 //*******************************************************************
 // Write Error Subfile
 //*******************************************************************
 Begsr write_error;
 *In99 = *On;
 Monitor;
 Errrrn += 1;
 On-Error;
 Errrrn = *Hival;
 EndMon;
 write errorsf;
 endsr;
 //*******************************************************************
 // clear Error Subfile/Error Indicators
 //*******************************************************************
 Begsr clrerrsf;
 //Clear field error indicators...
 *In20 = *Off;
 *In21 = *Off;
 *In22 = *Off;
 *In23 = *Off;
 //Initialise Indicators...
 ErrorFound = *Off;
 RecordFound = *Off;
 //Clear Subfile...
 Errrrn = *zeros;
 Mesg = *blanks;
 *In99 = *off;
 *In91 = *off;
 *in90 = *on;
 write errorsfc;
 *in90 = *off;
 Endsr;
 //*******************************************************************
 // Clear Subfile
 //*******************************************************************
 Begsr Clear_Sfile01;
 Sf1Rrn = *Zero;
 *In01 = *On;
 Write Sfctl01;
 *In01 = *Off;
 Clear Ssopt;
 Clear Sstqty;
 EndSr;
 //*******************************************************************
 // Build Subfile
 //*******************************************************************
 Begsr Build_Sfile01;
 Exsr Clear_Sfile01;
 //Declare Cursor for loading subfile records...
 Exec Sql Declare CTOE_Fetch_Cursor cursor for
 SELECT OEWORD, OEWAST, OEWSEQ,
 OESKU,COALESCE(FCCLTH,''),COALESCE(PTPTNM,''),
 OEMACH, OECRDT, OECRTM,
 CASE WHEN OECODE IN ('FP5000','FS5000') THEN OEQTY
 WHEN OECODE IN ('FP5010','FS5010') THEN OEFQTY * -1
 END AS QTY, OELEVL
 FROM CTOEP00 TBL1
 LEFT OUTER JOIN PAFCP00 TBL2
 ON TBL1.OESKU = TBL2.FCSKU
 LEFT OUTER JOIN RMPTP00 TBL3
 ON TBL3.PTPTRN = TBL2.FCPATT
 WHERE OECRDT >= :#SSFDATE
 AND OECRDT <= :#SSTDATE
 AND OEPLNT = :SSPLNT
 AND OEWCTR = :SSURSC
 AND OECODE IN ('FP5000',
 'FP5010',
 'FS5000',
 'FS5010');
 Exec Sql Close CTOE_Fetch_Cursor;
 Exec Sql Open CTOE_Fetch_Cursor;
 Exsr Check_SqlCode;
 Exec Sql FETCH NEXT FROM CTOE_Fetch_Cursor
 INTO :DSP_FIELDS;
 Exsr Check_SqlCode;
 Dow (SQLCod = *Zeros and Sf1Rrn < SflSize);
 Monitor;
 Sf1rrn += 1;
 On-Error;
 Sf1rrn = *Hival;
 EndMon;
 //Get only hours and minutes of OECRTM
 Monitor;
 Sstime = sstimed/100;
 On-Error;
 Sstime = *Loval;
 EndMon;
 //Format OECRDT to mmddyy format...
 Monitor;
 Sdatec = %Char(Ssdated);
 Sdatec = %Subst(Sdatec:5:2) + %Subst(Sdatec:7:2) +
 %Subst(Sdatec:3:2);
 SSdate = %Dec(Sdatec:6:0);
 On-Error;
 SSdate = *Loval;
 EndMon;
 //Calculate total quantity produced...
 Monitor;
 Sstqty += Ssqty;
 On-Error;
 Sstqty = *Loval;
 EndMon;
 Write Sfile01;
 Exec Sql FETCH NEXT FROM CTOE_Fetch_Cursor
 INTO :DSP_FIELDS;
 Exsr Check_SqlCode;
 EndDo;
 If (Sf1rrn = *Zeros);
 *In02 = *Off;
 Else;
 Sf1Rrn = 1;
 *In02 = *On;
 RecordFound = *On;
 EndIf;
 EndSr;
 //*******************************************************************
 // Process Subfile
 //*******************************************************************
 BegSr Process_Sfile01;
 ReadC Sfile01;
 Dow Not %Eof;
 Monitor;
 Sseqnc = %Char(Ssseqn);
 On-Error;
 Sseqnc = *Loval;
 EndMon;
 Select;
 //If option 5 taken, call MO Inquiry program...
 When SSOPT = Moinquiry;
 MoInquiryPR(ParmCorp:ParmDivi:SSPLNT:SSPLVL:SSORD#:
 SSASRT:SSEQNC:MOMODE:'1');
 //If option 7 taken, call History Inquiry program...
 When SSOPT = Hisinquiry;
 HistoryInqPR('':0:SSORD#:SSASRT:SSEQNC:'':'':'':'':
 0:'':'':Ssplnt:0);
 EndSl;
 ReadC Sfile01;
 EndDo;
 SavRrn = Sf1Rrn;
 EndSr;
 //*******************************************************************
 // Check for SQL Errors
 //*******************************************************************
 BegSr Check_SqlCode;
 If SqlCod <> *Zero;
 If SqlCod <> 100;
 Except $ERR;
 Dump(a);
 *Inlr = *On; // Halt indicator
 return;
 EndIf;
 EndIf;
 EndSr;
 //*******************************************************************
 OQSYSPRT E $ERR 2 1
 O + 1 '************************'
 O + 0 '************************'
 OQSYSPRT E $ERR 1
 O + 1 'SQLAID='
 O SQLAID + 1
 O E $ERR 1
 O + 1 'SQLABC='
 O SQLABC + 1
 O E $ERR 1
 O + 1 'SQLCOD='
 O SQLCOD L + 1
 O E $ERR 1
 O + 1 'SQLERL='
 O SQLERL L + 1
 O E $ERR 1
 O + 1 'SQLERM='
 O SQLERM + 1
 O E $ERR 1
 O + 1 'SQLERP='
 O SQLERP + 1
 O E $ERR 1
 O + 1 'SQLER1='
 O SQLER1 L + 1
 O E $ERR 1
 O + 1 'SQLER2='
 O SQLER2 L + 1
 O E $ERR 1
 O + 1 'SQLER3='
 O SQLER3 L + 1
 O E $ERR 1
 O + 1 'SQLER4='
 O SQLER4 L + 1
 O E $ERR 1
 O + 1 'SQLER5='
 O SQLER5 L + 1
1**********************************************************************
 * Error Message Array
1**********************************************************************
** ==== Error Messages ====
Invalid Plant 01 01
Cannot Determine Work Center 02 01
Date Entered is Invalid 03 01
From Date must be less than or equal to To Date 04 01
No matching records found for Input Provided 05 01

Please note that my organization has not yet adopted RDi or fully free RPG. This code has been written in SEU.

• Fabionis: The correct tag for this question should be RPG or IBM Midrange. But both these tags dont exist. Kindly can someone with enough reputation add it for future use? This tag will help RPG developers working on IBM i to post required questions.
• Vogel612: IIUC "Midrange" refers to the platform that you can run RPG on. I have created the tag ibm-rpg. You should be able to suggest an edit to the tag wiki :)

Answer 1

I would say that if you are looking for a code review of code written right now, you should be using modern practices. I can excuse the lack of **free as it appeared with v7.3 (PTF'd back to v7.1). But you still should be using free form H, F, and D specs. Also ditch the O specs for print files as those do not have a free form equivalent. Also realize that by sticking with SEU, you are not able to use any advances in RPG or SQL put forth since v6.1 (about 10 years) without turning off syntax checking. So that is a big issue as well.

On to style, I have just a few points here:

1. Use sub-procedures instead of sub-routines. There are several advantages to this:

   • You can start creating a library of reusable code so you don't have to keep coding the same business logic in every program.
   • It allows you to use local variables, and even define files locally.
   • They are far more flexible as they can reside in service programs or programs, and can be used for recursion if you need that.
   • You can return a value so the sub-procedure can be called inline in an expression.

2. Use named indicators rather than numeric indicators. Even with display files. The INDDS() keyword should be used to name your indicators. Otherwise you are going to have to keep going back to the display file to determine what all those numeric indicators mean. It is a lot more readable if you can write something like sflDspCtl = TRUE; rather than *IN01 = *On;.

3. Use Qualified file references. That is activated by the QUALIFIED keyword on the file spec. This way you can keep your file activity seperate by using a qualifier rather than by forcing yourself to rename fields or set prefixes. This allows you to read and write into data structures and assign values by name (using EVAL-CORR).
4. Break SQL out into it's own procedure, it just clutters the logic of the routine that contains it. Because local variables and parameters are scoped to the sub-procedure, the DECLARE CURSOR does need to be in the same sub-procedure as it's associated OPEN, but keep everything else separate.
5. Don't mix and match command key processing. In your DDS you specify CA05(05) but CA03. You are also assigning indicators 01 - 03 to subfile control keywords. So F3 must be detected by the AID byte in the file information data structure or the old K indicaotrs, but F5 can be detected either by the AID byte or *IN05, and *IN01 - *IN03 don't refer to Function keys. This will be initially confusing to anyone coming behind you. Either use the AID byte exclusively, or reserve indicators 01 - 24 for function keys F1 - F24. Once you start using Qualified on your display files, the K indicators will not be usable. Not a big deal, the letters aren't contiguous anyway (there are gaps in the sequence, do you know off the top of your head where they are)?
6. Finally, your life will be made a bit easier by using a message subfile rather than a standard subfile for error messages.

• Fabionis: Hi Mark, Thanks for these suggestions. I would definitely like to write the code with free F and D Specs. But my company is not ready to invest in RDi. And as you had mentioned in one of your earlier replies to me, SEU does not support fully free RPG. I am attempting now to change rest of the program based on your comments.
• jmarkmurphy: Which version of the OS are you at? The more up to date your operating system is, the more stuff you could use that will be harder while using SEU. As far as RDi goes, IBM will convert SEU seats to RDi seats, and you can also try MiWorkplace for lower cost, but more functionality than SEU.