This is the RPG IV source code for the Add/Change/Delete program named CUSTR01.
FCUSTD01 CF E WORKSTN
FCUST UF A E K DISK
*---------------------------------------------------------------------
D RecOK S 1a
*---------------------------------------------------------------------
D Err1 C CONST('RECORD ALREADY ON FI-
D LE')
D Err2 C CONST('RECORD IS NOT ON FI-
D LE')
D Err3 C CONST('NO MORE RECORDS')
D Err4 C CONST('ZIP CAN NOT BE BLANK')
D Err5 C CONST('NAME IS MANDATORY')
D Err6 C CONST('STATE IS MANDATORY')
D Err7 C CONST('INVALID ACTION')
D Err8 C CONST('NO MORE RECORDS')
D Msg1 C CONST('RECORD ADDED')
D Msg2 C CONST('RECORD UPDATED')
D Msg3 C CONST('RECORD DELETED')
D Msg4 C CONST('HIT F9 TO DELETE')
D Msg9 C CONST('NO ACTION TAKEN')
*---------------------------------------------------------------------
C KEYLST KLIST
C KFLD CSNBR
C*---------------------------------------------------------------------
C* Display the add, delete, inquire, next, or update screen
C* and process unless user hit F3 (indicator 03)
C
C DoW *in03 = *off
C ExFmt SCR1
C Eval ERRLIN = *blanks
C Eval *in90 = *off
C If *in03 = *off
C Select
C When Action = 'A'
C ExSr AddRecord
C When Action = 'D'
C ExSr DltRecord
C When Action = 'I'
C ExSr InqRecord
C When Action = 'N'
C ExSr NextRecord
C When Action = 'U'
C ExSr UpdRecord
C Other
C Eval ERRLIN = Err7
C Eval *in90 = *on
C EndSl
C EndIf
C EndDo
C
C Eval *inlr = *on
C Return
C*---------------------------------------------------------------------
C AddRecord BegSr
C
C* Indicator 80 is used by the display file to protect most fields
C* since we are in ADD mode, set the indicator off to allow field entry
C Eval *IN80 = *off
C Eval MODE = ' ADD'
C* See if customer is already on file. If so, display error
C KEYLST Chain CUST 91
C If *in91 = *off
C Eval ERRLIN = Err1
C* Indicator 90 draws attention to the error line with reverse display
C Eval *in90 = *on
C Else
C ExSr AddScreen
C EndIf
C
C EndSr
C*---------------------------------------------------------------------
C AddScreen BegSr
C
C* Clear all fields except the key field
C *NOKEY Clear CSREC
C Eval RecOK = 'n'
C* Stay on this screen until user gets it right or hits F3
C Dow RecOK = 'n' and
C *in03 = *off
C ExFmt SCR2
C If *in03 = *off
C ExSr EditRecord
C If recOK = 'y'
C Write CSREC
C Eval ERRLIN = Msg9
C EndIf
C Else
C Eval ERRLIN = Msg9
C EndIf
C EndDo
C
C Eval *in03 = *off
C
C EndSr
C*---------------------------------------------------------------------
C DltRecord BegSr
C
C* Indicator 80 is used by the display file to protect most fields
C* since we are in DLT mode, set the indicator on for no field entry
C Eval *in80 = *on
C Eval MODE = 'DELETE'
C* Display "Hit F9 to DELETE" in ERRLIN
C Eval ERRLIN = Msg4
C Eval *in90 = *on
C* See if customer is on file. If not, show error Msg
C KEYLST Chain CUST 91
C If *in91 = *on
C Eval ERRLIN = Err2
C Else
C* If customer is on file, show screen again and see if user hit F9
C* to confirm delete
C ExFmt SCR2
C Eval *in90 = *off
C If *in09 = *on
C Delete CSREC
C Eval ERRLIN = Msg3
C Else
C Eval ERRLIN = Msg9
C EndIf
C EndIf
C
C Eval *in03 = *off
C EndSr
C*---------------------------------------------------------------------
C InqRecord BegSr
C
C* Indicator 80 is used by the display file to protect most fields
C* since we are in DLT mode, set the indicator on for no field entry
C Eval *in80 = *on
C Eval MODE = 'INQUIRY'
C
C KEYLST Chain CUST 91
C If *in91 = *on
C Eval ERRLIN = Err2
C Eval *In90 = *on
C Else
C ExFmt SCR2
C EndIf
C Eval *in03 = *off
C
C EndSr
C*---------------------------------------------------------------------
C NextRecord BegSr
C
C Eval *in80 = *on
C Eval MODE = 'INQUIRY'
C Eval ERRLIN = *blanks
C
C* Set file cursor at cust from screen
C KEYLST SetLL CUST 92 93
C If *in92 = *on
C Eval ERRLIN = Err3
C Eval *in90 = *on
C EndIf
C
C* Read file to get next customer
C If ERRLIN = *BLANKS
C Read CUST 90
C If *in92 = *on
C Eval ERRLIN = Err3
C Eval *in90 = *on
C EndIf
C EndIf
C* If *in93 is on, we are at an existing record and need to read past it
C If *in93 = *on and
C ERRLIN = *blanks
C Read CUST 90
C If *in90 = *on
C Eval ERRLIN = Err3
C Eval *in90 = *on
C EndIf
C EndIf
C
C If ERRLIN = *blanks
C ExFmt SCR2
C EndIf
C Eval *in03 = *off
C
C EndSr
C*---------------------------------------------------------------------
C UpdRecord BegSr
C
C Eval *IN80 = *off
C Eval MODE = ' UPDATE '
C KEYLST Chain CUST 91
C If *in91 = *on
C Eval ERRLIN = Err2
C Eval *in90 = *on
C Else
C ExSr UpdScreen
C EndIf
C
C EndSr
C*---------------------------------------------------------------------
C UpdScreen BegSr
C Eval RecOK = 'n'
C DoW RecOK = 'n' and
C *in03 = *off
C ExFmt SCR2
C If *in03 = *off
C ExSr EditRecord
C If RecOK = 'y'
C Update CSREC
C Eval ERRLIN = Msg2
C EndIf
C Else
C Eval ERRLIN = Msg9
C EndIf
C EndDo
C Eval *in03 = *off
C EndSr
C*---------------------------------------------------------------------
C EditRecord BegSr
C Eval RecOK = 'y'
C
C If CSNAME = *blanks
C Eval RecOK = 'n'
C Eval ERRLIN = Err5
C Eval *in90 = *on
C EndIf
C
C If CSSTE = *blanks
C Eval RecOK = 'n'
C Eval ERRLIN = Err6
C Eval *in90 = *on
C EndIf
C
C If CSZIP = *zero
C Eval RecOK = 'n'
C Eval ERRLIN = Err4
C Eval *in90 = *on
C EndIf
C
C EndSr
*----------------------------------------------------------------