RPG OPM fixed-format
RPG was once a fixed-format language.
Fixed-format RPG, rightly or wrongly, is always associated with the Original Program Model (OPM) style of application development. This is an OPM example of an interactive program.The absence of the MAIN keyword is an message to the compiler signaling that traditional RPG cycle instructions are included in the executable module. All cycle processing instructions such as level totals, and primary file operations are functional. In current terms this type of program would be called a Cycle-Main program as opposed to a Linear-Main program.
1 - All heading and detail lines (H or D in position 17 of the output specifications) are processed.
2 - The next input record is read and the record identifying and control level indicators are set on.
3 - Total calculations are processed. They are conditioned by an L1 through L9 or LR indicator, or an L0 entry.
4 - All total output lines are processed. (identified by a T in position 17 of the output specifications).
5 - It is determined if the LR indicator is on. If it is on, the program is ended.
6 - The fields of the selected input records are moved from the record to a processing area. Field indicators are set on.
7 - All detail calculations are processed (those not conditioned by control level indicators in positions 7 and 8 of the calculation specifications) on the data from the record read at the beginning of the cycle.
The Cycle Reads and Writes
This program was designed to create a popup window to overlay whatever panel was on display. It allowed the user to enter a system command, similar to the command line offered by the OS.
H/TITLE ** QCL POP UP WINDOW PROGRAM **
H
****************************************************************
* PROGRAM NAME - MIS420RP *
* *
* FUNCTION - THIS PROGRAM IS DESIGNED TO OVERLAY THE *
* CURRENT DISPLAY AND PROVIDE A COMMAND ENTRY. *
* *
* PROGRAMMER - STEVE CROY 12/15/89 *
****************************************************************
****************************************************************
* MODIFICATION LOG *
* *
* DATE PROGRAMMMER DESCRIPTION *
* *
****************************************************************
****************************************************************
* PROGRAM INTERFACE SECTION *
* *
* CALLED BY PROGRAMS: *
* CALLS PROGRAMS: *
****************************************************************
****************************************************************
* ** INDICATOR USAGE *** *
* ** ON ** ** OFF ** *
* *
* 60 -- DUMMY INDICATOR FOR SETATNPGM *
* 70 -- ROLLUP *
* CF12-- HELP *
* CF01-- EXIT *
* CF03-- DUPLICATE *
* CF04-- PROMPT *
* *
* ** ERROR INDICATORS ** *
* 98 FIELD IS BLANK *
* 96 CMD TO BE REPEATED IS FOUND *
* 94 THIS LINE NOT OCCUPIED BY A COMMAND*
* 92 COMMAND IS TOO LONG; SHD BE < 256 *
* 91 COMMAND TOO LONG TO BE DUPLICATED *
* 77 - 90 FIELDS 1-14 RSPCTVLY CONTAIN BLANKS*
* 75 ERROR ON CALL "QCACHECK" *
* 73 FOUND THE NEXT COMMAND *
* *
****************************************************************
****************************************************************
* SUBROUTINES DESCRIPTION *
****************************************************************
* BEGIN ONE TIME PASS ONLY SUBROUTINE *
* DUPLIC DUPLICATE COMMAND - F9 PRESSED *
* ENDPGM END THE PROGRAM - F3 PRESSED *
* NORMAL PROCESS THE COMMAND *
* PROMPT PROMPT THE COMMAND - F4 PRESSE D *
* ROLLUP ROLLUP THE DISPLAY *
* HELP HELP - F12 DETECTED, HELP KEY *
****************************************************************
FMIS420DFCP F 281 WORKSTN
F KNUM 2
F KID WSID
F KIND 69
F KINFDS FILEDS
E CL 1 4 80 SET ATTENTION
E FLD 14 20 INPUT FIELDS
E FL2 14 20 STORE FLD HERE
E FL3 14 20 FOR ECHOING CMDS
E CMD 256 1 THE COMMAND
E VAC 14 2 CMD/MSG IND
IMIS420DFAA 69 281 C1
I 1 20 FLD,1 77
I 21 40 FLD,2 78
I 41 60 FLD,3 79
I 61 80 FLD,4 80
I 81 100 FLD,5 81
I 101 120 FLD,6 82
I 121 140 FLD,7 83
I 141 160 FLD,8 84
I 161 180 FLD,9 85
I 181 200 FLD,10 86
I 201 220 FLD,11 87
I 221 240 FLD,12 88
I 241 260 FLD,13 89
I 261 280 FLD,14 90
IFILEDS DS
I* File status data structure for cursor line position only
I B 370 3710CURSOR
I 370 370 CURLIN
I DS
I B 1 20W$LINE
I 2 2 WLINE
I B 3 40W$POS
I 4 4 WPOS
I* Program status data structure
I SDS
I *PROGRAM PRGNAM
I 43 46 MSGID
I 91 170 ESSAGE
I 244 253 JOB
I 254 263 USER
I 264 269 JOBNBR
ILONGUN DS
I* Data structure which includes question mark (?) for prompting
I 1 1 QM
I 2 255 MAIN
/EJECT
C*----------------------------------------------------------------
C* M A I N
C*----------------------------------------------------------------
C/SPACE
C FIRST CASEQ*BLANK *INZSR FIRST TIME ONLY
C ENDCS
C WNDPRM PLIST
C PARM P$PGM
C PARM P$FMT
C/SPACE
C SETOF 75 Indicators off
C MOVEA*IN,77 SAV14 14
C/SPACE
C *INKC CASEQ#ON ENDPGM F3- END PROGRAM
C *INKI CASEQ#ON DUPLIC F9- REPEAT CMD
C *INKD CASEQ#ON PROMPT F4- PROMPT CMD
C *INKA CASEQ#ON HELP Help Request
C *IN70 CASEQ#ON ROLLUP ROLLUP detected
C SAV14 CASNE#EMPTY NORMAL NORMAL PROCESS
C ENDCS
C X CASGE14 ROLLUP MOVE DISPLAY UP
C ENDCS IF NECESSARY
C* Use the toggle key to determine if S/38 or AS/400
C* command environment is to be used to check commands
C *INKJ IFEQ #ON
C #S38 IFEQ #YES
C MOVEL#NO #S38
C ELSE
C MOVE #YES #S38
C ENDIF
C MOVE #S38 *IN51
C ENDIF
/EJECT
C*================================================================
C* Program initialization subroutine first time pass only
C*================================================================
CSR *INZSR BEGSR
C MOVELPRGNAM P$PGM 10 PROGRAM
C MOVEL*BLANKS P$FMT 10 FORMAT
C MOVEL'1' #YES 1
C MOVEL'1' #ON 1
C MOVEL'0' #OFF 1
C MOVEL'0' #NO 1
C MOVEL'0' #S38 1
C Z-ADD1 #ONE 10
C MOVELCL,1 W$CMD 80
C CALL 'QCMDEXC' 60 SETATNPGM
C PARM W$CMD
C PARM 80 CMDLEN
C MOVE '?' QM
C Z-ADD*ZERO NOC Nbr of commands
C Z-ADD#ONE X 20 First input
C MOVE *ALL'1' #EMPTY 14
C MOVE '1' FIRST 1
CSR ENDSR
/SPACE
C*=====================================================================
C* DUPLIC - IF COMMAND KEY 09 WAS ENTERED DUPLICATE
C*=====================================================================
CSR DUPLIC BEGSR
C X DO 14 W 30 Clear unused
C MOVE *BLANKS FLD,W portion
C ENDDO
C*---------------------------------------------------------------------
C* Determine relative position of cursor to determine if cursor
C* is at action line or, at succeeding lines
C*---------------------------------------------------------------------
C Z-ADD*ZEROS W$LINE
C Z-ADD*ZEROS W$POS
C MOVE CURLIN WLINE W$LINE NOW NUM
C Z-ADDW$LINE NO 30
C Z-ADDW$LINE Y 30
C NO IFGT 3 If within the
C NO ANDLT18 screen display
C SUB 3 NO Which field?
C MOVE VAC,NO WHAT 2 CMD/MSG/BLK
C NO IFGE X Repeat previus
C MOVE NOC WHAT Get the number
C ENDIF of last comand
C ELSE Else its not in
C GOTO ENDDUP Exit from subr
C ENDIF End "NO IFGT
C*
C* Determine if cursor is positioned at a message or unused line
C*
C WHAT IFNE 'MM' IF NOT MSG
C WHAT ANDNE' ' OR NOT BLANK
C Z-ADD#ONE GO 20 GET THE FIRST
C WHAT LOKUPVAC,GO 96OCCURRENCE
C*
C* Determine where command begins and ends based on the array VAC
C*
C 96GO DO 14 ZZ 20 GET THE LAST
C VAC,ZZ COMP WHAT 9494 DIFFT FR PREV
C N94 ENDDO ENDDO "DO 14
C ZZ IFNE GO NOT SAME LINE
C ZZ SUB GO LS NBR OF LINES
C SUB #ONE ZZ THE LAST LINE
C ELSE ELSE
C MOVE #ONE LS ONE LINE ONLY
C ENDIF ENDIF "ZZ IFNE
C*----------------------------------------------------------------
C MOVEAFLD,GO FL3 SAVE IT FIRST
C Z-ADDX PS 20 A PSEUDO-X PTR
C DO LS ZZ DO SEVERAL TMS
C MOVE FL3,ZZ FLD,PS FROM START UP
C ADD #ONE PS NEXT
C*----------------------------------------------------------------
C* If beyond point of ROLLUP, execute the subroutine to roll
C*----------------------------------------------------------------
C PS IFGT 14 If beyond
C EXSR ROLLUP ROLLUP
C Z-ADDX PS
C Z-ADD*ZERO ZZ
C ENDIF
C ENDDO
C*---------------------------------------------------------------
C ENDIF
CSR ENDDUP ENDSR
/SPACE
C*================================================================
C* ENDPGM - CLOSE ALL FILES AND EXIT THE PROGRAM
C*================================================================
CSR ENDPGM BEGSR
C SETON LR CLOSE ALL
C RETRN FILES AND
CSR ENDSR RETURN
/SPACE
C*================================================================
C* NORMAL - IF ANY OR NO COMMAND OR CF4 WAS ENTERED
C*================================================================
CSR NORMAL BEGSR
C*
C* If not CF4 get the last line of the command; else this has been
C* done already
C *INKD IFNE '1' If not CF4
C 1 DO 14 LS 20 Get last line
C 91 SUB LS N 20 from the last
C *IN,N COMP '1' 98 on if blank
C 98 ENDDO Enddo "1 DO 14
C N SUB 76 LS THE LAST LINE!
C*----------------------------------------------------------------
C* Assemble the command to execute. Do first to last, assembling
C* the command end-to-end. If the assembled command exceeds 256
C* bytes, execute the end-program subroutine.
C*----------------------------------------------------------------
C MOVEA*BLANKS CMD,1
C Z-ADD#ONE PT 30 Starting point
C X DO LS VZ 20 First to last
C MOVEAFLD,VZ CMD,PT Put end-to-end
C ADD 20 PT Next endpoint
C PT COMP 256 92
C N92 ENDDO Enddo "X DO LS
C 92 EXSR ENDPGM
C MOVEACMD COMAND VALID COMMAND
C ENDIF
C*----------------------------------------------------------------
C* Invoke the generic command execution program, if there are no
C* syntax errors, execute the command and check for messages.
C*----------------------------------------------------------------
C *IN75 IFNE '1'
C #S38 IFEQ #YES
C CALL 'MIS420CL' Execute command
C ESSAGE PARM COMAND256
C PARM 256 CMDLEN 155
C PARM ' ' ANYMSG 1
C ELSE
C CALL 'MIS421CL' Execute command
C ESSAGE PARM COMAND256
C PARM 256 CMDLEN 155
C PARM ' ' ANYMSG 1
C ENDIF End "N75 DO
C ENDIF End "N75 DO
C*---------------------------------------------------------------------
C* If error occurred on CF4 routine (*IN75=1) or message was received
c* get the message and indicate message handling has been performed
C*---------------------------------------------------------------------
C *IN75 IFEQ '1'
C ANYMSG OREQ '1'
C MOVELESSAGE COMAND
C LS IFLT 14 Not last line
C ADD 1 LS Next available
C MOVELCOMAND FLD,LS First 20 bytes
C MOVEA'MM' VAC,LS
C MOVE '0' *IN,75
C MOVE '0' ANYMSG
C ENDIF
C ENDIF
C*---------------------------------------------------------------------
C* Protect used fields, place in array and turn off underline
C* mark as executed command in VAC array
C*---------------------------------------------------------------------
C ADD #ONE NOC 20
C MOVE NOC NOCK 2
C 1 DO LS LM 20
C MOVE '1' *IN,LM
C VAC,LM IFEQ ' '
C MOVEANOCK VAC,LM
C ENDIF
C ENDDO
C*---------------------------------------------------------------------
C* Increment X to get the value of next command input line
C* Show colons for cursor positions
C*---------------------------------------------------------------------
C LS ADD 20 DT 20
C MOVE '1' *IN,DT
C LS ADD #ONE X
C ENDSR E X I T
/SPACE
C*=====================================================================
C* PROMPT - PROMPT FOR COMMAND PARAMETERS OR ALL COMMAND MENU
C*=====================================================================
C PROMPT BEGSR
C*
C* If not empty get the last line of the command
C*
C MOVEA*BLANKS CMD,1
C SAV14 IFNE #EMPTY ISN"T IT EMPTY
C 1 DO 14 LS 20 GET LAST LINE
C 91 SUB LS N 20 FROM THE LAST
C *IN,N COMP '1' 98IS ON IF BLANK
C 98 ENDDO ENDDO GET LAST
C N SUB 76 LS THE LAST LINE!
C*----------------------------------------------------------------
C* Assemble the command to execute. Do first to last, assembling
C* the command end-to-end. If the assembled command exceeds 256
C* bytes, execute the end-program subroutine.
C*----------------------------------------------------------------
C Z-ADD#ONE PT 30
C X DO LS VZ 20
C MOVEAFLD,VZ CMD,PT
C ADD 20 PT
C PT COMP 256 92
C N92 ENDDO
C *IN92 CASEQ#ON ENDPGM
C ENDCS
C ENDIF
C*----------------------------------------------------------------
C* Call the prompter, move question mark and command into COMAND
C* and perform syntax checking and prompt
C*----------------------------------------------------------------
C MOVEACMD COMAND
C MOVE ' ' MSGID Blank out
C MOVELCOMAND MAIN
C MOVELLONGUN COMAND
C #S38 IFEQ #YES
C CALL 'QCACHECK' 75
C PARM COMAND
C PARM 256 CMDLEN
C ELSE
C CALL 'QCMDCHK' 75
C PARM COMAND
C PARM 256 CMDLEN
C ENDIF
C* If command syntax is correct adjust the screen
C MOVEACOMAND CMD Valid Command
C *IN75 IFNE '1'
C Z-ADD#ONE PT Set the pointer
C Z-ADDX VZ Set field point
C MOVEACMD,PT CMDER 3
C CMDER DOWNE' '
C VZ IFGT 14
C EXSR ROLLUP
C Z-ADD#ONE PT
C Z-ADDX VZ
C MOVEACMD,PT CMDER
C ELSE
C MOVEACMD,PT FLD,VZ New comand goes
C ADD #ONE VZ to display only
C ADD 20 PT if its not very
C PT COMP 256 92 long; or else
C *IN92 IFEQ #OFF
C MOVEACMD,PT CMDER To be compared
C ENDIF
C ENDIF
C N92 ENDDO
C VZ SUB #ONE LS Adjust lastline
C ELSE
C COMAND IFNE *BLANKS If not empty
C MOVELCOMAND LONGUN If cancelled
C MOVELMAIN COMAND reshow screen
C ENDIF Endif "COMAND
C ENDIF Endif "IN75 IF
C COMAND CASNE*BLANKS NORMAL No abort issued
C ENDCS End "COMAND CAS
CSR ENDPRO ENDSR
/SPACE
C*================================================================
C* ROLLUP - ROLLUP COMMAND ENTRY
C*================================================================
CSR ROLLUP BEGSR
C X DOULT14 Until last two
C *IN70 ANDNE'1' and not rollup
C MOVE '0' *IN70 Roll done once
C* Initialize all save areas
C MOVE '0' *IN73
C MOVE *ALL' ' SAYWOT 28
C MOVE *ALL'0' SAYIND 34
C MOVEA*ALL' ' FL2
C* Where to begin - the second command
C MOVEAVAC,1 FCMEN 2 Change it to a
C MOVE FCMEN FCMDEN 20 numeric field
C ADD #ONE FCMDEN then increment
C MOVE FCMDEN FCMEN for next comand
C $REFND TAG
C Z-ADD#ONE K 20 Init pointer
C FCMEN LOKUPVAC,K 73=Next pointer
C* If search for next command fails, search for next inputable line
C *IN73 IFNE '1'
C MOVE ' ' FCMEN
C GOTO $REFND
C ENDIF
C* Save pertinent fields before initializing
C MOVEAFLD,K FL2
C MOVEAVAC,K SAYWOT
C MOVEA'000000' *IN,15 Prevent fallout
C MOVEA'000000' *IN,34 Prevent fallout
C MOVEA*IN,K SAYIND
C* Initialize those fields CLEAN UP
C 1 DO 14 K
C MOVE ' ' VAC,K
C MOVE *ALL' ' FLD,K
C MOVE '0' *IN,K
C ADD 20 K Especially the
C MOVE '0' *IN,K screen indics
C SUB 20 K from 1-14,21-34
C ENDDO
C*----------------------------------------------------------------
C* Set previous values to fields from save areas, initialize the
C* pointer using blanks to find the new value of X.
C*----------------------------------------------------------------
C MOVEASAYWOT VAC
C MOVEAFL2 FLD
C MOVEASAYIND *IN
C Z-ADD#ONE X
C ' ' LOKUPVAC,X 73=New pointer
C X ADD 19 XS 20
C*----------------------------------------------------------------
C* Test for any messages associated with the last command.
C*----------------------------------------------------------------
C *IN75 IFNE '1' If none
C ANYMSG ANDNE'1'
C *INKD IFNE '1' and not prompt
C MOVE '1' *IN,XS put the colon
C ENDIF
C ELSE Else get
C MOVELESSAGE COMAND the following:
C MOVELCOMAND FLD,X
C MOVEA'MM' VAC,X the message
C MOVE '1' *IN,X the protector
C MOVE '0' *IN,XS colons
C ADD #ONE X next
C X ADD 19 XS
C MOVE '1' *IN,XS
C MOVE '0' *IN,75 Reset message
C MOVE '0' ANYMSG flags
C ENDIF
C ENDDO
C ENDSR
C*================================================================
C* HELP SUBROUTINE, OVERLAY WITH TEXT WINDOW
C*================================================================
C HELP BEGSR
C MOVEL'MIS42001'P$FMT
C CALL 'MIS440CL'WNDPRM E
C ENDSR
OMIS420DFD 1P
O OR N1PNKC
O K8 'MIS42001'
O FLD,1 20
O FLD,2 40
O FLD,3 60
O FLD,4 80
O FLD,5 100
O FLD,6 120
O FLD,7 140
O FLD,8 160
O FLD,9 180
O FLD,10 200
O FLD,11 220
O FLD,12 240
O FLD,13 260
O FLD,14 280
** SET ATTENTION KEY TO POP UP MENU
SETATNPGM PGM(MIS421RP)
SETATNPGM PGM(MIS420RP)
AS/400 Environment
S/38 Environment
Fixed-Format Sort
This is an example of a bubble sort in fixed-format RPG. The small array is loaded with three digit values. The entries are not in numerical sequence. The demo program loops through and performs a 'bubble' sort rearranging the values so that they are in sequence from lowest to highest.
/TITLE ** DISPLAY BUBBLE SORT EXAMPLE **
H DEBUG(*YES)
********************************************************************
FCH5P11 CF E WORKSTN
F INFDS(DSPDS)
*===================================================================
* Externally defined data structures
*-------------------------------------------------------------------
D KEYDS E DS EXTNAME(MISKEYPF)
D PGMDS ESDS EXTNAME(MISSTSDA)
D DSPDS E DS EXTNAME(MISDSPDA)
*-------------------------------------------------------------------
* Array of 10, 3 digit numbers, defined as a data structure
*-------------------------------------------------------------------
DARRAY DS 30
D SEQ 3 0
D DIM(10) CTDATA PERRCD(10)
*-------------------------------------------------------------------
* data structure to hold array values before sort
*-------------------------------------------------------------------
D DS INZ
DBEFORE 30
D Z$ARR0 3 0 OVERLAY(BEFORE)
D Z$ARR1 3 0 OVERLAY(BEFORE:4)
D Z$ARR2 3 0 OVERLAY(BEFORE:7)
D Z$ARR3 3 0 OVERLAY(BEFORE:10)
D Z$ARR4 3 0 OVERLAY(BEFORE:13)
D Z$ARR5 3 0 OVERLAY(BEFORE:16)
D Z$ARR6 3 0 OVERLAY(BEFORE:19)
D Z$ARR7 3 0 OVERLAY(BEFORE:22)
D Z$ARR8 3 0 OVERLAY(BEFORE:25)
D Z$ARR9 3 0 OVERLAY(BEFORE:28)
*-------------------------------------------------------------------
* data structure to hold after image of sorted array
*-------------------------------------------------------------------
D DS INZ
DAFTER 30
D Z$NEW0 3 0 OVERLAY(AFTER :1)
D Z$NEW1 3 0 OVERLAY(AFTER :4)
D Z$NEW2 3 0 OVERLAY(AFTER :7)
D Z$NEW3 3 0 OVERLAY(AFTER :10)
D Z$NEW4 3 0 OVERLAY(AFTER :13)
D Z$NEW5 3 0 OVERLAY(AFTER :16)
D Z$NEW6 3 0 OVERLAY(AFTER :19)
D Z$NEW7 3 0 OVERLAY(AFTER :22)
D Z$NEW8 3 0 OVERLAY(AFTER :25)
D Z$NEW9 3 0 OVERLAY(AFTER :28)
*-------------------------------------------------------------------
* Define constants
*-------------------------------------------------------------------
D #NO C CONST('N')
D #YES C CONST('Y')
*-------------------------------------------------------------------
* START of work fields
*-------------------------------------------------------------------
D END_SORT S 1 INZ(#NO)
D HOLD S 3 0
D I S 3 0 INZ(1) index
D X S 3 0 INZ(1) next element
D NXT_PASS S 3 0 INZ(10)
D PASS S 3 0 INZ(10)
*-------------------------------------------------------------------
* END of work fields
*-------------------------------------------------------------------
* Load array to the before image for display
C MOVE ARRAY BEFORE
*
C DOU PASS = 1 Do until pass = 1
C EVAL END_SORT = #YES Assume sort complet
C EVAL NXT_PASS = 1 Set element pass
C EVAL I = 1 Initialize index
C EVAL X = 1 Initialize X
C DOW NXT_PASS < 10 While less than 10
C EVAL X = X + 1
C IF SEQ(I) > SEQ(X) If an element was
C EVAL HOLD = SEQ(I) moved, do not end
C EVAL SEQ(I) = SEQ(X) the sort
C EVAL SEQ(X) = HOLD
C EVAL END_SORT = #NO
C ENDIF End if
C EVAL I = I + 1 Increment index
C EVAL NXT_PASS = NXT_PASS + 1 Increment elem pass
C ENDDO End inner loop
C IF END_SORT = #YES If elements are
C EVAL PASS = 1 sequenced end sort
C ELSE else continue
C EVAL PASS = PASS - 1 Decrement array pass
C ENDIF End if
C ENDDO End do outer loop
* Load array to the after image for display
C MOVE ARRAY AFTER
*-------------------------------------------------------------------
* Display panel, wait for F3 to exit program.
*-------------------------------------------------------------------
C DOU #KEY = #F3
C EXFMT CH5P1101
C ENDDO
* Exit program
C EVAL *INLR = *ON
C RETURN
*===================================================================
* END of mainline calculations, begin subroutine section
*===================================================================
C *INZSR BEGSR
* define function keys
C CALL 'MIS500RP'
C PARM KEYDS
C ENDSR
** Sequence Array
002006004008010012089068045037
