RPG snippets...for those of us who cant remember
stuff
Program status data structure (PSDS) * Program data structure
D SDS
D qPROC_NAME *PROC * Procedure name
D qPGM_STATUS *STATUS * Status code
D qPRV_STATUS 16 20S 0 * Previous status
D qLINE_NUM 21 28 * Src list line num
D qROUTINE *ROUTINE * Routine name
D qPARMS *PARMS * Num passed parms
D qEXCP_TYPE 40 42 * Exception type
D qEXCP_NUM 43 46 * Exception number
D qPGM_LIB 81 90 * Program library
D qEXCP_DATA 91 170 * Exception data
D qEXCP_ID 171 174 * Exception Id
D qDATEFMT 191 198 * Date (*DATE fmt)
D qYEARFMT 199 200S 0 * Year (*YEAR fmt)
D qLAST_FILE 201 208 * Last file used
D qFILE_INFO 209 243 * File error info
D qJOB_NAME 244 253 * Job name
D qUSER 254 263 * User name
D qJOB_NUM 264 269S 0 * Job number
D qJOB_DATE 270 275S 0 * Date (UDATE fmt)
D qRUN_DATE 276 281S 0 * Run date (UDATE)
D qRUN_TIME 282 287S 0 * Run time (UDATE)
D qCRT_DATE 288 293 * Create date
D qCRT_TIME 294 299 * Create time
D qCPL_LEVEL 300 303 * Compiler level
D qSRC_FILE 304 313 * Source file
D qSRC_LIB 314 323 * Source file lib
D qSRC_MBR 324 333 * Source file mbr
D qPROC_PGM 334 343 * Pgm Proc is in
D qPROC_MOD 344 353 * Mod Proc is in
SNDPGMMSG - Send Program Message API(the line at bottom of screen) ** D-Spec stuff
** The fields used by the SndPgmMsg API
D szMsgID S 7A Inz('CPF9898')
D szMsgFile S 20A Inz('QCPFMSG QSYS' )
D szMsgText S 255A
D nMsgLen S 10I 0
D szMsgType S 10A
D szToPgmQ S 10A
D nToPgmQ S 10I 0
D szMsgKey S 4A
** C-Spec stuff
C eval szMsgText = 'Error - you got bad error,'+
C ' call someone who cares'
C Eval nMsgLen = %Len(%trimr(szMsgText))
**----------------------------------------------------------------
** SndPgmMsg MSGID(CPF9898) MSGF(QSYS/QCPFMSG) TOPGMQ(*PRV) +
** MSGDTA(szMsgText) MSGTYPE(*ESCAPE)
**----------------------------------------------------------------
C Call 'QMHSNDPM'
C Parm 'CPF9898' szMsgID
C Parm szMsgFile
C Parm szMsgText
C Parm nMsgLen
C Parm '*ESCAPE' szMsgType
C Parm '*PGMBDY' szToPgmQ
C Parm 1 nToPgmQ
C Parm szMsgKey
C Parm api_error 21
Strip Number Procedure Strip
numbers out of a string that has other characters in it *=====================================================================
* StripNum - SubProcedure strip an number out of a string
*=====================================================================
PStripNum B
D StripNum PI 30S 0
D InString 30 value
D X S 2 0
D End S 2 0
D Pos S 2 0
D Var S 1
D CharNum S 30
D Number S 30 0
D digits C '1234567890'
c clear Number
c eval Pos = 30
c ' ' checkr InString End
c for X = End downto 1
c eval var = %subst(Instring:X)
c Var scan(e) Digits 11
c if %found
c eval CharNum = %replace(Var:Charnum:Pos)
c eval Pos = Pos -1
c endif
c endfor
c move CharNum Number
c return Number
PStripNum E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I got a "null" problem
Crash, bam, boom...my program blew up and I don't know why. I can DBU
the file and it looks alright, but the field is hi-lited. Here is a little scrub
to "set off" the null indicator. h alwnull(*usrctl)
ffile UP E DISK
c if %NullInd(FIELD) = *on
c eval %NullInd(FIELD) = *off
c move *loval FIELD
c update rFILE
c endif
Mod10 Procedure aka Luhn Algorithm
This procedure is a combination of a couple snippets I found and created a
procedure. It is only 98% tested...never really got to use it b/c of some bad
documentation of a bank routing number that said it was supposed to be a
mod10'ed number (which it's not). * Prototypes
D mod10 PR 1 0
D Alpha24 24
* call
C eval testdigit = mod10(Text24)
/EJECT
*=====================================================================
* mod10 - SubProcedure to give you back the check digit
* it DOES NOT validate the last digit is a correct check digit
* you send a left justified zero paded number in a character field
* this will send back the check digit
*
* NOTE-you make sure you left justify and zero fill(if you want it)
*
*=====================================================================
Pmod10 B
D mod10 PI 1 0
D Alpha24 24a
D RA S 1 DIM(24)
D RB S 1 DIM(48)
C CLEAR X 3 0
C CLEAR Y 3 0
C CLEAR WK001A 1
C CLEAR WK002A 2
C CLEAR WK017A 17
C CLEAR WK001N 1 0
C CLEAR WK020N 2 0
C CLEAR WK090N 9 0
C CLEAR MULTIPLIER 3 0
C CLEAR ACCUM 9 0
C CLEAR LSTCHR 1
* Determine length.
C ' ' CHECKR Alpha24 NumLength 2 0
C movea Alpha24 RA
*
C MOVE NumLength X
C MOVE 1 MULTIPLIER
C MOVE 1 Y
* Luhn algorithm.
C X DOWGE 1
C MOVEA RA(X) WK001A
C MOVE WK001A WK001N
C WK001N MULT MULTIPLIER WK090N
C MOVE WK090N WK002A
C MOVEA WK002A RB(Y)
C ADD 2 Y
C 3 SUB MULTIPLIER MULTIPLIER
C SUB 1 X
C ENDDO
* Accumulate result array.
C DO 48 X
C RB(X) IFNE *BLANKS
C MOVE RB(X) WK002A
C MOVE WK002A WK020N
C ADD WK020N ACCUM
C ENDIF
C ENDDO
* take the summed numbers and do a little trick of RPGs right justify
C MOVE ACCUM NXTHI 2 0
C 100 SUB NXTHI CHDIG 1 0
*
C dump
*
C return CHDIG
Pmod10 E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ABA Bank Routing Number aka ACH Routing
Number CODE - see AS400 page for misc info This particular example is dealing with the route code being 9 signed
D DS
D BRoute 1 9 0
D Route2 1 2 0
D Route8 1 8 0
D CheckDigit 9 9 0
Prototypes
* Prototypes
D abacheck PR 1n
D Alpha9 9
D abacheckdigit PR 1s 0
D Alpha8 8
Calls
* function calls
C clear Text9
C movel BRoute Text9
C if abacheck(Text9)
C eval text = '-Good'
...
C movel BRoute Text8
C if abacheckdigit(Text8) = CheckDigit
C eval text = '-Good'
...
Also did a little checking of 1st characters
C if Route2 >= 1 and Route2 <= 12 or
C Route2 >= 21 and Route2 <= 32
C eval text = '-Good'
...
...
Here is the procedures
‚/EJECT
‚*=====================================================================
‚* abacheck - procedure to validate the aba routing code
‚* NOTE - send all 9 digits
‚*
‚* cut and paste this prototype at top of your program
‚* Prototypes
*D abacheck PR 1n
*D Alpha9 9a
‚*=====================================================================
Pabacheck B
D abacheck PI 1N
D Alpha9 9a
D Alpha S 1 DIM(9)
D Digits c '0123456789'
D True S n inz(*on)
D False S n inz(*off)
‚* validate all characters are digits
C if %check(Digits:Alpha9) > 0
C return false
C endif
‚* sum 'em up
‚* i coulda created an elaborate loop...but its only 9 digits
C movea Alpha9 Alpha
C clear Sum 3 0
C eval Sum = Sum + %dec(Alpha(1):1:0) * 3
C eval Sum = Sum + %dec(Alpha(2):1:0) * 7
C eval Sum = Sum + %dec(Alpha(3):1:0) * 1
C eval Sum = Sum + %dec(Alpha(4):1:0) * 3
C eval Sum = Sum + %dec(Alpha(5):1:0) * 7
C eval Sum = Sum + %dec(Alpha(6):1:0) * 1
C eval Sum = Sum + %dec(Alpha(7):1:0) * 3
C eval Sum = Sum + %dec(Alpha(8):1:0) * 7
C eval Sum = Sum + %dec(Alpha(9):1:0) * 1
‚*
C if %rem(sum:10) = 0
C return True
C else
C return false
C endif
Pabacheck E
‚*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
‚/EJECT
‚*=====================================================================
‚* abacheckdigit - procedure to send back aba routing code check digit
‚* NOTE - send only first 8 digits
‚*
‚* cut and paste this prototype at top of your program
‚* Prototypes
*D abacheckdigit PR 1s 0
*D Alpha8 8a
‚*=====================================================================
Pabacheckdigit B
D abacheckdigit PI 1s 0
D Alpha8 8a
D Alpha S 1 DIM(8)
D Digits c '0123456789'
‚* validate all characters are digits
C if %check(Digits:Alpha8) > 0
C return -0
C endif
‚* sum 'em up
‚* i coulda created an elaborate loop...but its only 9 digits
C movea Alpha8 Alpha
C clear Sum 3 0
C eval Sum = Sum + %dec(Alpha(1):1:0) * 3
C eval Sum = Sum + %dec(Alpha(2):1:0) * 7
C eval Sum = Sum + %dec(Alpha(3):1:0) * 1
C eval Sum = Sum + %dec(Alpha(4):1:0) * 3
C eval Sum = Sum + %dec(Alpha(5):1:0) * 7
C eval Sum = Sum + %dec(Alpha(6):1:0) * 1
C eval Sum = Sum + %dec(Alpha(7):1:0) * 3
C eval Sum = Sum + %dec(Alpha(8):1:0) * 7
C**************** eval Sum = Sum + %dec(Alpha(9):1:0) * 1
‚* take the summed numbers and do a little trick of RPGs right justify
C move sum NextHigh 2 0
C 100 sub NextHigh CheckDigit 1 0
C return CheckDigit
Pabacheckdigit E
‚*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
You are here: Home-Computer Tips & Help-AS400-RPG snippets
Previous Topic: RPG Dates
| 
