Monday, Aug 20, 2012
Background
While cleaning out my shelves I came across this old code sample disk. The company is long gone and the language is small in today's standards. RPG II's roots went back to punch-card days:
- Column position on each line was important
- Column 6 contains a one letter "record type", e.g. H = header, C = calculation
- The OPCODE in the middle of the calc spec was max 6 chars long, e.g. EXSR = execute subroutine.
Technically, this code is written in RPG II 1/2 which was a commercial 3rd party tool/enhancement that added stuff like "IF" and "DO" instead of having to use the left-hand indicators (e.g. N90) to condition execution of the line.
0001 H 024 B 1 SAL010
0002 H*===============================================================
0003 H*@ PROPERTY OF XXXXXXXXXXXX, XXXXX, NEW HAMPSHIRE 1988
0004 H*T Generate #GSORT OCL to retrieve customer/item sales history
0005 H*M 144 07Dec88 Written *** Uses RPG II 1/2 ***
0005 H*D Accepts up to 18 selection criterion and generates the necessary
0005 H*D OCL code to run #GSORT to extract/sort the customer/item sales
0005 H*D history file. The calling report proc is stored in LDA to
0005 H*D determine various report-specific sort specs such as the header
0005 H*D and field specs. To add another procedure the following must
0005 H*D be done: Add proc name to PROC array, add the new sort header
0005 H*D spec to HDR, add the record type spec(s) to REC if necessary,
0006 H*S EDIT$ Edits the selection criteria
0006 H*S INIT$ Program Initialization
0009 H*I 40-57 Screen error indicators.
0014 H*===============================================================
0015 FWORKSTN CD E WORKSTN
0019 FPROC O 120 120 DISK
0021 E* workstation arrays
0022 E $FN 18 2 0 field number
0022 E $OP 18 2 operation code
0022 E $CR 18 15 selection criteria
0021 E* program work arrays
0022 E OPNS 6 6 2 operation codes
0022 E PROC 8 8 6 procedure names
0022 E TABPRC 8 8 6 TABNUM 2 0 proc names & # of #GSORT field specs
0021 E* sort specs (OCL code)
0022 E BEG 1 5 80 common 'beginning' OCL statements
0022 E HDR 1 8 80 header specs
0022 E REC 1 11 80 record selection specs
0037 I UDS
0038 I 1 8 @USER
0039 I 9 10 @WS
I 505 512 @PROC ?WS? + ?TIME?
0040 C*==============================================HILOEQ===========
0042 C #@INIT IFNE 1
0043 C EXSR INIT$
0044 C END
C*
C T$1000 TAG
C EXFMTSCRN100
C KG SETON U7
C KG GOTO T$9999
C* call edit routine to check for errors
C EXSR EDIT$
C* if any error occured, redisplay screen
C #@ERR IFEQ 1
C GOTO T$1000
C END
C* if Cmd/1 wasn't pressed loop back and redisplay
C NKA GOTO T$1000
C* set array element pointer for procedure name
C SETOF 90
C Z-ADD1 Z 20
C @PROC LOKUPPROC,Z 90
C N90 DO
C SETON U7 *proc not found - cancel job
C GOTO T$9999
C END
C* display 'prompt' screen
C EXCPTWK110
C* output // COPY statement with proc name
C EXCPTOCL1
C* output common begining sort specs
C DO 5 X
C EXCPTOCL2
C END
C* output sort header spec
C EXCPTOCL3
C* output user-selected record type specs
C MOVE *BLANKS #AND *clear 'AND' code
C DO 18 X
C $FN,X IFGE 1 *assume if valid $FN
C $FN,X IFLE 18 * then valid $OP and $CR
C SETOF 90
C Z-ADD1 Y 20
C $OP,X LOKUPOPNS,Y 90*assume valid OPN since passed EDIT$
C EXCPTOCL4
C END
C MOVE 'A' #AND *set 'AND' code for remainder of loop
C END
C* output field records for this proc
C DO 28 X
C SETOF 90
C @PROC IFEQ PNAM,X
C EXCPTOCL5
C END
C END
C*==============================================HILOEQ===========
CSR EDIT$ BEGSR
C*
C Z-ADD0 #@ERR 10 *clear error flag
C DO 18 X 20 DO once for each screen line
C X ADD 39 Y 20 point to screen indicator
C Z-ADD0 *IN,Y clear screen indicator
C* if field num is blank, blank out operation and criterion
C $FN,X IFEQ *BLANKS
C $FN,X OREQ *ZEROS
C MOVE *BLANKS $OP,X
C MOVE *BLANKS $CR,X
C GOTO EDITX
C END
C* if operation is blank, blank out field num and criterion
C $OP,X IFEQ *BLANKS
C $OP,X OREQ *ZEROS
C MOVE *ZEROS $FN,X
C MOVE *BLANKS $CR,X
C GOTO EDITX
C END
C* check for valid field number range
C $FN,X IFLT 1
C $FN,X ORGT 11
C Z-ADD1 *IN,Y turn on corresponding indicator
C Z-ADD1 #@ERR set error flag
C END
C* check for valid operation code
C SETOF 90
C $OP,X LOKUPOPNS 90
C N90 Z-ADD1 *IN,Y turn on corresponding indicator
C N90 Z-ADD1 #@ERR set error flag
C END .END
C*
C EDITX TAG
C*
CSR ENDSR
C*==============================================HILOEQ==========
OPROC E OCL1
O 23 '// COPY LIBRARY-P,NAME-'
O @PROC 31
O E OCL2
O COM,X 80
O E OCL3
O HDR,Z 80
O E OCL4
O REC,X 80
O #AND 7
O OPN,Y 18
O $CR,X 34
O E OCL5
O FLD,X 80
** operation codes
EQGEGTLELTNE
** procedure names
SAL299SAL297SAL296SAL295SAL294SAL293SAL292SAL291
** table of procedure names & number of sort field specs
SAL29905SAL29703SAL29603SAL29503SAL29403SAL29303SAL29205SAL29103
** common 'beginning' sort specs
// REGION SIZE-64
// LOAD #GSORT
// FILE NAME-INPUT,LABEL-PRO.SCD,DISP-SHR
// FILE NAME-OUTPUT,LABEL-SAL010?WS?
// RUN
** header specs for each program
// HSORTA 17A 3 N *SAL299
// HSORTA 18A 3 N *SAL297
// HSORTA 18A 3 N *SAL296
// HSORTA 5A 3 N *SAL295
// HSORTA 18A 3 N *SAL294
// HSORTA 18A 3 N *SAL293
// HSORTA 8A 3 N *SAL292
// HSORTA 18A 3 N *SAL291
** common record selection and field specs (insert AND code & test condition)
// I C 3 8 D *customer number
// I C 9 23 C *item number
// I C 36 36 C *sbu
// I C 37 38 C *product group
// I C 548 548 C *product line
// I C 549 550 C *product class
// I C 39 40 C *item class
// I C 41 42 C *customer type
// I C 43 44 C *company code
// I C 33 34 C *sales region
// I C 35 35 C *sales territory
** proc names and their respective #GSORT field specs
SAL299// FNC 33 34 *sales region