Reference file for code syntax used seldom enough to be forgotten; array overlays, SORTA, date formats, tables, multi-occur-DS's, SDS, plus.
At one time, I took an rpg program that did something that is not done very often and saved it as a sample for my reference and, sometimes when i would write some routine that was rare enough to be forgotten, i would save that little piece of code in it so that it became a convenient place to find the syntax etc. of a rarely needed routine. I will include parts of it here
Sample ILE RPG/400
H dftactgrp(*no) actgrp('QILE')
F*========================================================
F*-------- := - - --- - ------- ---------------------------
FONLSECFP UF A E DISK
* format: ONLSECR Key: *none
FCUSTMPL IF E K DISK
* format: CUSTMFR Key: CMPHON
FINVMFL IF E K DISK
* format: INVFMR Key: IFPHON, IFINVD(D)
FSTANDA O E DISK USROPN RENAME(STANDAR:WRKFMT1)
* format: STANDAR Key: 'UC'
F*-------- := - - --- - ------- ---------------------------
FCATRQDL IF E K DISK
F*-------- := - - --- - ------- ---------------------------
FQSYSPRT O F 132 PRINTER OFLIND(*INOF) USROPN INFDS(PRINTDS)
F*-------- := - - --- - ------- ---------------------------
**---------------------------------------------------------------
D*----- =-- --- --- = ---------------------------
D** D E F I N I T I O N S
D*----- =-- --- --- = ---------------------------
D* 3 tables
D MSG S 65 DIM(4) CTDATA PERRCD(1)
D CMD S 80 DIM(2) CTDATA PERRCD(1)
D CLR S 80 DIM(1) CTDATA PERRCD(1)
* a pair of tables / arrays
* 2 tables together: state abbreviations and state names:
D TABSTABREV S 2 DIM(51) CTDATA PERRCD(1)
D TABSTNAME S 21 DIM(51) ALT(TABSTABREV)
D*----- =-- --- --- = ---------------------------
D REPc S 3
D CCODES S 34
D CAT# S 2 0 INZ(0)
D*----- =-- --- --- = ---------------------------
D Name S 20
D Long_name S +5 LIKE(Name)
D Dim20 S LIKE(Name) DIM(20) INZ(*ALL'X')
D*----- =-- --- --- = ------------------------------------
DPRINTDS DS
D PRTLINE 367 368B 0
D PRTPAGE 369 372B 0
D*----- =-- --- --- = ---------------------------
D* 1 multi-occur.data struct.:
D INVDS DS 80 OCCURS(30)
D IFPHON 1 10 0
D IFINVD 11 16 0
D IFCOMP 21 50
D IFCONT 51 80
D*----- =-- --- --- = ---------------------------
D CMD DS 160
D CMD1 1 80
D CMD2 81 160
D USRDTA 129 138
D*----- =-- --- --- = ---------------------------
D DS
D* MMDDYY to YYMMDD (MUCH FASTER than the 'MULT'opcode!)(40/3)
D* move inyy otyy ~~~~~~~~~~~ ... do not use mult on
D* every read of a rec.!
D OUTYY 1 2
D OUTYMD 1 6 0
D INMDY 3 8 0
D INYY 7 8
D*----- =-- --- --- = ---------------------------
* ---------------------- -= - -----------------
D dateISO S D DATFMT(*ISO) CCYYMMDD
D dateCYMD S 8S 0 inz(0)
D MO#of S 3S 0 inz(0)
*
D REACT S 5 0
D CANCL S 5 0
D ACTIV S 5 0
*
D*DATEiso * S D DATFMT(*ISO) INZ(D'1997-05-28')
* *
D*DATEusa * S D DATFMT(*USA) INZ(D'05-28-1997')
* *
D*DATEmdy * S D DATFMT(*MDY) INZ(D'05/28/97')
* *
D*DATEymd * S D DATFMT(*YMD) INZ(D'97/05/28')
* *
D*DATEeur * S D DATFMT(*EUR) INZ(D'31.12.1992')
* (europe)
D*----- =-- --- --- = ---------------------------
D CCODES 12 45
D CAT# 172 173 0
D*----- =-- --- --- = ---------------------------
D* PROGRAM STATUS DATA STRUCTURE
D SDS
D PGMNAM 1 10
D CPFMSG 91 170
D JOBNAM 244 253
D USERID 254 263
D USER# 259 261
D*----- =-- --- --- =
D*----- =-- --- --- = ---------------------------
D* "*LDA": the LOCAL DATA AREA is *char externally and rpg will
D* internally convert - often used instead of parms.
D* as always, be sure #'s are in the numeric fields!
D* U = read in by rpg at start of program and
D* written out at end of program
DADPinf UDS
D PRV6MO 1 6 0
D PRV6YY 1 2 0
D PRV6MM 3 4 0
D PRV6DD 5 6 0
D CLR1ST 8 8
D TSTRUN 10 10
D*----- =-- --- --- = ---------------------------
DENTRY DS
D STABBR 1 2
D STCODE 3 4 0
D STNAME 5 25
** all 3 parms are 1 text field 'out' on the command line
** and STCODE is converted internally in RPG.
D*----- =-- --- --- = ---------------------------
D DS
D PHONE 1 10
D PHONE# 1 10 0
D STRDT 11 16 0
D FULNAM 21 50
D FIRSTN 51 70
D MDY1 71 76
D MDY2 81 86
D ENDDT 91 96 0
D*----- =-- --- --- = ---------------------------
D TEST$ C CONST('********* test run -
D only **********')
D ON12 C CONST('111111111111')
D*----- =-- --- --- = ---------------------------
D DIGITS C CONST('0123456789')
D* cats: a set of char(1) fields (in a PF) converted to an array/DataStru.
D Up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D Lo C 'abcdefghijklmnopqrstuvwxyz'
D*----- =-- --- --- = ---------------------------
*=====================================================
D DS
D gAgenta 8 DIM(100) Descend
D gAgentc 4 overlay(gAgenta:1)
D gAGENT# 4S 0 overlay(gAgenta:5) inz(0)
D DS
D SUBpAGa 10 DIM(100) Descend
D SUBpAGc 6 overlay(SUBpAGa:1)
D SUBpAG# 4S 0 overlay(SUBpAGa:7) inz(0)
D DS
D OffClsa 6 DIM(100) Descend
D OffClsc 2 overlay(OffClsa:1)
D OffCls# 4S 0 overlay(OffClsa:3) inz(0)
D DS
D STATESa 6 DIM(100)
D STATESc 2 overlay(STATESa:1) inz('ZZ')
D STATES# 4S 0 overlay(STATESa:3) inz(0)
external data area named comm98mnu:
d*----------- =-- --- --- = ---------------------------
D dtaaraCYM DS 2000 dtaara(comm98mnu)
D savFPER 16 21
D morestuff 22 2000
d*----------- =-- --- --- = ---------------------------
D*----- =-- --- --- = ---------------------------
I* "I spec's" go here ((for internal file definitions.))
I*
*
* C SORTA gAgentc
* C or SORTA gAgent# etc.
* -==------------- ========= ------------- ============== ---- :++--== *
* old, standard, fixed format RPG
*
* not the new C/FREE . . . C/END-FREE
* free-format
*
* extrenal (named) data area - pulled in:
c in dtaaraCYM
c MOVE savFPER dsFPER
* extrenal (named) data area - saved:
c out dtaaraCYM
* -==------------- ========= ------------- ============== ---- :++--== *
* format user profile and password - chg to lower case letters (unix)
* upper to lower:
C
C Up:Lo XLATE string20 newstr20 90
C*
C* -==------------- ========= ------------- ============== ---- :++--== *
C *ENTRY PLIST
C PARM ENTRY
C KEY22 KLIST
C KFLD PRV6YY
C KFLD PRV6MM
C KFLD PRV6DD
C* -==------------- ========= ------------- ============== ---- :++--== *
C Z-ADD *ZERO ZIP## 5 0
C* in-mdy to out-ymd:
C MOVE INYY OTYY
C*
C MOVE CMD(1) CMD1
C MOVE CMD(2) CMD2
C CALL 'QCMDEXC'
C PARM CMD
C PARM 160 LEN 15 5
C OPEN QSYSPRT
C MOVE *ALL'-' LINE1 130
C MOVE *ALL'- ' LINE3 130
C* line3: - - - - - - - ...
C* -==------------- ========= ------------- ============== ---- :++--== *
C* seton 31 to 42 and setof 36 to 40
C MOVEA ON12 *IN(31)
C MOVEA '00000' *IN(36)
C* -==------------- ========= ------------- ============== ---- :++--== *
C* to replace # with a blank:
C eval stringname = %XLate('#':' ':stringname)
C*
C* MOVEing numeric to string:
C eval alpha5 = digits(num2)
C eval alpha5 = digits(num2) + digits(num3)
C eval alpha5 = %editc(num5:'X')
C* 'X' = no editing
C STATES(INDX) LOOKUP TABSTABREV TABSTNAME 99
C IF *IN99 = *OFF
C EXCEPT ERROR
C ELSE
* state o.k.: --------- --------------------------------- :++--== *
C EVAL ABLSTNA = %SUBST(TABSTNAME:2:20)
*** dow not eof ... enddo.
C ENDIF
*
C* Indicator 20 is set on only if indicators 10, 12, 14,16, and 18
C* are set on.
C EVAL *IN20 = *IN10 AND *IN12 AND *IN14
C AND *IN16 AND *IN18
C* -==------------- ========= ------------- ============== ---- :++--== *
C* Each element of array ARR will be assigned the value 0
C EVAL ARR(*) = 0
*
*
* Half rounding with mult. (& div.):
*
C EVAL(H) PAY = RATE * 40
*
C* -==------------- ========= ------------- ============== ---- :++--== *
C* If true, B< A
*
* %subst(string:start:length)
* original value of A = 'abcdefghijklmno'
C* After the EVAL the value of A contains 'ab****ghijklmno'
C EVAL %SUBST(A:3:4) = '****'
C* ------------- = ----
C READ CATRQDL 80
C*
C* OUT PRDOUT write it Out
C** * CALL 'BMI078'
C* IN PRDOUT read to get changes
C* ========= ------------- ============== ---- :++--== *
C MOVEL(P) LASTNM FULNAM PAD BLANKS
C CAT ',':0 FULNAM
C CAT FIRSTN:1 FULNAM
** or ... or ...
C* trailing *blanks padding done by 'eval' *
C EVAL FULNAM = *
C %TRIM(LASTNM) +', '+ %TRIM(FIRSTNM) *
** or ... or ... *
C EVAL FULNAM = %TRIM(LASTNM) +', '+ *
C %TRIM(FIRSTNM) *
C* ========= ------------- ============== ---- :++--== *
C OPEN STANDA
C TIME CLOCK 6 0
C MOVEL CLOCK UTIME 4 0
C EXCEPT HEAD
C*
C* -==------------- ========= ------------- ============== ---- :++--== *
C Z-ADD 80 LEN 15 5
C* either clear (clr1st=y), or rerun
C* on the current set of records
C CLR1ST IFEQ 'Y'
C CALL 'QCMDEXC'
C PARM CLR(1)
C PARM LEN
C*
C* - ========= ------------- ============== ---- :++--== *
C* Determine a DUEDATE which is xx years, yy months, zz days later
C* than LOANDATE.
C LOANDATE ADDDUR XX:*YEARS DUEDATE
C ADDDUR YY:*MONTHS DUEDATE
C ADDDUR ZZ:*DAYS DUEDATE
C* Determine the date 23 days later
C*
C ADDDUR 23:*D DUEDATE
C* Add a 1234 microseconds to a timestamp
C*
C ADDDUR 1234:*MS timestamp
C* Add 12 HRS and 16 minutes to midnight
C*
C T'00:00 am' ADDDUR 12:*Hours answer
C ADDDUR 16:*Minutes answer
C* Subtract 30 days from a loan due date
C*
C SUBDUR 30:*D LOANDUE
C* - ========= ------------- ============== ---- :++--== *
C* Determine a LOANDATE which is xx years, yy months, zz days prior to
C* the DUEDATE.
C DUEDATE SUBDUR XX:*YEARS LOANDATE
C SUBDUR YY:*MONTHS LOANDATE
C SUBDUR ZZ:*DAYS LOANDATE
C* Add 30 days to a loan due date
C*
or
C ADDDUR 30:*D LOANDUE
C* Calculate the number or days between a LOANDATE and a DUEDATE.
C LOANDATE SUBDUR DUEDATE NUM_DAYS:*D 5 0
C* Determine the number of seconds between LOANDATE and DUEDATE.
C LOANDATE SUBDUR DUEDATE NUM_SECS:*S 5 0
C* - ========= ------------- ============== ---- :++--== *
C*
*
C* -==------------- ========= ------------- ============== ---- :++--== *
adddur and subdur works across any 2 formats of "D" defined date fields:
even ISO - MDY (40=19=cc; . 40=20=cc) ex:
c move S@EXDT dateISO
c dateISO subdur THISmo01MDY MO#of:*M
c dateISO subdur THISmo01USA MO#of:*M
c dateISO subdur THISmo01ISO MO#of:*M
C* -==------------- ========= ------------- ============== ---- :++--== *
C *INLR DOWEQ *OFF
TST C ADD 1 REC#
TST C EXCEPT TSTPT1
C* 1. scan:
C MOVEL CMZIP ZIP5 5
C ' ' SCAN ZIP5 BB 2 0
C** if ZIP5 has no *blanks bb is set to 0.
C BB IFEQ 0
C MOVEL ZIP5 ZIP##
C ENDIF
C* or 2. check:
C MOVEL CMZIP ZIP5 5
C** if zip5 is all #'s then bb is set to 0.
C DIGITS CHECK ZIP5 BB 2 0
C BB IFEQ 0
C MOVEL ZIP5 ZIP##
C ENDIF
C*
C* translate; xlate:
C* to see which print is which more readily and
C* to change a ' to a ` (ex: USRDTA('O'Brian')
C* will error out.)
C '''':'`' XLATE IFCONT USRDTA
*
C MOVEL SCACCT CHAR2 2
C SCSTCD IFEQ 'R'
C SCSTCD OREQ 'C'
C CHAR2 IFEQ 'YP'
C*
C MOVE 'N' INVR05 1
C Z-ADD 1 XX 3 0
C XX OCCUR INVDS
C SCPHON SETLL INVMFL
C SCPHON READE INVMFL 99
C *IN99 IFEQ *ON
C EXCEPT NORECS
C ELSE
C MOVE *OFF *IN98
TST C EXCEPT TSTPT2
C*
C* -==------------- ========= ------------- ============== ---- :++--== *
C SCSTCD IFEQ 'C'
C SCPHON CHAIN(E) CUSTMPL off=ok
* custmpl = filename (only)
C If Not %Found(CUSTMPL)
/FREE
chain SCPHON CUSTMPL;
if Not %Found(CUSTMPL);
// whatever //
endif;
/end-free
C clear CUSTMFR
C ELSE
TST C ADD 1 MSGC
C EXSR WRITE2
C MOVE *ON *IN98
C ENDIF
C ENDIF
C*
C* -==------------- ========= ------------- ============== ---- :++--== *
C*
C ADD 1 XX
C XX OCCUR INVDS
C SCPHON READE INVMFL 99
C *IN99 IFEQ *OFF
C IFINVD ANDGT MO6
C EXCEPT TSTPT2
C ENDIF
C ENDDO
C* -==------------- ========= ------------- ============== ---- :++--== *
C* B < A is evaluated: If true, 01 is set on. If false 01 is set off.
C EVAL *IN01 = B < A
C* -==------------- ========= ------------- ============== ---- :++--== *
C*
C* to match on the 1st few characters:
C*
C* 1st: get the prompted input substring
C IF INCOMP <> *BLANKS
C MOVE '1' LSTCMP
C ' ' SCAN INCOMP SIZ
C* get end of name
C SUB 1 SIZ
C IF SIZ < 1
C Z-ADD 30 SIZ
C ENDIF
C ENDIF
C MOVE INCOMP LINCMP
C*
C* 2nd: compare during reading of file
C IF LSTCMP = '1'
C INCOMP:SIZ SCAN CBCOMP 40
C IF *IN40 = '1'
C MOVE '1' GOODR
C ELSE
C MOVE '0' GOODR
C ENDIF
C ENDIF
C* -==------------- ========= ------------- ============== ---- :++--== *
C*
C SCSTCD IFEQ 'R'
C INVR05 ANDEQ 'N'
C SCPHON CHAIN CUSTMPL 99
C *IN99 IFEQ *ON
C EXCEPT ERRLNC
C ELSE
TST C ADD 1 MSGR
C EXSR WRITE2
C ENDIF
C ENDIF
C*
C READ ONLSECFP LR
C ENDDO
C ENDIF
C* -==------------- ========= ------------- ============== ---- :++--== *
**
O*-------- :- -- -- =========== : -: ----+' ------------------------ '
** hint: to speed up processing, clear the extra QSYSPRT's
** from xx to 1 cut time to 1/3 ! in a read-all/print-some program.
O*-------- :- -- -- =========== : -: ----+' ------------------------ '
OQSYSPRT E HEAD 1 2
O CONAME 80
OQSYSPRT E HEAD 1
O PGMNAM 12
O 85 'Page'
O PAGE Z 90
OQSYSPRT E HEAD 1
O UTIME 8 ' : '
O 45 'ACTION CODES BY DATE'
O UDATE Y 90
OQSYSPRT E HEAD 1
O 26 'FROM'
O STRDT Y 36
O 40 'TO'
O ENDDT Y 50
OQSYSPRT E HEAD 1
O LINE1 131
O*-------- :- -- -- =========== : -: ----+' ------------------------ '
OQSYSPRT E ERROR 1
OQSYSPRT E ERRLNB 1
O 64 '0&05FR6, but no address'
O*-------- :- -- -- =========== : -: ----+' ------------------------ '
OQSYSPRT E ERRLNC 1
O 64 'CUSTMPL Record not found'
O*-------- :- -- -- =========== : -: ----+' ------------------------ '
** MSG - LENGTH 65 2 3 4 5 6 65
RECORD NOT FOUND FOR PHONE
RECORD IN USE BY
YOU MUST ENTER A B-BEGINNING AND E-ENDING POINT TO PRINT RECORDS
|---------------------------------------------------------------|
** CMD
OVRPRTF FILE(QSYSPRT) OUTQ(CBIDOT) PAGESIZE(96 132) SPLFNAME(OOORPG)
OVRFLW(96) LPI(8) SAVE(*YES) COPIES(2) USRDTA('a test')
** CLR
CLRPFM STANDA
** tabSTA / STN - State abbreviations / names
AL ALABAMA
AK ALASKA
AZ ARIZONA
AR ARKANSAS
CA CALIFORNIA
CO COLORADO
CT CONNECTICUT
DE DELAWARE
DC DISTRICT OF COLUMBIA
FL FLORIDA
GA GEORGIA
HI HAWAII
ID IDAHO
IL ILLINOIS
IN INDIANA
IA IOWA
KS KANSAS
KY KENTUCKY
LA LOUISIANA
ME MAINE
MD MARYLAND
MA MASSACHUSETTS
MI MICHIGAN
MN MINNESOTA
MS MISSISSIPPI
MO MISSOURI
MT MONTANA
NE NEBRASKA
NV NEVADA
NH NEW HAMPSHIRE
NJ NEW JERSEY
NM NEW MEXICO
NY NEW YORK
NC NORTH CAROLINA
ND NORTH DAKOTA
OH OHIO
OK OKLAHOMA
OR OREGON
PA PENNSYLVANIA
RI RHODE ISLAND
SC SOUTH CAROLINA
SD SOUTH DAKOTA
TN TENNESSEE
TX TEXAS
UT UTAH
VT VERMONT
VA VIRGINA
WA WASHINGTON
WV WEST VIRGINIA
WI WISCONSIN
WY WYOMING
H,
This ref is very good unfortunately there is no DDS layout. I was wondering you can send me the DDS so I can compile.
Thanks
As you said, this is a reference file. It is no longer a program that compiles.