Programming and Coding Examples › RPG III Program Source Example

RPG III Program Source Example

H/TITLE YEDTSCR - Screen name selection.
H* SYSTEM : Universal Sprocket Co
H* PROGRAMMER : A Turing
H* DATE : 16/06/87
H* (C) Copyright 1989 Universal Sprocket Company
*
M* 20/07/04 PW Add copy screen option
M* 20/07/92 MS Revise Help handling to use UIM
*
H* SYNOPSIS : Display the titles of screens from within the
H* current DBF member
H* Permit selection of a single line, or exit.
H*
H* 1. RECEIVE ENTRY PARAMETERS :
H* 1.1 (O) SCREEN NAME.
H* 1.2 (O) MSGID OF RETURN MESSAGE.
H*
H* 2. LOAD AND DISPLAY FIRST PAGE OF SCREEN TITLES.
H* 3. PROCESS INPUT:
H* 3.1 IF START OPTION CHANGED RE-POSITION THE FILE AND
H* CONTINUE FROM 2.
H* 3.2 PROCESS COMMAND KEYS (EXIT, ROLLUP)
H* CMD5 = PROMPT INCLUDE SCREEN.
H* 3.3 PROCESS LINE ENTRIES.
H* 3.3.1 IF ‘X’, RETURN WITH SELECTED SCREEN NAME.
H* ALSO 1,2,3
H* 3.3.2 IF ‘C’, PROMPT COPY SCREEN.
H* 3.3.3 IF ‘R’, PROMPT RENAME SCREEN.
H* 3.3.4 IF ‘D’, DELETE SCREEN.
H* 3.3.5 IF ‘P’, PRINT SCREEN.
H* 3.3.6 IF ‘?’, DISPLAY SCREEN.
/EJECT
FYDSCSSR#CF E WORKSTN
F #1RR KSFILE #SFRC#1
* ##: Display file.
*
FYDSCDAL1IF E K DISK
F @SCDASA KRENAME@SCDASAI
* SA: SCREEN FILE (0|SCSQ|SCVN)
*
FYDSCDAP UF E K DISK
F @SCDASA KRENAME@SCDASAU
* SA: SCREEN FILE (0|SCSQ|SCVN)
*
/EJECT


E @OP 1 6 1 @RM 7 OPT/RQS MSGID
/EJECT
IPGMDS SDS
* PGM DS
I* PROGRAM ##PGVN
I 81 90 ##PGLB
I 244 253 ##JBVN
I 254 263 ##USVN
I 264 2690##JBNO
/EJECT
IWMMSDA DS 50
* MESSAGE SUBSTITUTION DATA
I 1 20 WMFL
I 1 10 WMFLVN
I 11 20 WMLBV
I 21 30 WMMBVN
I 31 40 WMSCVN
I P 41 432WMSCSQ
/EJECT
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C *ENTRY PLIST * ENTRY LIST
** XALL ‘YSSCNSR’
C PARM $$SCVN 10 O:SEL SCREEN
C PARM $$FLVN 10 I:SCREEN FILE
C PARM $$LBVN 10 I:SCREEN LIB
C PARM $$MBVN 10 I:SCREEN MBR
C PARM #1XX O:TITLE OPTN
C PARM $RTCD 1 O:RETURN CODE
* Y:EXIT PROC
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* INITIALISE
C EXSR ZZINIT
*
* INITIALISE SF & LOAD A PAGE
C SETON 82*
C EXSR BAIZSF *ROLLUP/DOWN
C N81 SETOF 82
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* DISPLAY RECORDS UNTIL EXIT PRESSED
C DO *HIVAL
* DISPLAY SCREEN
C EXSR CAEXFM
*
* PROCESS RESPONSE FROM SCREEN
* CA01: CANCEL & EXIT
C 01 CAS KAEXKY CAS
* CF05: COPY SCREEN
C 05 CAS EGINSC
* SCREEN NAME ENTERED
C 41 CAS DASCVN



* SCREEN START NAME ENTERED
C 40 CAS BAIZSF
* CK27: ROLLUP ON CURRENT POSITION
C 27 CAS BBLDSF
* OTHERWISE READ CHANGED SFL RECORDS FOR SELECTION.
C 81 CAS EARDSF
C END SAC : KAEXKY
*
C END OD *HIVAL
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

/EJECT
CSR BAIZSF BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* CLEAR SUBFILE, POSITION FILE
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* CLEAR SUBFILE
C SETON 80
C WRITE#SFCT#1
C SETOF 80
* RESET NO OF RECS IN SUBFILE & CURRENT POSITION
C Z-ADD*ZERO #1RR 50 81 SETOF 81
C Z-ADD*ZERO #1RRMX 50 SETOF 81
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* POSITION FILE
C ##NXSQ SETLL@SCDASAI 81 *
C 81 MOVE *BLANK SASCVN
* LOAD PAGE.
C EXSR BBLDSF
*
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR BAEXIT ENDSR
/EJECT
CSR BBLDSF BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* LOAD SUBFILE WITH ONE MORE PAGE OF #1PGSZ RECORDS.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* START AT PREVIOUS LAST RECORD
C Z-ADD#1RRMX #1RR
C SETOF 67*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* READ UP TO A SF PAGE AT A TIME
C 1 DO #1PGSZ DO
C READ @SCDASAI 81 CODE ORDER
* FOR EACH RECORD READ :
C N81 DO DO
* CANCEL ROLLUP AS SUCCESSFULLY ACTIONED.
C SETOF 27*
* OUTPUT TO SUBFILE
C MOVE *BLANK #1XX
C Z-ADDSASCSQ ##SCSQ



C MOVELSASCDA ##SCTL
C ADD 1 #1RR 81 81=DSPSFLREC
C SETON 67
C WRITE#SFRC#1
C END OD : *N81
*
C N81 END OD 1 - #1PGSZ
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* DISPLAY ERROR MESSAGE IF NO RECORDS FOUND,
C 81 #1RR IFEQ *ZERO IF
C MOVE ‘YYY7104’ MSGID NO RECORDS
C EXSR ZASNMS
C ELSE XFI #1RR = 0
* DISPLAY MESSAGE IF ROLL UP & NO MORE TO ROLL-UP
C 27 SETON 55
C END FI #1RR = 0
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
SAVE POSITION SO LOAD CAN CONTINUE AT END POINT
C 67 DO
C #1RRMX ADD 1 #1SFRN *
C Z-ADD#1RR #1RRMX
C END OD 67
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR BBEXIT ENDSR
/EJECT
CSR CAEXFM BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* DISPLAY SCREEN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C DO *HIVAL
* DISPLAY MESSAGES & COMMAND KEY LINE
C WRITE#SFCT#Q MESSAGES
* DISPLAY SCREEN.
C EXFMT#SFCT#1 SFL CTL
*
* CLEAR MESSAGES PROM PROGRAM MESSAGE QUEUE
C EXSR ZBCLMS
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
/EJECT
CSR DASCVN BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* SPECIFIED SCREEN NAME ENTERD.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C ##SCVN CABEQ*BLANK DAEXIT
C MOVE ##SCVN SASCVN
C MOVE ‘X’ #1XX
* EXIT PROGRAM WITH SELECTED SCREEN NAME.
C EXSR EBSLLN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =



CSR DAEXIT ENDSR
/EJECT
CSR EARDSF BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* READ & PROCESS A SUBFILE
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* SET NO CHANGE TO SFL ORDER.
C MOVE ‘N’ WWRLSF 1
*
C DO *HIVAL DO
C READC#SFRC#1 70
C N70 DO DO
* CHANGED LINE DATA
C 46
COR 47 EXSR EDCHLN
* ENTER/UPDATE SCREEN (EXIT PROGRAM)
C #1XX CASEQ’X’ EBSLLN CAS
C #1XX CASEQ’1’ EBSLLN
C #1XX CASEQ’2’ EBSLLN
C #1XX CASEQ’3’ EBSLLN
C #1XX CASNE’ ‘ ECPROP
C END SAC #1XX = X
C WWRLSF IFEQ ‘N’
* CLEAR SELECTION LINE UNLESS SFL RE-LOAD PENDING.
C MOVE ‘ ‘ #1XX
C UPDAT#SFRC#1
C END FI WWRLSF=’N’
C END OD N70
C N70 END OD *HIVAL
*
* RE-LOAD SFL IF ORDER CHANGED.
C WWRLSF IFEQ ‘Y’ IF
* COPY COMP MESSAGES TO *PRV
C EXSR ZECMMS
* REDISLAY SUBFILE (DUE TO CHANGED CONTENTS).
C Z-ADD*ZERO ##NXSQ
C EXSR BAIZSF * RELOAD
C END FI WWRFSF=’Y’
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR EAEXIT ENDSR
/EJECT
CSR EBSLLN BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* SELECT LINE & RETURN.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* EXIT WITH SELECTED SCREEN
C MOVE SASCVN $$SCVN
C SETON LR*
C RETRN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =



CSR EBEXIT ENDSR
/EJECT
CSR ECPROP BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* PROCESS OPTION REQUEST.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* SFL RELOAD NECESSARY.
C #1XX IFNE ‘P’ IF
C MOVE ‘Y’ WWRLSF
C END FI #1XX = ‘P’
*
C Z-ADD1 OP 30
C #1XX LOKUP@OP,OP 60*
C MOVE @RM,OP MSGID
* EXECUTE OPTION.
C EXSR FAEXOP
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ECEXIT ENDSR
/EJECT
CSR EDCHLN BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* UPDATE CHANGED LINE DATA.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C KSCDAP KLIST
C KFLD SASCVN
C KFLD WKSCTP 1
C KFLD SASCSQ
C MOVE ‘1’ WKSCTP
C KSCDAP CHAIN@SCDASAU 60
C Z-ADD##SCSQ SASCSQ
C MOVEL##SCTL SASCDA
C UPDAT@SCDASAU
C 46 MOVE ‘Y’ WWRLSF
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR EDEXIT ENDSR
/EJECT
CSR EGINSC BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* INCLUDE SCREEN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* YCPYSCR COMMAND STRING MESSAGE.
* THIS STRING CONTAINS COMMAND PROMPTING INFO.
C MOVE ‘YSD0015’ MSGID
C MOVE *BLANK SASCVN
* EXECUTE OPTION.
C EXSR FAEXOP
C N60 DO DO
* COPY COMP MESSAGES TO *PRV
C EXSR ZECMMS
* REDISLAY SUBFILE (DUE TO CHANGED CONTENTS).



C MOVE *ZERO ##NXSQ
C EXSR BAIZSF * RELOAD
C END OD N60
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR EGEXIT ENDSR
/EJECT
CSR FAEXOP BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* EXECUTE OPTION.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* RETRIEVE COMMAND STRING.
C MOVE SASCVN WMSCVN
C Z-ADD##SCSQ WMSCSQ
C EXSR ZCRTMS
* EXEC COMMAND.
C CALL ‘QCMDEXC’ 60 *
A D* MSG MSGLEN
C PARM MSG I: RQST STR
C PARM MSGLEN W15N5 155 I: RQST LEN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR FAEXIT ENDSR
/EJECT
CSR KAEXKY BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* CK01:CANCEL AND EXIT
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* COMMAND CANCELLED (ESCAPE MESSAGE)
C MOVE ‘Y’ $RTCD
C SETON LR
C RETRN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR KAEXIT ENDSR
/EJECT
CSR ZASNMS BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* SEND MESSAGE TO PROGRAM Q
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C N99 CALL ‘YYPGMSC’ Send message
C PARM ##PGVN 10 I:PGM QUEUE
C PARM ‘*SAME’ ##PGRL 5 I:REL QUEUE
C PARM MSGID 7 I: MSG ID.
C PARM MSGDTA132 I:MSGDATA.
C PARM ‘*INFO ‘ MSGTYP 7 I:MSGTYPE.
C SETON 99
*
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ZAEXIT ENDSR
/EJECT
CSR ZBCLMS BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =



* Clear message queue
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C CALL ‘YYCLMSC’ Clear message
C SETOF 99
*
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ZBEXIT ENDSR
/EJECT
CSR ZCRTMS BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* RETRIEVE MESSAGE.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C CALL ‘YYRTMSC’ RTVM MESSAGE
C PARM MSGID 7 I:MESSAGEID.
C PARM WMMSDA MSGDTA 50 I:MSG DATA
C PARM MSG 132 O:MSG TEXT
C PARM MSGLEN 50 O:MSG LENGTH
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ZCEXIT ENDSR
/EJECT
CSR ZECMMS BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* COPY COMP MESSAGES TO *PRV CPP.
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C CALL ‘YYCMMSC’
C PARM ‘YDSCEDC@’W10X 10 I: PGM Q NAME
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ZEEXIT ENDSR
/EJECT
CSR ZZINIT BEGSR
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* INITIALISATION
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
C MOVE *BLANK $RTCD
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* SETUP MESSAGE SUBSTITUTION DATA.
C
C MOVE $$LBVN WMLBVN
C MOVE $$MBVN WMMBVN
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* GET COMPANY NAME.
C *NAMVAR DEFN YYCOTXA YYCOTX
C IN *NAMVAR
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*
* SUBFILE PAGE SIZE
C Z-ADD15 #1PGSZ 30 !!
* SUBFILE INITIAL RECORD AT
C Z-ADD1 #1SFRN SFL POSN
C Z-ADD*ZERO #1RRMX MAX RECNO
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*



C MOVE *BLANK SASCVN
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
CSR ZZEXIT ENDSR
** @OP,@RM OPTION/REQUEST MESSAGE ID.
?YSD0011
CYSD0010
RYSD0016
DYSD0007
PYSD0035
GYSD0024