|
 |
|
RPGLE - Example chaining to logical file to write/update data
Posted By: JimmyOctane Contact |
C*===============================================
C* Chaining to a logical file, if record found
C* then update quantities else write record.
C*===============================================
C TheKey02 Klist
C Kfld PGPGRP
C Kfld PGPCA1
C Kfld PGPCA2
C Kfld PGPRDCS2
C*
C* Chain to file with keylist if found add to existing values
C* else Z-ADD (Zero out and add)
C*
C TheKey02 Chain AVAILABLEW
C*
C* This snippet of code is getting total quantity on hand/pick
C*
C If %Found(AVAILABLEW)
C Eval ONHAND = ONHAND + LPLOQT
C Eval ONPICK = ONPICK + LPPIQT
C + MOMQTY
C Update AVAILR
C Else
C Movel(p) PGPRDCS2 PRODUCT
C Movel(p) PGPGRP PGROUP
C Movel(p) PGPCA1 CAT1
C Movel(p) PGPCA2 CAT2
C Movel(p) PGDESC DESC
C Z-add LPLOQT ONHAND
C Z-add LPPIQT ONPICK
C Write AVAILR
C Endif
C*===============================================
| |
RPGLE - Example loading subfile one page at a time
Posted By: JimmyOctane Contact |
C*===============================================
C* $LoadSFL - Load the Main Menu.
C* load all errors so can total
C*===============================================
CSR $LoadSFL Begsr
C*
C If SavRrn > *Zeros
C Z-add SavRrn RRN1
C Z-add SavRrn SCRRN
C Endif
C*
C* Subfile page is set to 12. show 12 records to user at a time
C* This load function sequences the data by customer # or Name
C* Depending on what the value of ReadBy is.
C*
C Do 12
C Select
C When ReadBy = 'C'
C Read C40NAM1 89
C When ReadBy = 'N'
C Read C40NAM2 89
C Endsl
C*
C If Not*In89
C Movel(p) C4NUM S1CUSTOMER
C Movel(p) C4NAME S1CNAME
C Add 1. RRN1
C Add 1. SCRRN
C Write SUB01
C Endif
C*
C Enddo
C*
C Z-add SCRRN SavRrn
C*
C* If no records in subfile then do not disply the subfile.
C*
C If SavRrn = *Zeros And *In89
C Eval *In50 = *Off
C Endif
C
C*
C Endsr
C*===============================================
| |
RPGLE - Example position file to product read equal to total sales dollars
Posted By: JimmyOctane Contact |
C*===============================================
C* This code reads the file C40ISD by product
C* and Totals Dollars and Qty Sold.
C*===============================================
C Clear Sales
C Clear Count
C*
C PRDC Setll C40ISD
C PRDC Reade C40ISD
C Dow Not%Eof(C40ISD)
C*
C* The "+" preforms the same function as ADD.
C*
C Eval Sales = (Sales + C4DOL$)
C Eval Count = (Count + C4QTY)
C*
C PRDC Reade C40ISD
C Enddo
C*===============================================
| |
RPGLE - Program writes to source physical file then uses CPYTOSTMF
Posted By: Reynoo Moore Contact |
F*
FZZPOOUTD CF E WORKSTN
F*
FSOURCE O E DISK Rename(SOURCE:FMT1) Prefix(X)
F UsrOpn
FSRBPOH IF E K DISK
FSRBPOL IF E K DISK
FSRBPRG IF E K DISK
FXABMAIL IF E K DISK
F*
D*=======================================================
D* Commands for QCMDEXC
D*=======================================================
D*
D* CLRPFM FILE(QGPL/SOURCE) MBR(XXXX)
D*
D CLRPFM DS
D Text1 1 25 Inz('CLRPFM FILE(QGPL/SOURCE) ')
D Text2 26 31 Inz(' MBR(')
D Member1 32 42
D*
D* CRTSRCPF FILE(QGPL/SOURCE) RCDLEN(112) MBR(XXXX)
D*
D CRTSRCPF DS
D Text2A 1 27 Inz('CRTSRCPF FILE(QGPL/SOURCE)')
D Text2B 28 44 Inz(' RCDLEN(112) MBR(')
D Member2 45 55
D*
D* ADDPFM FILE(QGPL/SOURCE) MBR(JAMIEF)
D*
D ADDPFM DS
D Text2C 1 29 Inz('ADDPFM FILE(QGPL/SOURCE) MBR(')
D Member3 30 41
D*
D* OVRDBF FILE(MODELS) TOFILE(QGPL/SOURCE) MBR(XXXX)
D*
D OVRDBF DS
D Text3 1 27 Inz('OVRDBF FILE(SOURCE) TOFILE')
D Text4 27 44 Inz('(QGPL/SOURCE) MBR(')
D Member4 45 55
D*
D* CPYTOSTMF FROMMBR('/QSYS.LIB/QGPL.LIB/SOURCE.FILE/OUTP.MBR')
D* TOSTMF('/RJAPO/%%%%%%%%%%/#########.###')
D* STMFOPT(*REPLACE)
D*
D CPYTOSTMF DS
D Text5 1 25 Inz('CPYTOSTMF FROMMBR(''/QSYS')
D Text6 25 44 Inz('.LIB/QGPL.LIB/SOURCE')
D Text7 45 50 Inz('.FILE/')
D Member5 51 70
D Text8 71 79 Inz(' TOSTMF(''')
D TheRest 80 256
D*
D* del 'RJAPO/&USER/#######.###'
D*
D DEL DS
D Text13 1 11 Inz('Del ''RJAPO/')
D TheRest2 12 256
D*
D*
D MD DS
D Text14 1 11 Inz('md ''RJAPO/')
D Directory 11 40
D*
D ADDLIBLE DS
D Text15 1 22 Inz('addlible busintl *Last')
D*
D ISODate S D
D InPO S 7
D DecPO S 7 0
D*
D Str S 3 0
D End S 4 0
D Len S 4 0
D Count S 4 0
D Loop S 4 0
D #Fnd S 4 0
D InCode S 10
D @Scrn1 S 01 Inz('Y')
D CURRENTMO S 2 0
D X S 2 0
D Dec12 S 12 0
D Chr12 S 12
D OutDsm S 03 Inz('HAN')
D OutAddress S 40
D OutLoc S 50
D Name S 09
D Chr1 S 01
D ScreenError S 1
D MONTH S 2
D CURRENTYR S 4 0
D YEAR S 4
D PYear1 S 4
D PYear2 S 4
D PYear3 S 4
D FlagNo S 1 Inz('N')
D CmdString S 256
D CmdLength S 15 5
D*
D* Program Info
D*
D SDS
D @PGM 001 010
D @PARMS 037 039 0
D @JOB 244 253
D @USER 254 263
D @JOB# 264 269 0
C*============================================================
C* M A I N L I N E
C*============================================================
C*
C @User Chain XABMAIL
C If %Found(XABMAIL)
C Eval W1EMAIL = %Trim(W1EMAIL) +
C %trim(XAEADR) +
C %trim('@Code400.com')
C Else
C Eval W1EMAIL = 'SomeOne@Code400.com'
C Endif
C*
C Reset @Scrn1
C*
C Dow @Scrn1 = 'Y'
C Exfmt WIN1
C Select
C When *In03 Or *In12
C Clear @Scrn1
C Other
C*
C Exsr $Valid
C If ScreenError = *Blanks
C Exsr $ReadIt
C Exsr $Email
C Eval W1MSG = 'File sent to Folder & Emailed'
C Clear W1PO
C Endif
C*
C Endsl
C Enddo
C Eval *INLR = *On
C*=============================================================
C* $ReadIt - Read the PO data
C*=============================================================
CSR $ReadIt Begsr
C*
C Exsr $Open
C*
C Move W1PO DecPO
C PoKey01 Chain SRBPOH
C If %Found(SRBPOH)
C PoKey01 Setll SRBPOL
C PoKey01 Reade SRBPOL
C Dow Not%Eof(SRBPOL)
C*
C If OLSTAT <> 'D'
C*
C Z-add OLOQTY Dec12
C Move Dec12 Chr12
C*
C Do 12 X
C Eval Chr1 = %Subst(Chr12:X:1)
C If Chr1 <> '0'
C Leave
C Endif
C Enddo
C*
C OLPRDC Chain SRBPRG
C If %Found(SRBPRG)
C*
C Eval XSRCDTA = %Trim(XSRCDTA) +
C %Trim('"') + %Trim(PGPRDCS2) +
C %Trim('",')
C + %Trim(%Subst(Chr12:X))
C*
C Write FMT1
C Clear XSRCDTA
C*
C Endif
C Endif
C*
C PoKey01 Reade SRBPOL
C Enddo
C Endif
C*
C EXSR $StreamIt
C Endsr
C*
C*=============================================================
C* $Open - reset the overides for each DSM to build
C*=============================================================
CSR $Open Begsr
C*
C* Setup member name(s)
C*
C Eval Member1 = %Trim(NAME) + %Trim(')')
C Eval Member2 = %Trim(NAME) + %Trim(')')
C Eval Member3 = %Trim(NAME) + %Trim(')')
C Eval Member4 = %Trim(NAME) + %Trim(')')
C Eval Member5 = %Trim(NAME) + %Trim('.MBR/'')' )
C*
C If %Open(SOURCE)
C Close SOURCE
C Endif
C*
C*
C* Clear the source file and do data base override
C*
C Movel(p) CRTSRCPF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C* Add member that is the name
C*
C Movel(p) ADDPFM CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Movel(p) CLRPFM CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Movel(p) OVRDBF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C If Not%Open(SOURCE)
C Open SOURCE
C Endif
C*
C* Create the IFS folder by user profile
C*
C Eval Directory = %Trim(name) +
C %Trim('''')
C Movel(p) MD CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Endsr
C*
C*=============================================================
C* $StreamIt - Streamfile the data.
C*=============================================================
C $StreamIt Begsr
C*
C If %Open(SOURCE)
C Close SOURCE
C Endif
C*
C*
C* Delete old one by same PO Number
C*
C Eval TheRest2 = %Trim(NAME)
C +%Trim('/') + %Trim('PO') +
C %Trim(W1PO) + %Trim('.csv')
C + %Trim('''')
C*
C Movel(p) DEL CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C* Build the stream file command 'RJAPO/&USER/#######.###'
C*
C*
C Eval TheRest = %Trim('RJAPO/') +
C %Trim(NAME) +
C %Trim('/') +
C %Trim('PO') + %Trim(W1PO) +
C %Trim('.csv') + %Trim(''')')
C + ' STMFOPT(*REPLACE)'
C + ' STMFCODPAG(*PCASCII)'
C*
C Eval OutLoc =
C %Trim('RJAPO/') +
C %Trim(NAME) +
C %Trim('/') +
C %Trim('PO') + %Trim(W1PO) +
C %Trim('.csv')
C*
C Movel(p) CPYTOSTMF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C*
C Endsr
C*=============================================================
C* $Valid - Check screen entries
C*=============================================================
CSR $Valid Begsr
C*
C Clear ScreenError
C Clear W1MSG
C*
C If W1PO = *Blanks Or W1PO = '0000000'
C Eval W1MSG = 'Invalid PO Entered.'
C Eval ScreenError = 'Y'
C Else
C Move W1PO DecPO
C PoKey01 Chain SRBPOH
C If Not%Found(SRBPOH)
C Eval W1MSG = 'Invalid PO Entered.'
C Eval ScreenError = 'Y'
C Endif
C Endif
C*
C Eval Name = %Trim('PO') + %Trim(W1PO)
C*
C Endsr
C*
C*=============================================================
C* $Email - Email this to someone
C*=============================================================
CSR $Email Begsr
C*
C Call 'BICTL02C'
C Parm OutDsm
C Parm W1Email OutAddress
C Parm OutLoc
C*
C Endsr
C*=============================================================
C* *Inzsr - Initial one time run subroutine.
C*=============================================================
C *Inzsr Begsr
C*
C*
C* Klist(s)
C*
C PoKey01 Klist
C Kfld FlagNo
C Kfld DecPO
C*
C *MDY Move UDATE ISODate
C*
C Movel(p) ADDLIBLE CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Endsr
C*=============================================================
| |
RPGLE - Translate Lower case to Upper case
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
H DftActGrp(*No) Option(*SrcStmt : *NoDebugIO)
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* Program Name:
* Description :
* Date Written:
* Modification:
* ~~~~~~~~~~~~
*
*
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
FINBOX if e k disk prefix(x)
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* Program Information
* ~~~~~~~~~~~~~~~~~~~
D @PgmInfo sds
D @PgmNam 1 10
D @Parms 37 39 0
D @MsgId 40 46
D @MsgDta 91 170
D @JobNam 244 253
D @UserId 254 263
D @JobNum 264 269 0
*
* Constants
* ~~~~~~~~~
D UpperCase C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D LowerCase C 'abcdefghijklmnopqrstuvwxyz'
*
* Define Variables
* ~~~~~~~~~~~~~~~~
D XMLField s 1000 inz(*blanks)
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
C eval *inlr = *on
C return
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C *inzsr begsr
*
C read INBOX
C dow not %eof(INBOX)
*
C eval XMLField = %xlate(LowerCase : UpperCase :
C %trim(xSRCDTA))
*
C read INBOX
C enddo
*
C endsr
| |
RPGLE - CPYTOSTMF example reading XML file
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* Program Name:
* Description :
* Written On :
*
* Modification
* ~~~~~~~~~~~~
* Date Mark Int Description
* ~~~~~~~~ ~~~~ ~~~ ~~~~~~~~~~~
*
*
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
H Option(*SrcStmt: *NoDebugIO) DftActGrp(*No)
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* XML Source File
* ~~~~~~~~~~~~~~~
FBIGSOURCE if e k disk rename(BIGSOURCE : format1)
F prefix(x)
*
*
* XML Source File
* ~~~~~~~~~~~~~~~
FOUTSOURCE uf a e k disk rename(OUTSOURCE : format2)
F prefix(q)
F usropn
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* Constants
* ~~~~~~~~~
D Up C const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D Low C const('abcdefghijklmnopqrstuvwxyz')
*
* Program Info
* ~~~~~~~~~~~~
D PgmInfo SDS
D @PgmName 1 10
D @Parms 37 39 0
D @MsgID 40 46
D @JobName 244 253
D @UserId 254 263
D @JobNbr 264 269 0
*
* Field Definitions.
* ~~~~~~~~~~~~~~~~~~
D Next S 4 0 inz(0)
D Chr4 S 4
D*
D pos S 5 0 inz(0)
D OutFile S 50
D infile S 50
*
D WorkData s 30000 inz(*blanks)
D TheHeader s 30000 inz(*blanks)
D Line# S 3 0 inz(0)
D WriteHeader S 01 inz('Y')
D pos2 S 5 0 inz(0)
D pos3 S 5 0 inz(0)
*
D Cmdstring s 40000 inz(*blanks)
D CmdLength s 15 5 inz(0)
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
* Read the source file to populate WorkData
*
*
C*
C Reset WriteHeader
C*
C *start setll BIGSOURCE
C read BIGSOURCE
C dow not %eof(BIGSOURCE)
C*
C eval WorkData = %Trim(WorkData) + %trim(xSRCDTA)
C*
C* The header is complete dont write anymore
C*
C eval pos2 = %scan('' : xSRCDTA)
C if pos2 > 0
C Eval WriteHeader = 'N'
C Endif
C*
C If WriteHeader = 'Y'
C eval TheHeader = %Trim(TheHeader)+ %trim(xSRCDTA)
C Endif
C*
C eval pos3 = %scan('' : xSRCDTA)
C if pos3 > 0
C Eval Line# = (Line# + 1)
C Endif
C*
C eval pos = %scan('' : xSRCDTA)
C if pos > 0
C Or Line# = 90.
C*
C exsr $writeIFS
C*
C If Line# = 90.
C Exsr $Continue
C Endif
C*
C Clear Line#
C*
C endif
C*
C read BIGSOURCE
C enddo
C
C eval *inlr = *on
C return
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $WriteIFS begsr
C*
C Eval Next = (Next + 1)
C Movel(p) Next Chr4
C '.' Scan InFile Pos
C Eval OutFile = %Trim(%Subst(Infile:1:Pos-1))
C + %Trim('-')
C + %Trim(Chr4) + %Trim('.xml')
C*
C if %open(OUTSOURCE)
C close OUTSOURCE
C endif
*
C eval CmdString = %trim('OVRDBF FILE(OUTSOURCE)') +
C %trim('TOFILE(QTEMP/OUTSOURCE)')
C eval CmdLength = 256.
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C eval CmdString = 'CLRPFM OUTSOURCE'
C eval CmdLength = 256.
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
*
C if not %open(OUTSOURCE)
C open OUTSOURCE
C endif
*
C eval qSRCDTA = WorkData
C write format2
*
C if %open(OUTSOURCE)
C close OUTSOURCE
C endif
C*
C* Copy to stream file
C* CPYTOSTMF FROMMBR('qsys.lib/qgpl.lib/outsource.file/outdata.mbr')
C* TOSTMF('dsmorders/test.xml-01') STMFOPT(*REPLACE)
C*
C*
C Eval CmdString = 'CPYTOSTMF FROMMBR(''qsys.'
C + %Trim('lib/qgpl.lib/outsource.file')
C + %Trim('/outdata.mbr''')
C + %Trim(') TOSTMF(''')
C + %Trim('dsmorders/')
C + %Trim(Outfile)
C + %Trim(''') STMFOPT(*REPLACE)')
C + %Trim('@@STMFCODPAG(*PCASCII)')
C*
C '@':' ' Xlate CmdString CmdString
C*
C eval CmdLength = 256.
C*
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C*
C* QSYS/CHGAUT OBJ('dsmorders/*') USER(*PUBLIC) +
C* DTAAUT(*RWX) OBJAUT(*ALL)
C*
C Eval CmdString = %Trim('CHGAUT OBJ(''dsmorde')
C + %Trim('rs/*'' USER(*PUBLIC) DTAAUT')
C + %Trim('(*RWX) OBJAUT(*ALL)')
C Eval CmdLength = 256.
C*
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C Clear WorkData
C*
C endsr
C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C* $Continue - Set up program to send the rest of the file.
C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $Continue begsr
C*
*
C if not %open(OUTSOURCE)
C open OUTSOURCE
C endif
C*
C Movel(p) TheHeader WorkData
C*
C endsr
C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C* *inzsr - Initial one time run subroutine
C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C *inzsr begsr
*
C *entry plist
C parm infile
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
| |
RPGLE - Six decimal date *MDY converted to *ISO
Posted By: Reynoo Moore Contact |
C*
C* must cerify that this is a correct date
C*
C Move ShipDateTxt Dec6
C *MDY Test(de) Dec6
C If %Error
C Eval ShipDate = %Date()
C Else
C *MDY Move Dec6 ShipDate
C Endif
C*
| |
RPGLE - %Scan and replace example
Posted By: Reynoo Moore Contact |
*
* Free of Charge
*
C eval str = %scan('FOC="' : items(z))
C if str > 0
C eval str = str + 5
C '"' scan items(z):str end
C eval len = (end - str)
C eval OLFOCC = %subst(items(z) : str : len)
C endif
| |
RPGLE - Delete with RPG
Posted By: Reynoo Moore Contact |
C*
C* if line number is zero then must delete the header
C*
C If LineNumber = *zeros
C DsmOrdL1Key Chain DSMHORDL1
C If %Found(DSMHORDL1)
C Delete OrdHdrR
C Endif
C Endif
C*
| |
RPGLE - Use api to get spooled file information
Posted By: Reynoo Moore Contact |
FMONITORP UF E K DISK
FDAILYP iF E K DISK
F*
F* Source file to write new daily reports HTM to
F*
FDAILY O E DISK UsrOPn Prefix(X) Rename(DAILY:DLY)
F*
* PROGRAM STATUS DATA
D SDS
D PGMID 1 10
D USERID 254 263
* DATA QUEUE LAYOUT
D QDATA DS 128 INZ
D RCDID 1 10
D* 11 12 ??
D JOBID 13 38
D JOBNM 13 22
D JOBUSER 23 32
D JOBNBR 33 38
D SPLF 39 48
D BSPLF# 49 52B 0
D OUTQ 53 62
D OTQLIB 63 72
D* 73 128 ??
D* QUSRSPLA - LIST SPOOL FILE ATRIBUTES API
D* 73 128 ??
D RCVVAR DS INZ
D BYTRTN 1 4B 0
D BYTVAL 5 8B 0
D SPLFID 25 40
D JOBNAM 41 50
D USRNAM 51 60
D JOBNUM 61 66
D FILNAM 67 76
D FILNUM 77 80B 0
D FRMTYP 81 90
D USRDTA 91 100
* DEFINE BINANRY NUMBERS
D DS
D RCVLEN 1 4B 0
* DEFINE CONSTANTS
D ISODate S D
D TodayISO S D
D Available S 1
D DEC155 S 15 5
D Dec8 S 08 0
D Chr8 S 08
D Chr4 S 04
D Chr2 S 02
D Chr8_2 S 08
D Out8 S 08
D C1DAY S 09
D Str S 02 0
D Year S 04 0
D ChrYear S 04
D Month S 02 0
D Day S 02 0
D ChrDay S 02
D Len S 05 0
D Next S 05 0
D Today S 50
D WorkField S 5 0
D MName S 256
D CmdString S 256
D CmdLength S 15 5
D DayOfWeek S 07 0
D*
D* Days
D*
D DNames S 63 Inz('Sunday Monday Tuesday Wedn+
D esdayThursday Friday Saturday ')
D*
D* Months
D*
D MNames S 108 Inz('January FebruraryMarch Apri+
D l May June July +
D August SeptemberOctober Nove+
D mber December ')
D*=====================================================================
D* Commands for QCMDEXC
D*=====================================================================
D*
D* CLRPFM FILE(CGI_BIN/DAILY) MBR(DAILY)
D*
D CLRPFM DS
D Text1 1 25 Inz('CLRPFM FILE(CGI_BIN/DAILY')
D Text2 26 37 Inz(') MBR(DAILY)')
D*
D* OVRDBF FILE(DAILY) TOFILE(CGI_BIN/DAILY) MBR(DAILY)
D*
D OVRDBF DS
D Text3 1 27 Inz('OVRDBF FILE(DAILY) TOFILE')
D Text4 27 53 Inz('(CGI_BIN/DAILY) MBR(DAILY)')
D*
D* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
D* TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
D* STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
D*
D*
D**************************************************************
* MAIN LINE - RTV DATA QUEUE
D**************************************************************
C*
C Exsr $Daily
C*
C MOVE *ON *INLR
C**************************************************************
* SUBROUTINES:
C**************************************************************
* RETRIVE SPOOL FILE ATTRIBUTES
C**************************************************************
C $RTVA BEGSR
* CALL SYSTEM API
C CALL 'QUSRSPLA' 99
C PARM RCVVAR
C PARM 100 RCVLEN
C PARM 'SPLA0100' FMTNM 8
C PARM JOBID 26
C PARM *BLANK INTJOB 16
C PARM *BLANK INTSPL 16
C PARM SPLF
C PARM BSPLF#
C*
C Select
C When JOB = 'QPRT160'
C WebKey2 Chain MONITORP
C Other
C WebKey1 Chain MONITORP
C Endsl
C*
C If %Found(MONITORP)
C*
C Move TodayISO UsedDate
C*
C* last spooled info
C*
C Movel(p) FILNAM SFILE
C Movel(p) JOBNAM SJOB
C Movel(p) USRNAM SUSER
C Movel(p) JOBNUM SNUMBER
C Move FILNUM SSNUMBER
C*
C Do 5 Str
C If %Subst(SSNUMBER:Str:1) <> '0'
C Leave
C Else
C Eval %Subst(SSNUMBER:Str:1) = *Blanks
C Endif
C Enddo
C*
C Eval SSNUMBER = %Trim(SSNUMBER)
C*
C Movel(p) USRDTA SUSERDATA
C*
C Update MONR
C*
C *MDY Move UDATE ISODate
C Move ISODate Dec8
C Move Dec8 Chr8_2
C Subdur 1:*days ISODate
C Move ISODate Dec8
C Move Dec8 Chr8
C Move Chr8 Out8
C*
C Z-add BSPLF# Dec155
C*
C Eval USRDTA = %Trim(USRDTA)
C Call 'MONITORC2' 99
C Parm SPLF
C Parm JOBNM
C Parm JOBUSER
C Parm JOBNBR
C Parm DEC155
C Parm WEBPAGE
C Parm FOLDER
C Parm Chr8
C Parm HTML
C Parm PDF
C Parm EMAIL
C Parm EADDRESS
C Parm ESUBJECT
C Parm ENOTE1
C Parm Chr8_2
C*
C Endif
C*
C ENDSR
C*==================================================================
C* $Daily - Daily Reports
C*==================================================================
CSR $Daily Begsr
C*
C* Redundant date functions so that I can test
C*
C *MDY Move UDATE ISODate
C Move ISODate Dec8
C Move Dec8 Chr8_2
C Subdur 1:*days ISODate
C Move ISODate Dec8
C Move Dec8 Chr8
C Move Chr8 Out8
C*
C* Create string for today
C*
C*
C Eval Year = %Subdt(ISODate:*Y)
C Move Year ChrYear
C Eval Month = %Subdt(ISODate:*M)
C Eval Day = %Subdt(ISODate:*D)
C Move Day ChrDay
C Exsr $Day
C Eval Month = Month -1
C Eval MName = %Trim(%Subst(MNames:(Month*9):9))
C Clear Today
C Eval Today = %Trim(C1DAY) + '%The%'
C + %Trim(ChrDay) + %Trim('%Of%')
C + %Trim(MName) + %Trim('%The Year Of%')
C + %Trim(ChrYear)
C*
C '%':' ' Xlate Today Today
C*
C *Start Setll DAILYP
C Read DAILYP
C Dow Not%Eof(DAILYP)
C*
C '@@DATE' Scan DFIELD Str
C If %Found
C Eval %Subst(DFIELD:Str:50) = Today
C Endif
C*
C '$$$$$$$$' Scan DFIELD Str
C If %Found
C Eval %Subst(DFIELD:Str:08) = Chr8
C Endif
C*
C '%%%%%%%%' Scan DFIELD Next
C If %Found
C And Next > *Zeros
C Eval %Subst(DFIELD:Next:08) = Chr8
C Endif
C*
C*
C Movel(p) DFIELD XSRCDTA
C*
C*
C Write DLY
C*
C Read DAILYP
C Enddo
C*
C* Close the source member and then send it somewhere
C*
C If %Open(DAILY)
C Close DAILY
C Endif
C*
C*
C* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
C* TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
C* STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
C*
C Eval CmdString =%Trim('CPYTOSTMF FROMMBR(') +
C %Trim('''') +
C %Trim('/QSYS.LIB/CGI_BIN') +
C %Trim('.LIB/DAILY.FILE/D') +
C %Trim('AILY.MBR') +
C %Trim('''') +
C %Trim(') TOSTMF(') +
C %Trim('''') +
C %Trim('/WEB/REPORTS/') +
C %Trim(Chr8) +
C %Trim('/DailyReports.htm') +
C %Trim('''') +
C %Trim(')') +
C %Trim('!STMFCODPAG(*PCAS') +
C %Trim('CII)') +
C %Trim('!STMFOPT(*REPLACE)')
C '!':' ' Xlate CmdString CmdString
C*
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 88
C Parm CmdString
C Parm Len CmdLength
C*
C*
C Endsr
C*==================================================================
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C* $Day - What Day is Today.
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $Day Begsr
C*
C*
C IsoDate Subdur D'1899-12-30' DayofWeek:*D
C Div 7 DayOfWeek
C Mvr DayOfWeek
C*
C If DayOfWeek < 1.
C Eval DayOfWeek = DayOfWeek + 7.
C Endif
C*
C Select
C When DayOfWeek = 1.
C Movel(p) 'Sunday' C1DAY
C When DayOfWeek = 2.
C Movel(p) 'Monday' C1DAY
C When DayOfWeek = 3.
C Movel(p) 'Tuesday' C1DAY
C When DayOfWeek = 4.
C Movel(p) 'Wednesday' C1DAY
C When DayOfWeek = 5.
C Movel(p) 'Thursday' C1DAY
C When DayOfWeek = 6.
C Movel(p) 'Friday' C1DAY
C When DayOfWeek = 7.
C Movel(p) 'Saturday' C1DAY
C Endsl
C*
C*
C Endsr
**************************************************************************
C *INZSR BEGSR
* ENTRY PARMS
* RECEIVE DATA QUEUE PARMS
* DEFINE VARIABLES
C*
C* Klist
C*
C WebKey1 Klist
C Kfld JOBNM
C Kfld SPLF
C*
C WebKey2 Klist
C Kfld JOBNM
C Kfld SPLF
C Kfld USRDTA
C*
C *MDY Move UDATE TodayISO
C*
C*Set up member to write to
C*
C*
C* Build the DSM model(s)
C*
C Movel(p) CLRPFM CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 88
C Parm CmdString
C Parm Len CmdLength
C*
C Movel(p) OVRDBF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 88
C Parm CmdString
C Parm Len CmdLength
C*
C If Not%Open(DAILY)
C Open DAILY
C Endif
C*
C ENDSR
| |
RPGLE - Function to center a field
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $GetComNam - Get Company Information
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
P$GetComNam b
D $GetComNam pi 30a
D LenStr s 3 0 inz(0)
D ComNum s 3 0 inz(1)
D ComNam s 30 inz(*blanks)
D TmpComNam s 30 inz(*blanks)
*
C if not %open(CCFILEL)
C open CCFILEL
C endif
*
C eval ComNum = 001.
C ComNum Chain CCFILEL
C if %found(CCFILEL)
C eval TmpComNam = %trim(CCCONM)
C endif
*
C if %open(CCFILEL)
C close CCFILEL
C endif
*
C eval LenStr = ((%len(TmpComNam) -
C %len(%trim(TmpComNam))) / 2) + 1
C eval %subst(ComNam:LenStr) = %trim(TmpComNam)
*
C return ComNam
*
P$GetComNam e | |
RPGLE - Function to get day of the week
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $GetDoW - Get Day of Week
* 1=Sun, 2=Mon, etc.
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
P$GetDoW b
D $GetDoW pi 3a
D InpDate d value
*
D DayOfWk s 11p 0
D AnySundayDate s d datfmt(*iso)
D inz(d'1998-08-01')
D WrkDate s d datfmt(*iso)
D DoWDesc s 3 inz(*blanks)
*
C eval WrkDate = InpDate
C eval DayOfWk = %diff(InpDate:AnySundayDate:*days)
C div 7 DayOfWk
C mvr DayOfWk
*
C if DayOfWk <= 0
C eval DayOfWk = (DayOfWk + 7)
C endif
*
C select
C when DayOfWk = 1
C eval DoWDesc = 'Sun'
C when DayOfWk = 2
C eval DoWDesc = 'Mon'
C when DayOfWk = 3
C eval DoWDesc = 'Tue'
C when DayOfWk = 4
C eval DoWDesc = 'Wed'
C when DayOfWk = 5
C eval DoWDesc = 'Thu'
C when DayOfWk = 6
C eval DoWDesc = 'Fri'
C when DayOfWk = 7
C eval DoWDesc = 'Sat'
C endsl
*
C return DoWDesc
*
P$GetDoW E
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
| |
RPGLE - Clear messages subfile API
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $ClrMsg - clear the messages from the screen
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $ClrMsg begsr
*
C call 'QMHRMVPM'
C parm PGMQ
C parm STKCNT
C parm MSGKY
C parm MSGRMV
C parm ERRCOD
*
C endsr
| |
RPGLE - Write message subfile API
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $SndMsg - Send a message to the message subfile
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $SndMsg begsr
*
C call 'QMHSNDPM'
C parm MSGID
C parm MSGF
C parm MSGDTA
C parm DTALEN
C parm MSGTYP
C parm PGMQ
C parm STKCNT
C parm MSGKEY
C parm ERRCOD
*
C endsr
| |
RPGLE - Variables for message subfile
Posted By: Reynoo Moore Contact |
D DS inz
D STKCNT 001 004B 0
D DTALEN 005 008B 0
D ERRCOD 009 012B 0
*
*
* Program Info
* ~~~~~~~~~~~~~
D* SDS
D* @PGM 001 010
D* @Parms 037 039 0
D* @JOB 244 253
D* @UserId 254 263
D* @JOB# 264 269 0
C eval PgmQ = @PgmName
C eval DtaLen = 60
*
* Initialize the message subfile fields
*
C movel 'CODMSGF' MSGF 20
C movel '*LIBL' MSGLIB 10
C move MSGLIB MSGF
C move *blanks MSGKY 04
C move *blanks MSGDTA 80
C movel '*DIAG' MSGTYP 10
C movel '*ALL' MSGRMV 10
C movel *blanks MSGID 07
*
| |
RPGLE - Renaming record format with prefix fields
Posted By: Reynoo Moore Contact |
FC$USRBLDL1UF E K DISK rename(C$USRR:ByModel) Prefix(Z)
| |
RPGLE - Example of displaying a screen
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* $DispSFL01 - Survey Type LookUp
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
C $DispSFL01 begsr
*
C exsr $ClearSFL01
C exsr $LoadSFL01
C exsr $CLRMSG
*
C dow @Scrn01 = 'Y'
*
C write SUB01FKEY
C write MSGCTL 99
C exfmt SUB01CTL
*
C if CURREC <> *zeros
C eval RRn01 = CURREC
C eval ScRRn01 = CURREC
C endif
*
C eval SavScRRn01 = 1
C if ScRRn01 > 0
C eval SavScRRn01 = ScRRn01
C endif
*
C exsr $CLRMSG
*
C select
*
* F3 pressed end the program
*
C when *in03 = *on
C eval @Scrn01 = 'N'
*
* F6=Add
*
C when *in06 = *on
C eval ChangedRecord = 'Y'
C eval ScreenMode = 'ADD'
C exsr $Screen01
*
* F12=Return
*
C when *in12 = *on
C eval @Scrn01 = 'N'
*
* other
*
C other
C if RRn01 > 0
C exsr $Process01
C endif
*
C endsl
*
C if ChangedRecord = 'Y' and ScreenError = 'N'
C exsr $ClearSFL01
C exsr $LoadSFL01
C eval ScreenError = 'N'
C eval ChangedRecord = 'N'
C eval ScRRn01 = SavScRRn01
C endif
*
C enddo
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
| |
RPGLE - Loading an entire subfile all at once
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $LoadSFL01 - Load subfile display
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $LoadSFL01 begsr
*
C eval S01CNAM = CompName
C eval S01CDAY = $GetDoW(%date())
*
C if SavRRn01 > *zeros
C eval RRn01 = SavRRn01
C eval ScRRn01 = SavRRn01
C endif
C eval ScRRn01 = (SavRRn01 + 1)
*
* Load the subfile fields
*
C *start setll MONITORL2
C read MONITORL2 89
C dow not %eof(MONITORL2)
*
C reset SUB01
C eval S01SPLF = SFILE
C eval S01UDTA = SUSERDATA
C eval S01HTML = HTML
C eval S01PDF = PDF
C eval S01JNAM = SJOB
*
C eval RRn01 = (RRn01 + 1)
C write SUB01
*
C read MONITORL2 89
C enddo
*
C if RRn01 = 0
C eval RRn01 = 1
C eval *in50 = *off
C endif
C if RRn01 > 0 and *in89 = *on
C eval ScRRn01 = (SavRRn01 + 1)
C endif
C eval SavRRn01 = RRn01
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
| |
RPGLE - Clearing a subfile by writing subfile control
Posted By: Reynoo Moore Contact |
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $ClearSFL01 - Clear the subfile.
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $ClearSFL01 begsr
*
C eval *in50 = *off
C eval *in51 = *off
C eval *in52 = *on
*
C write SUB01CTL
*
C eval *in50 = *on
C eval *in51 = *on
C eval *in52 = *off
*
C eval RRn01 = 0
C eval ScRRn01 = 0
C eval SavRRn01 = 0
*
C endsr
*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
| |
RPGLE - Simple if statment with error message subfile write
Posted By: Reynoo Moore Contact |
*
* SPLF/Job Name/User Data must not be blanks
*
C if C01SPLF = *blanks or C01JNAM = *blanks or
C C01UDTA = *blanks
C eval MsgId = 'ROL0053'
C eval MsgDta = *blanks
C exsr $SndMsg
C eval *in40 = *on
C eval ScreenError01 = 'Y'
C endif
| |
RPGLE - Create user space
Posted By: Reynoo Moore Contact |
* Standard API error data structure
d ErrorDs DS INZ
d BytesProvd 1 4B 0 inz(116)
d BytesAvail 5 8B 0
d MessageId 9 15
d Err### 16 16
d Message 17 116
* Name and location of the Output Queue
d UserSpace DS
d QSName 10 Inz('SPOOL1')
d QSLibrary 10 Inz('QTEMP')
* Create the user space
c CALL 'QUSCRTUS'
c PARM UserSpace
c PARM *BLANKS SpaceAttr 10
c PARM 4096 SpaceLen
c PARM *BLANKS SpaceVal 1
c PARM '*CHANGE' SpaceAuth 10
c PARM *BLANKS SpaceText 50
c PARM '*YES' SpaceRepl 10
c PARM ErrorDs
| |
RPGLE - Identify Hex Codes for all function keys
Posted By: Reynoo Moore Contact |
.D*ame+++++++++++ETDsFrom+++To/L+++IDc.Keywords+++++++++++
D F1 C CONST(X'31')
D F2 C CONST(X'32')
D F3 C CONST(X'33')
D F4 C CONST(X'34')
D F5 C CONST(X'35')
D F6 C CONST(X'36')
D F7 C CONST(X'37')
D F8 C CONST(X'38')
D F9 C CONST(X'39')
D F10 C CONST(X'3A')
D F11 C CONST(X'3B')
D F12 C CONST(X'3C')
D F13 C CONST(X'B1')
D F14 C CONST(X'B2')
D F15 C CONST(X'B3')
D F16 C CONST(X'B4')
D F17 C CONST(X'B5')
D F18 C CONST(X'B6')
D F19 C CONST(X'B7')
D F20 C CONST(X'B8')
D F21 C CONST(X'B9')
D F22 C CONST(X'BA')
D F23 C CONST(X'BB')
D F24 C CONST(X'BC')
D CLEAR C CONST(X'BD')
D ENTER C CONST(X'F1')
D HELP C CONST(X'F3')
D ROLLDN C CONST(X'F4')
D ROLLUP C CONST(X'F5')
D PRINT C CONST(X'F6')
D RCBKSP C CONST(X'F8')
D AUTENT C CONST(X'3F')
| |
RPGLE - OS/400 API Error Data Structure
Posted By: JimmyOctane Contact |
*********************************************
* OS/400 API Error Data Structure
**********************************************
** API Error Return Code data structure
D api_error DS
** Bytes Provided
D err_BProv 10I 0 inz(%size(api_error))
D* Bytes Available
D* -- Test err_BAvail for > 0 then look at ERR_MSGID
D* for the CPF message ID that was issued.
D err_BAvail 10I 0 inz(0)
D* Exception Id
D err_MsgID 7A
D* Reserved
D err_Resv1 1A
D* extended error stuff, such as the message data fields
D err_exterr 64A
D err_status S 1A INZ(*OFF)
D err_flags S 10I 0 INZ(0)
| |
RPGLE - Remove quotes from a data string
Posted By: JimmyOctane Contact |
D qtScan S 9B 0
D qtText S 256A
C*-----------------------------------------------------------------
C Z-ADD 1 qtScan
C Dow qtScan > 0 and qtScan <= %size(qtText)
c '''' Scan qtText:qtScan qtScan
C if qtScan > 0
C eval qtText = %subst(qtText: 1 : qtScan) +
C '''' + %subst(qtText: qtScan+1)
C Add 2 qtScan
C endIf
C endDo
| |
RPGLE - Testing for valid *ISO date
Posted By: JimmyOctane Contact |
D*=======================================================
D ISODate S D
D Count S 06 0
D MonthD S 02 0
D YearD S 04 0
D ChrMonth S 02
D ChrYear S 04
D Chr6 S 06
C*
C* OLDELT is a decimal field in data file with length of 8,0
C* Test(de) = Test date for error if error %Error = *On
C*
C *ISO Test(de) OLDELT
C If Not%Error
C *ISO Move OLDELT ISODate
C*
C* Using Extrct to extract the year and month from date
C*
C Extrct ISODate:*M MonthD
C Extrct ISODate:*Y YearD
C Move MonthD ChrMonth
C Move YearD ChrYear
C Eval Chr6 = ChrYear + ChrMonth
C Move Chr6 YEARMONTH
C*
C Z-add Count LINEITEMS
C If YearD = 2002
C Or YearD = 2001
C And MonthD >= 10
C Write AVERAGER
C Endif
C Endif
C*=======================================================
| |
RPGLE - Defining constants
Posted By: JimmyOctane Contact |
D HTTPHeader C CONST('Content-type: text/html')
D NewLine C CONST(X'15')
D Yel C CONST('')
D End C CONST('')
| |
RPGLE - Defining subfiles in F specs
Posted By: JimmyOctane Contact |
FDRPT002D cf e workstn infds(INFDS)
F sfile(SUB01 : RRn1)
F sfile(SUB02 : RRn2)
F sfile(SUB03 : RRn3)
F sfile(SUB04 : RRn4)
| |
RPGLE - Using Data queues in RPGLE
Posted By: JimmyOctane Contact |
C*-------------------------------------------------------
C* ENTRY PARMS
C*
C *ENTRY PLIST
C PARM @DTAQ 10
C PARM @QLIB 10
C PARM @QLEN 5 0
C PARM OUT8 08
C*
C* RECEIVE DATA QUEUE PARMS
C*
C PRCVQ PLIST
C PARM @DTAQ DTAQ
C PARM @QLIB QLIB
C PARM 0 QLEN
C PARM *BLANK QDATA
C PARM 0 QWAIT 5 0
C*
C* DEFINE VARIABLES
C*
C *LIKE DEFINE @DTAQ DTAQ
C *LIKE DEFINE @QLIB QLIB
C *LIKE DEFINE @QLEN QLEN
C*-------------------------------------------------------
C* RECEIVE DATA QUEUE - WAIT for ever
C*
C Dou 1 = 2
C CALL 'QRCVDTAQ' PRCVQ 99
C*
C* When no more dataqueue entries bail.
C*
C IF QLEN = *Zeros
C Leave
C Else
C EXSR $RTVA
C Endif
C Enddo
C*-------------------------------------------------------
| |
RPGLE - CPYTOSTMF QCMDEXC example
Posted By: JimmyOctane Contact |
C*
C*
C* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
C* TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
C* STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
C*
C Eval CmdString =%Trim('CPYTOSTMF FROMMBR(') +
C %Trim('''') +
C %Trim('/QSYS.LIB/CGI_BIN') +
C %Trim('.LIB/DAILY.FILE/D') +
C %Trim('AILY.MBR') +
C %Trim('''') +
C %Trim(') TOSTMF(') +
C %Trim('''') +
C %Trim('/WEB/REPORTS/') +
C %Trim(Chr8) +
C %Trim('/DailyReports.htm') +
C %Trim('''') +
C %Trim(')') +
C %Trim('!STMFCODPAG(*PCAS') +
C %Trim('CII)') +
C %Trim('!STMFOPT(*REPLACE)')
C '!':' ' Xlate CmdString CmdString
C*
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 88
C Parm CmdString
C Parm Len CmdLength
| |
RPGLE - Scan and replace entire string
Posted By: JimmyOctane Contact |
C*
C '&EXT' Scan WBTEXT
C If %Found
C Eval WBTEXT = %Trim(WBPEXT)
C Endif
C*
C '&DEPT' Scan WBTEXT
C If %Found
C Eval WBTEXT = %Trim(WBPDEPT)
C Endif
C*
C '&IMAGE' Scan WBTEXT
C If %Found
C Eval WBTEXT = 'No photo Available'
C Endif
| |
RPGLE - Reading equal a database
Posted By: JimmyOctane Contact |
C*
C* Footer
C*
C 'F' Setll WBPHONE1WP
C 'F' Reade WBPHONE1WP
C Dow Not%Eof(WBPHONE1WP)
C*
C eval WrtDta = %trim(WBTEXT) +
C NewLine
C EXSR $WrStout
C*
C 'F' Reade WBPHONE1WP
C Enddo
| |
RPGLE - Writting data to browser (internet explorer) from Iseries
Posted By: JimmyOctane Contact |
D*----------------------------------------------------
D*
D* API error processing
D*
D WPError DS
D EBytesP 1 4B 0 INZ(40)
D EBytesA 5 8B 0
D EMsgID 9 15
D EReserverd 16 16
D EData 17 56
D*
D* define the data for the API
D*
D WrtDta S 1024
D WrtDtaLen S 9B 0
D Count S 01 0
D WNM1 S 50
D WEX1 S 10
D WDP1 S 10
D WNM2 S 50
D WEX2 S 10
D WDP2 S 10
D WNM3 S 50
D WEX3 S 10
D WDP3 S 10
D*
D NewLine C CONST(X'15')
C eval WrtDta = %trim("Umm Hello!")
C + NewLine
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C* $WrStout - Write data to browser
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
CSR $WrStOut Begsr
C*
C eval WrtDtaLen = %len(%trim(WrtDta))
C CALLB 'QtmhWrStout'
C PARM WrtDta
C PARM WrtDtaLen
C PARM WPError
*
C*
C Endsr
C*----------------------------------------------------
| |
RPGLE - Creating an array of from defining an external table as data structure
Posted By: JimmyOctane Contact |
D*
D* The file BUDGET hold budget info both $dollars and expected sold qtys
D* We just want the money, so it starts in position 6 and ends with 77.
D* Its also stored by month (thats why 12) so now we have all $'s for all
D* months in one place BUD
D*
D E DS EXTNAME(BUDGET)
D BUD 6 77P 2
D DIM(12)
| |
RPGLE - Stop debug from looping on file fields header spec
Posted By: JimmyOctane Contact |
H option(*srcstmt: *nodebugio) dftactgrp(*no)
| |
RPGLE - Date difference hour minute second
Posted By: JimmyOctane Contact |
C*
C*DiffDays = %Diff(ToISO:FromISO:*DAYS)
C*
C SAVEETIME Subdur SAVESTIME DiffSec:*S
C*
C Eval RunHours = (DiffSec/3600)
C Eval RunMinutes = (DiffSec/60 - RunHours * 60)
C Eval RunSeconds = (DiffSec -((RunHours * 3600)+
C (RunMinutes * 60)))
C*
| |
RPGLE - Subroutine to backup libraries from a file using QCMDEXC
Posted By: JimmyOctane Contact |
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C* $Backup - Backup the libraries/files from the system
C* SAVLIB LIB(LIBRARY) DEV(&DEVICE) ENDOPT(&REWIND)
C* SAVF(&SAVFLIB/&SAVF) SAVACT(*LIB) ACCPTH(*YES)
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
C $Backup Begsr
C*
C KeyName Setll BCKLIB03P
C KeyName Reade BCKLIB03P
C Dow Not%Eof(BCKLIB03P)
C*
C* save command always use SAV command.
C*
C Select
C When TYPE = '*LIB'
C Eval SaveCmd = 'SAVLIB LIB('
C When TYPE = '*FIL'
C Eval SaveCmd = 'SAVOBJ OBJ('
C When TYPE = '*DOC'
C Eval SaveCmd = 'SAV'
C Endsl
C*
C* SAVLIB LIB(JUNK) DEV(*SAVF) SAVF(JJFLIB/SAVF)
C*
C Eval Device = 'DEV(' + %Trim(TAPEDRIVE)
C + %Trim(')')
C Eval EndOpt = %Trim('ENDOPT(')
C + %trim(ENDOFTAPE) + %Trim(')')
C*
C* write record for start of backup - Start Date And Time
C*
C If Not%Open(BCKLIB04P)
C Open BCKLIB04P
C Endif
C*
C If Not%Eof(BCKLIB03P)
C*
C Time SAVESTIME
C Time KeyTime
C Move *DATE SAVESDATE
C Move *DATE KeyDate
C Write BCK04R
C*
C Endif
C*
C If %Open(BCKLIB04P)
C Close BCKLIB04P
C Endif
C*
C Eval CmdString = %Trim(SaveCmd) + %Trim('@@')
C + %Trim(OBJECT) + %Trim(')@')
C + %Trim(Device)+ %trim('@')+%Trim(EndOpt)
C + %Trim('@SAVACT(*LIB) ACCPTH(*YES)')
C*
C '@':' ' Xlate CmdString CmdString
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm 256. CmdLength
C*
C* write record for start of backup - End Date And Time - Total run
C*
C Back04Key Klist
C Kfld LISTNAME
C Kfld OBJECT
C Kfld KeyDate
C Kfld KeyTime
C*
C If Not%Open(BCKLIB04P)
C Open BCKLIB04P
C Endif
C*
C Back04Key Chain BCKLIB04P
C If %Found(BCKLIB04P)
C Time SAVEETIME
C Move *DATE SAVEEDATE
C*
C*DiffDays = %Diff(ToISO:FromISO:*DAYS)
C*
C SAVEETIME Subdur SAVESTIME DiffSec:*S
C*
C Eval RunHours = (DiffSec/3600)
C Eval RunMinutes = (DiffSec/60 - RunHours * 60)
C Eval RunSeconds = (DiffSec -((RunHours * 3600)+
C (RunMinutes * 60)))
C*
C Exsr $LibInfo
C*
C Update BCK04R
C Endif
C*
C If %Open(BCKLIB04P)
C Close BCKLIB04P
C Endif
C*
C KeyName Reade BCKLIB03P
C Enddo
C*
C* if there is a program to run then run it.
C*
C If ENDPGM <> *Blanks
C Eval CmdString = 'CALL@@' + %Trim(ENDPGMLIB)
C + %Trim('/') + %Trim(ENDPGM)
C '@':' ' Xlate CmdString CmdString
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm 256. CmdLength
C Endif
C*
C Endsr
| |
RPGLE - Examples for FREE RPG
Posted By: Jamie Flanary Contact |
Programmers can specify search arguments in keyed Input/Output operations in
/FREE calculations in two new ways:
1. By specifying the search arguments (which can be expressions) in a list.
2. By specifying a data structure which contains the search arguments.
Examples:
D custkeyDS e ds extname(custfile:*key)
/free
CHAIN (keyA : keyB : key3) custrec;
CHAIN %KDS(custkeyDS) custrec;
|
|
|
|
|
|
| |
RPGLE - Various date examples
Posted By: Jamie Flanary Contact |
H*-----------------------------------------
H* %MSeconds %Seconds, %Minutes, %Hours,
H* %Days, %Months, and %Years.
H* %Date, %Time, and %TimeStamp
H*
H*
H*
H*
H*-----------------------------------------
D*-----------------------------------------
D* Program Info
D*-----------------------------------------
D SDS
D @PGM 001 010
D @PARMS 037 039 0
D @JOB 244 253
D @USER 254 263
D @JOB# 264 269 0
D*
D* Field Definitions.
D*
D ISOdate S D
D USAdate S D DatFmt(*USA)
D XMASDate S D Inz(D'2003-12-25')
D LogonDate S D
D Date_Start S 15
D MonthNames S 12 Dim(12) CtData
D Date_String S 40
*
* Time Stamp
*
DTimeStamp S Z
*
D WorkISO S D
D Month S 2 0
D Day S 2 0
D Year S 4 0
D Decimal8 S 8 0
D LogMonth S 2 0
D LogDay S 2
D LogYear S 4 0
D NextMonth S D
D EndOfMonth S D
*
* Variables for free RPG example + some above
*
D DateIn S D
D FromISO S D
D ToISO S D
D DiffDays S 3 0
D WorkField S 5 0
D Name S 9 Based(NamePtr)
D Name2 S 9
D NamePtr S * Inz(%ADDR(Names))
D Names S 63 Inz('Sunday Monday Tuesday Wedn+
D esdayThursday Friday Saturday ')
D*
D* RPG-defined date formats and separators for Date data type
D*
* 2-Digit Year Formats
* *MDY Month/Day/Year mm/dd/yy 8 09/26/03
* *DMY Day/Month/Year dd/mm/yy 8 26/09/03
* *YMD Year/Month/Day yy/mm/dd 8 03/09/26
* *JUL Julian yy/ddd 6 03/926
C*=====
* 4-Digit Year Formats
* *ISO Int Standards Org yyyy-mm-dd 10 2003-09-26
* *USA IBM USA Standard mm/dd/yyyy 10 09/26/2003
* *EUR IBM European Std dd.mm.yyyy 10 26.09.2003
* *JIS Japan Indst Std yyyy-mm-dd 10 2003-09-26
*
*
C*
*
* Okay first lets get todays date
* For display purposes the date is now
* Friday September 26th 2003
* so date now looks like this 2003-09-26
* because the default date type is *ISO
*
C Eval ISOdate = %Date()
*
* Now that I have the date in a date format
* (*ISO) I can do stuff to it.
* Once I move this date to a decimal 8,0 field
* the date is now in format 20030926
* Not very exciting..yet
*
C Move ISODate Decimal8
*
* Now back to the *ISO date lets add
* 1 month to the date.
* date after will equal 2003-10-26
* %days and % years works the same as %months
*
C Eval WorkISO = ISODate + %Months(1)
*
* Logon date is set equal to today then the month is extracted
* the "*M" is the same as "*Months" LogMonth = 09.
* LogDay = 26.
*
C Eval LogonDate = %Date()
C Extrct LogonDate:*Y LogYear
C Extrct LogonDate:*M LogMonth
C Extrct LogonDate:*D LogDay
*
* Build the date string - Later we will add the day name
*
C Eval Date_String =
C %Trim(MonthNames(LogMonth))
C + %trim('@') + %Trim(LogDay)
C + %trim(',@') + %Char(LogYear)
*
* convert the "@" back to *Blanks
* Date_String = 'September 26, 2003'
*
C '@':' ' Xlate Date_String Date_String
*
* TimeStamp = yyyy-mm-dd-hh.mm.ss.mmmmmm (length 26).
* TimeStamp = '2003-09-26-15.16.26.531000'
*
C Eval TimeStamp = %TimeStamp()
*
* Free Format date stuff By the way Name2 = 'Friday'
*
/Free
DateIn = %Date() ;
ISODate = %Date() ;
ISODate = DateIn ;
Year = %Subdt(ISODate:*Y) ;
Month = %Subdt(ISODate:*M) ;
Day = %Subdt(ISODate:*D) ;
FromISO = ISODate - %YEARS(1) ;
ToISO = ISODate ;
DiffDays = %Diff(ToISO:FromISO:*DAYS) ;
ISODate = DateIn ;
WorkField = %Diff(ISODate:D'1899-12-31':*DAYS);
WorkField = %REM(WorkField:7);
NamePtr = NamePtr + (WorkField * 9);
Name2 = Name;
/End-Free
*
* Build the date string - With The Day Name
* DATE_STRING = 'Friday September 26, 2003 '
*
C Eval Date_String =
C %trim(Name) + %Trim('@@')
C + %trim(MonthNames(LogMonth))
C + %trim('@') + %Trim(LogDay)
C + %trim(',@') + %Char(LogYear)
C Eval Date_String = %Xlate('@':' ':Date_String)
*
* Calculate the last day of the month
* ENDOFMONTH = '2003-09-30'
*
C ISODate AddDur 1:*Months NextMonth
C Extrct NextMonth:*D DiffDays
C NextMonth SubDur DiffDays:*D EndOfMonth
C Eval *INLR = *On
C*----------------------------------------------------
** CTDATA MonthNames
January
February
March
April
May
June
July
August
September
October
November
December
| |
RPGLE - Converting *Char to *Dec
Posted By: Jamie Flanary Contact |
c Eval numericField =
c %dec( %xlate(',':' ':alphaFld) : 15 : 2)
Note the %xlate replaces the thousands separator with a blank.
You may also need to %xlate '$' and '*', depending on your data.
%dec hates thousands separators, but ignores all blanks.
You will get a runtime error RNQ0105 if the argument isn't valid
according to the rules found in the RPG reference.
| |
RPGLE - Free form RPG read entire table
Posted By: JimmyOctane Contact |
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
/free
// Loop through all records of file
read file;
dow not %eof(file); // Process until end of file
if %error;
dsply 'Read error: process aborting.';
leave;
else;
pos = %scan (',': name);
if pos > 0;
firstname = %trimr(%subst(name:1:pos-1));
update file;
endif;
read file;
enddo;
/end-free
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
| |
RPGLE - Write directly to IFS
Posted By: JimmyOctane Contact |
H dftactgrp( *no ) bnddir( 'QC2LE' ) OPTION(*SRCSTMT : *NODEBUGIO)
H*============================================================
H*
H*============================================================
FRUAF015D IF E DISK
FSRBNAM IF E K DISK
FSRBNFP IF E K DISK
FSRBNOI IF E K DISK
D*
D RC S 10I 0
D FileNam S 20A INZ('/code400/File819.txt')
D FileNamP S * INZ(%ADDR(FileNam))
D FileDescr S 10I 0
D O_CREAT S 10I 0 INZ(8)
D O_RDWR S 10I 0 INZ(4)
D O_TEXTDATA S 10I 0 INZ(16777216)
D O_CODEPAGE S 10I 0 INZ(8388608)
D Oflag S 10I 0 INZ(0)
D Omode S 10U 0 INZ(511)
D cp S 10U 0 INZ(819)
D WorkEmail S 50
D CmdString S 512
D CmdLength S 15 5
D SendEmail S 50
D Len S 03 0
D*
D Big S 500
D Customer S 11
D Key#2 S 10 Inz('*PHONE')
D Chr7 S 07
D Dec7 S 07 0
D Chr8 S 08
D Chr4 S 04
D Chr6 S 06
D Negative S 01
D Chr2 S 02
D Month S 02 0
D ChrMonth S 02
D Year S 04 0
D Day S 02 0
D ChrDay S 02
D ISODate S D
D Str S 03 0
D Q C CONST('''')
D*
D* Program Info
D*
D SDS
D @PGM 001 010
D @PARMS 037 039 0
D @JOB 244 253
D @USER 254 263
D @JOB# 264 269 0
D*
D InID S 11
D InDirection S 01
D InTrans S 15 5
D*
D ZeroBin S 1A INZ(*ALLX'00')
D NLZero S 2A INZ(X'1500')
D SI_Fmt S 50A INZ('\n')
D SI_FmtP S * INZ(%ADDR(SI_Fmt))
D SI_Msg S 50A
D SI_MsgP S * INZ(%ADDR(SI_Msg))
D Num_DS DS
D Num_Hex 4A INZ(X'00000000')
D Num 10I 0 OVERLAY(Num_Hex)
D Buf S 500A
D BufP S * INZ(%ADDR(Buf))
D BufLen S 10U 0
Dperror PR 10I 0 EXTPROC('perror')
Dconst * VALUE
Dsprintf PR 10I 0 EXTPROC('sprintf')
D * VALUE
D * VALUE
D 10I 0 VALUE OPTIONS(*NOPASS)
D * VALUE OPTIONS(*NOPASS)
* Open Operations
* value returned = file descriptor 0 (OK), -1 (Error)
Dopen PR 10I 0 EXTPROC('open')
D * VALUE
D 10I 0 VALUE
D 10U 0 VALUE OPTIONS(*NOPASS)
D 10U 0 VALUE OPTIONS(*NOPASS)
* Read Operations
* value returned = number of bytes read or , -1 (Error)
Dread PR 10I 0 EXTPROC('read')
D 10I 0 VALUE
D * Value
D 10U 0 VALUE
* Write Operations
* value returned = number of bytes Written or , -1 (Error)
Dwrite PR 10I 0 EXTPROC('write')
D 10I 0 VALUE
D * VALUE
D 10U 0 VALUE
* Close Operations
* value returned = 0 (OK) or , -1 (Error)
Dclose PR 10I 0 EXTPROC('close')
D 10I 0 VALUE
* Open Directory Operation
* value returned = file descriptor 0 (OK), -1 (Error)
Dopendir PR * EXTPROC('opendir')
D * VALUE
* Read Directory Operation
*
Dreaddir PR * EXTPROC('readdir')
D * VALUE
* Open Directory Operation
* value returned = 0 (OK) or , -1 (Error)
Dclosedir PR 10I 0 EXTPROC('closedir')
D * VALUE
* Unlink a File from system... Delete File
* value returned = 0 (OK) or , -1 (Error)
Dunlink PR 10I 0 EXTPROC('unlink')
D * VALUE
C *MDY Move UDATE ISODate
C Extrct ISODate:*Y Year
C Extrct ISODate:*M Month
C Extrct ISODate:*D Day
C Move Year Chr4
C Move Month Chr2
C Eval Chr4 = %Trim(Chr2) +
C %Trim(%Subst(Chr4:3:2))
C
C Clear Str
C 'MMYY' Scan FileNam Str
C If %Found
C Eval %Subst(FileNam:Str:4) = Chr4
C Endif
C*
C*
C*
C Z-add O_CREAT Oflag
C Add O_RDWR Oflag
C Add O_CODEPAGE Oflag
C EVAL FileDescr=open(FileNamP:Oflag:Omode:cp)
C IF FileDescr = -1
C EVAL RC = perror(FileNamP)
C Return
C ENDIF
C EVAL RC = close(FileDescr)
C IF RC = -1
C EVAL RC = perror(FileNamP)
C Return
C ENDIF
C Z-Add O_RDWR Oflag
C Add O_TEXTDATA Oflag
C EVAL FileDescr=open(FileNamP:Oflag)
C IF FileDescr = -1
C EVAL RC = perror(FileNamP)
C Return
C ENDIF
C*----------------------------------------------------------------
C* This is where the writting takes place
C*----------------------------------------------------------------
C EVAL Buf='This is a Test number 1' + X'25'
C *Start Setll RUAF015D
C Read RUAF015D
C Dow Not%Eof(RUAF015D)
C
C Eval %Subst(Big:001:11) = PRIME
C Eval %Subst(Big:016:30) = NXNAME
C Eval %Subst(Big:056:30) = NXADR1
c Eval %Subst(Big:086:30) = NXADR2
C
C* Chain to srbnam and get city, state, zipcode
C
C Movel(p) PRIME Customer
C Customer Chain SRBNAM
C If %Found(SRBNAM)
C Eval %Subst(Big:116:20) = NAADR4
C Eval %Subst(Big:136:02) = NASPCD
C Eval %Subst(Big:138:10) =
C %Trim(%Subst(NAPOCD:4:10))
C*
C* Country code
C*
C Eval %Subst(Big:281:05) = %Trim(NACOUN)
C Endif
C*
C* Chain to srbnfp for the phone number
C*
C Key01 Klist
C Kfld Customer
C KFLD Key#2
C Key01 Chain SRBNFP
C If %Found(SRBNFP)
C Eval %Subst(Big:148:10) =
C %Trim(%Subst(NFPHNO:1:3)) +
C %Trim(%Subst(NFPHNO:5:7))
C Endif
C
C*
C* take the date entered from customer master and send as date opened
C* format will be MMYY
C*
C Move NACRDT Chr8
C Eval %Subst(Big:158:04) =
C %Trim(%Subst(Chr8:5:2)) +
C %Trim(%Subst(Chr8:3:2))
C*
C* Create the run date
C*
C *MDY Move UDATE ISODate
C Extrct ISODate:*Y Year
C Extrct ISODate:*M Month
C Extrct ISODate:*D Day
C Move Month ChrMonth
C Move Day ChrDay
C Eval Chr8 = %Char(Month) + %Char(Day) +
C %Char(Year)
C Move Year Chr4
C Eval Chr2 = %Subst(Chr4:3:2)
C Eval Chr6 = %Trim(ChrMonth) + %Trim(ChrDay)
C + %Trim(Chr2)
C Eval %Subst(Big:162:06) = Chr6
C*
C* Create the last invoice MMYY format date
C*
C Customer Chain SRBNOI
C If %Found(SRBNOI)
C *ISO Test(De) NOLIND
C If Not%Error
C *ISO Move NOLIND ISODate
C Extrct ISODate:*Y Year
C Extrct ISODate:*M Month
C Extrct ISODate:*D Day
C Move Month ChrMonth
C Move Year Chr4
C Eval Chr2 = %Subst(Chr4:3:2)
C Eval Chr4 = %Trim(ChrMonth) + %Trim(Chr2)
C Eval %Subst(Big:168:08) = Chr4
C Endif
C Endif
C*
C* now do the balance, current and the 4 horsemen
C*
C If BALANCE < *Zeros
C Eval BALANCE = (BALANCE * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C Move BALANCE Chr7
C*
C If Negative = 'Y'
C Eval %Subst(Big:172:08) = Chr7 +%Trim('-')
C Else
C Eval %Subst(Big:172:08) = '0' + %Trim(Chr7)
C Endif
C*
C* current
C*
C Eval Dec7 = CURRENT + NOTDUE
C*
C If Dec7 < *Zeros
C Eval Dec7 = (Dec7 * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C*
C Move Dec7 Chr7
C If Negative = 'Y'
C Eval %Subst(Big:180:08) = Chr7 + %Trim('-')
C Else
C Eval %Subst(Big:180:08) = '0' + %Trim(Chr7)
C Endif
C*
C* 30 days past
C*
C If DUEM01 < *Zeros
C Eval DUEM01 = (DUEM01 * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C Move DUEM01 Chr7
C If Negative = 'Y'
C Eval %Subst(Big:188:08) = Chr7 + %Trim('-')
C Else
C Eval %Subst(Big:188:08) = '0' + %Trim(Chr7)
C Endif
C*
C* 60 days past
C*
C If DUEM02 < *Zeros
C Eval DUEM02 = (DUEM02 * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C Move DUEM02 Chr7
C If Negative = 'Y'
C Eval %Subst(Big:196:08) = Chr7 + %Trim('-')
C Else
C Eval %Subst(Big:196:08) = '0' + %Trim(Chr7)
C Endif
C*
C* 90 days past
C*
C If DUEM03 < *Zeros
C Eval DUEM03 = (DUEM03 * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C Move DUEM03 Chr7
C If Negative = 'Y'
C Eval %Subst(Big:204:08) = Chr7 + %Trim('-')
C Else
C Eval %Subst(Big:204:08) = '0' + %Trim(Chr7)
C Endif
C*
C* Over 90 days past
C*
C If DUEM04 < *Zeros
C Eval DUEM04 = (DUEM04 * -1)
C Eval Negative = 'Y'
C Else
C Eval Negative = 'N'
C Endif
C Move DUEM04 Chr7
C If Negative = 'Y'
C Eval %Subst(Big:212:08) = Chr7 + %Trim('-')
C Else
C Eval %Subst(Big:212:08) = '0' + %Trim(Chr7)
C Endif
C*
C* Contact name
C*
C Eval %Subst(Big:241:20) = %Trim(NOCONT)
C*
C* write the line out.
C*
C EVAL Buf = Big + X'25'
C Movel(p) Big Buf
C Eval %Subst(Buf:500:1) = X'25'
C X'25' SCAN Buf BufLen 30
C EVAL RC = write(FileDescr: BufP: BufLen)
C Clear Big
C Clear Buf
C
C Read RUAF015D
C Enddo
C*
C*Shut down the IFS file and prepare to email.
C*
C Exsr $TheEnd
C*----------------------------------------------------------------
C* T H E E N D
C*----------------------------------------------------------------
CSR $TheEnd Begsr
C IF RC = -1
C EVAL RC = perror(FileNamP)
C Return
C ENDIF
C*
C* Close the File
C*
C EVAL RC = close(FileDescr)
C IF FileDescr = -1
C EVAL RC = perror(FileNamP)
C Return
C ENDIF
C*
C Eval *INLR = *On
C*
C Endsr
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
C* *INZSR - Initial one time run subroutine
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
CSR *INZSR Begsr
C*
C Endsr
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
| |
RPGLE - test numeric
Posted By: jimmy octane Contact |
D NumParm S 4
D DS
D Chk_Seasn 1 4
D Chk_Numeric 1 4S 0
C *Entry Plist
C Parm NumParm
C Eval Chk_Seasn = NumParm
C TestN Chk_Seasn 99
C If *IN99 = *On
C If Chk_Numeric >= *Zero
C 'Good' Dsply
C Else
C 'Bad' Dsply
C EndIf
C Else
C 'Bad' Dsply
C EndIf
C Eval *INLR = *On
| |
RPGLE - Unique file name example
Posted By: JimmyOctane Contact |
H dftactgrp(*no) option(*srcstmt : *nodebugio)
*
* Field Definitions
*
D FileName s 80
D Prefix s 256 Inz('Code400')
D ISODate s D
D ISOTime s T
D Month s 2 0
D Day s 3 0
D Hour s 3 0
D Minute s 3 0
D Second s 3 0
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
*
C Eval ISODate = %Date()
C Eval ISOTime = %Time()
C Eval Month = %Subdt(ISODate:*Months)
C Eval Day = %Subdt(ISODate:*Days)
C Eval Hour = %Subdt(ISOTime:*Hours)
C Eval Minute= %Subdt(ISOTime:*Minutes)
C Eval Second= %Subdt(ISOTime:*Seconds)
C eval FileName = %trim(Prefix) +
C %trim(%Char(Month))+
C %trim(%Char(Day))+
C %trim(%Char(Hour))+
C %trim(%Char(Minute))+
C %trim(%Char(Second))+
C %trim('.csv')
C*
C* The variable FileName will look like .... Code4001014113435.csv
C* depending on the date and time of course.....
C*
C eval *inlr = *on
C return
| |
RPGLE - Convert Date - free format
Posted By: JimmyOctane Contact |
V5R2
/free
numDate = %int(%char(date : *eur0); // ddmmyyyy
numTS = %dec(%char(timestamp : *iso0) : 20 : 0); //yyyymmddhhmmssuuuuuu
/End Free
V5R1
H bnddir('QC2LE')
D atoll pr 20i 0 extproc('atoll')
D string * value options(*string)
/free
numDate = atoll(%char(date : *eur0));
/End Free
| |
RPGLE - convert amount Numeric to WORDS
Posted By: JimmyOctane Contact |
Rewrite this later
E AR$ 11 1 ALPHA AMOUNT
E W 20 9 ARRAY OF WORDS
E X 7 19 9 WORDS 1 TO 19
E Y 7 8 9 WORDS 20 TO 90
E MISC 7 10 9 MISC. WORDS
E WORK 9 1 WORK ARRAY
E AMT 150 1 RESULT ARRAY
*
* PARAMETERS: LIMIT = WORD LENGTH LIMIT (MAXIMUM 150),
* CHK$ = CHECK AMOUNT TO CONVERT (MAXIMUM 999,999,999.99),
* VALUE = SPELLED AMOUNT RETURNED TO CALLING PROGRAM, ERROR =
* ERROR FLAG WHEN SPELLED AMOUNT EXCEEDS LIMIT.
*
C *ENTRY PLIST
C PARM LIMIT 30 MAX: 150
C PARM CHK$ 112 999,999,999.99
C PARM VALUE 150 RETURN VALUE
C PARM ERROR 1 ERROR FLAG
*
* CONVERT CHECK AMOUNT TO POSITIVE, IF NECESSARY
*
C CHK$ IFLT 0
C Z-SUBCHK$ CHK$2 112
C ELSE
C Z-ADDCHK$ CHK$2
C END
*
* TRANSLATE CHECK AMOUNT INTO WORDS
*
C MOVEA'00' *IN,06
C MOVE *BLANKS WORDS 4
C MOVE *BLANKS ERROR
*
C WORDS DOUEQ'QUIT'
C MOVE *BLANKS AMT
C MOVE *BLANKS W
C MOVE CHK$2 CHK$A 11
C MOVEACHK$A AR$
C Z-ADD1 I 30
*
C CHK$2 IFGE 1000000 OVER $1,000,000
C MOVEAAR$,1 A03 3
C EXSR SUBN30
C MOVE MISC,2 W,I
C ADD 1 I
C END CHK$2>=1000000
*
C MOVEAAR$,4 A03 OVER $1,000
C MOVE A03 N30
C N30 IFNE 0
C EXSR SUBN30
C MOVE MISC,3 W,I
C ADD 1 I
C END N30 IFNE 0
*
C MOVEAAR$,7 A03 LESS THAN $1000
C MOVE A03 N30
C N30 CASNE*ZEROS SUBN30
C END
*
C CHK$2 IFLT 1 UNDER A BUCK
C MOVE MISC,4 W,I
C ADD 1 I
C END CHK2$ IFLT 1
*
C MOVE MISC,5 W,I ADD "DOLLARS
C ADD 1 I AND"
C *IN07 IFEQ '0'
C MOVE MISC,6 W,I
C ELSE
C MOVE MISC,10 W,I
C END *IN07 IFEQ '0'
C ADD 1 I
*
C MOVEAAR$,10 A02 2 PROCESS CENTS
C MOVE A02 N20
C N20 IFEQ *ZEROS
C MOVE MISC,4 W,I
C ADD 1 I
C ELSE
C *IN06 IFEQ '0'
C EXSR SUBN20
C ELSE
C MOVELA02 W,I
C ADD 1 I
C END *IN06 IFEQ '0'
C END N20 IFEQ *ZERO
C N20 IFNE 01
C MOVE MISC,7 W,I
C ELSE
C MOVE MISC,8 W,I
C END N20 IFNE 01
C ADD 1 I
*
C CHK$ IFLT 0 NEGATIVE AMOUNT
C MOVE MISC,9 W,I
C END CHK$ IFLT 0
*
C Z-ADD1 I COMPRESS ARRAY
C Z-ADD1 J 30 W
*
C I DOWLE19
C MOVEAW,I WORK
C Z-ADD1 K 20
C ' ' LOKUPWORK,K 05
C *IN05 IFEQ '0'
C Z-ADD10 K
C END
C MOVEAWORK AMT,J
C ADD K J
C ADD 1 I
C W,I IFEQ *BLANKS
C Z-ADD20 I
C END
*
C END I DOWLE 19
*
* IS THE RESULTANT CHARACTER STRING TOO LONG? IF YES,
* TRY TO SHORTEN IT.
*
C J IFGT LIMIT
*
* IF *IN07 IS ON, STRING IS TOO LONG. EXIT WITH ERROR.
*
C *IN07 IFEQ '1'
C MOVE 'QUIT' WORDS
C MOVE 'Y' ERROR
C END
*
* IF *IN06 IS ON, RETRY SHORTENING STRING.
*
C *IN06 IFEQ '1'
C MOVE '1' *IN07
C END
C MOVE '1' *IN06
C ELSE
C MOVE 'QUIT' WORDS
C END J IFGT LIMIT
*
C END WORDS LOOP
*
* SETON LAST RECORD LE
*
C MOVE *BLANKS VALUE
C ERROR IFNE 'Y'
C MOVEAAMT VALUE
C END
*
C MOVE '1' *INLR
*
* SUBROUTINE TO TRANSLATE THE TWO RIGHT DIGITS OF EACH DIGIT
* TRIAD TO ITS SPELLED-OUT EQUIVALENT.
*
*
CSR SUBN20 BEGSR
C N20 IFGE 20
C MOVELN20 N10
C SUB 1 N10
C MOVE Y,N10 W,I
C ADD 1 I
C MOVE N20 N10
C N10 IFNE 0
C MOVE X,N10 W,I
C ADD 1 I
C END N10 IFNE 0
C ELSE
C N20 IFNE 0
C MOVE X,N20 W,I
C ADD 1 I
C END N20 IFNE 0
C END N20 IFGE 20
CSR ENDSR
*
* SUBROUTINE TO TRANSLATE THE LEFTMOST DIGIT OF A TRIAD TO
* ITS WORD QUIVALENT AND STORE THE TWO RIGHTMOST DIGITS OF
* THE TRIAD IN VARIABLE N20 FOR SUBSEQUENT PROCESSING.
*
CSR SUBN30 BEGSR
C MOVE A03 N30 30
C MOVELA03 N10 10
C MOVE A03 N20 20
C N10 IFNE 0
C MOVE X,N10 W,I
C ADD 1 I
C MOVE MISC,1 W,I
C ADD 1 I
C END N10 IFNE 0
C EXSR SUBN20
CSR ENDSR
*
* WORD ARRAYS
*
**
ONE TWO THREE FOUR FIVE SIX SEVEN
EIGHT NINE TEN ELEVEN TWELVE THIRTEEN FOURTEEN
FIFTEEN SIXTEEN SEVENTEENEIGHTEEN NINETEEN
**
TWENTY THIRTY FORTY FIFTY SIXTY SEVENTY EIGHTY
NINETY
**
HUNDRED MILLION, THOUSAND,NO DOLLARS AND CENTS
CENT CR &
| |
RPGLE - *ENTRY with a prototype
Posted By: JimmyOctane Contact |
dmain pr extpgm('CODE400')
d numberIn 15p 5
d*ENTRY
dmain pi
d numberIn 15p 5
d text s 15
c if %parms > 0
c move numberin text
c text dsply
c else
c 'Need number!'dsply
c endif
c eval *inlr = *on
| |
RPGLE - Retrieve IP with RPGLE
Posted By: JimmyOctane Contact |
H DFTACTGRP(*NO) BNDDIR('QC2LE')
D GetIpAdr PR 20a
D Device 10a CONST
*
D I_Net_Adr S 16a
*
D SDS
D Device 244 253
*---------------------------------------------------------
* Retrieve IP Address
C Eval I_Net_Adr = GetIpAdr(Device)
C Eval I_Net_Adr = %trim(I_Net_Adr)
C I_Net_Adr Dsply
C Eval *Inlr = *On
* RtvIpAdr - Subprocedure To Get IP Address
*---------------------------------------------------------
P GetIpAdr B Export
D GetIpAdr PI 20A
D Inp_Device 10A Const
D Apierr DS
D Bytprv 1 4B 0 Inz(216)
D Bytavl 5 8B 0 Inz
D Errorid 9 15A Inz
D Reserved 16 16A Inz
D ErrorDesc 17 216A Inz
D Net_Address S 20A INZ
D Format S 8A Inz('DEVD0600')
D Rcvar S 5000A Inz
D Varlen S 4B 0 Inz(5000)
C Eval Device = Inp_Device
C Call 'QDCRDEVD'
C Parm Rcvar
C Parm Varlen
C Parm Format
C Parm Device
C Parm Apierr
C If BytAvl = 0
C Eval Net_Address = %Subst(Rcvar:877:16)
C Endif
C Return Net_Address
P GetIpAdr E
| |
RPGLE - Generic template for Dynamic arrays in RPGIV
Posted By: prithviraj.D Contact |
The author of the code is Mr.Dave (Courtesy--Midrange .com)
The following text is the authors words about his code.
.....i.e Dave says
" Here is a generic program I use as a template when I'm building
applications with dynamic arrays.
FYI: When a ReAlloc is performed, "new" storage on the heap is allocated.
The "new" storage is initialized by the "old" storage. The "old" storage
is then released.The final amount of storage used is released with a DeAlloc
or when the activation group dies.
I hope it is what your looking for. I'd be glad to help if you have any questions.
----- Dave "
*##########################################*
Constants
*##########################################*
* The size of an element in the array.
D ArrayElmSize C %Size(ArrayElm)
* The # of elements by which the array will be incremented
* each time memory is allocated.
D ArrayIncAmt C 5
*###########################################*
Data Structures
*###########################################*
* Because the array is based, the compiler reserves no space
* for it at all and assumes you know what you are doing with
* the pointer ArrayPtr.
* If a variable is based, it means that it doesn't have any memory
* dedicated to it - it isn't fixed at a specific address.
* It will be at wherever its 'basing pointer' is set to.
*######################################################*
D ArrayElm DS
D Name 25
D Address 25
*############################################*
StandAlone Fields
*############################################*
D Array S Like(ArrayElm) Dim(32767)
D Based(ArrayPtr)
* The current # of elements in the array.
D Array#ofElm S 10 0
* The array index.
D ArrayIndex S 5 0
* The index of the last element of the array.
D ArrayLastElm S 5 0
* The current # of elements in the array.
D ArrayPtr S *
* The current # of bytes of storage allocated to the array.
D ArrayStorage S 10 0
*##############################################*
* Allocate initial storage for the array.
*##############################################*
C Eval ArrayLastElm = 0
C Eval ArrayPtr = *Null
C Eval Array#ofElm = ArrayIncAmt
C Eval ArrayStorage = Array#ofElm * ArrayElmSize
C Alloc ArrayStorage ArrayPtr
C Do 32767
C If ArrayLastElm = Array#ofElm
C Eval Array#ofElm = Array#ofElm + ArrayIncAmt
C Eval ArrayStorage = Array#ofElm * ArrayElmSize
C ReAlloc ArrayStorage ArrayPtr
C EndIf
C Eval ArrayLastElm = ArrayLastElm + 1
C Eval Array(ArrayLastElm) = 'Who Cares'
C Eval %Subst(Array(ArrayLastElm):25) = '123 Main Street'
C EndDo
C Eval *INLR = *ON
| |
RPGLE - Delay an RPG program
Posted By: prithviraj.D Contact |
PUTTING YOUR RPG PROGRAM TO SLEEP
Q: How do I insert pauses into my RPG program? In other words, how do I make
my RPG program go to sleep for a while?
A: The easiest way is to sing it a lullaby. There are a few other ways,
however.
You can use the Execute Command (QCMDEXC) API to run the DLYJOB command:
D qcmdexc pr ExtPgm('QCMDEXC')
D command 3000A const options(*varsize)
D length 15P 5 const
* wait for 5 seconds before continuing:
*
c callp qcmdexc('DLYJOB DLY(5)': 13)
One nice thing about the DLYJOB command is that it can resume at a given
time:
D qcmdexc pr ExtPgm('QCMDEXC')
D command 3000A const options(*varsize)
D length 15P 5 const
* wait until 02:17 before continuing:
*
c callp qcmdexc('DLYJOB RSMTIME(021700)': 22)
The sleep() API is nice because the source code is both shorter and easier
to read:
H DFTACTGRP(*NO)
D sleep PR 10I 0 extproc('sleep')
D seconds 10U 0 value
c callp sleep(10)
Sometimes you want to pause for less than a second, especially if you're
doing an animation such as scrolling text or graphics. The usleep() API
let's you specify your delay time in microseconds:
H DFTACTGRP(*NO)
D usleep PR 10I 0 extproc('usleep')
D seconds 10U 0 value
* Note, usleep works with microseconds (one millionth of a second)
* so the following equates to one half of a second:
c callp usleep(500000)
The select() API (which is usually used in sockets programming) can also be
used to put your program to sleep. One advantage of select() is that you can
specify both whole seconds and fractional seconds in the same call:
H DFTACTGRP(*NO)
D select PR 10I 0 extproc('select')
D max_fds 10I 0 value
D read_set * value
D write_set * value
D excp_set * value
D timeout * value
D timeval ds
D tv_sec 10I 0
D tv_usec 10I 0
*
* tv_sec = number of seconds
* tv_usec = number of microseconds (one millionth of a second)
*
* the following waits for 4.5 seconds:
*
c eval tv_sec = 4
c eval tv_usec = 500000
c callp select(0: *NULL: *NULL: *NULL:
c %addr(timeval))
| |
RPGLE - Data structures, Arrays and OVERLAY
Posted By: JimmyOctane Contact |
Those of you who have been using RPG IV for a while may not have noticed
that additional function has been added to the OVERLAY keyword. It is now
possible to specify the name of a data structure as the “parent” as you can see
in the following example:
D DayData DS
D 9A Inz('Monday')
D 9A Inz('Tuesday')
D 9A Inz('Wednesday')
D 9A Inz('Thursday')
D 9A Inz('Friday')
D 9A Inz('Saturday')
D 9A Inz('Sunday')
D DayName 9A Dim(7) Overlay(DayData)
| |
RPGLE - Determine day of the week - subprocedure
Posted By: JimmyOctane Contact |
* Prototype for subprocedure
D DayOfWeek PR 1 0
D InputDate D Datfmt(*ISO)
* Days of the week name table - note ield names are required
D NameData DS
D 9 Inz('Monday')
D 9 Inz('Tuesday')
D 9 Inz('Wednesday')
D 9 Inz('Thursday')
D 9 Inz('Friday')
D 9 Inz('Saturday')
D 9 Inz('Sunday')
* Define the array as an overlay of the DS name
D Name 9 Dim(7) Overlay(NameData)
D DayName S 9
D WorkDate S D DatFmt(*ISO)
* Program input parameter
C *Entry PList
C Parm WorkDate
* Using DayofWeek, initialize DayName with table Name 5
C Eval DayName = Name(DayOfWeek(WorkDate))
* displaying result
C DayName Dsply
* Terminate Program
C Eval *InLR = *On
* SubProcedure: DayOfWeek (Day of the Week)
* The subprocedure accepts a valid date (format *ISO) and returns
* a number (1 digit) representing the day of the week
* (Monday = 1, ... , Sunday = 7) 2
P DayOfWeek B
* procedure interface definition 3
D DayOfWeek PI 1 0
D WorkDate D
D AnySunday C D'1999-06-13'
D WorkNum S 7 0
D WorkDay S 1 0
C WorkDate Subdur AnySunday WorkNum:*D
C WorkNum Div 7 WorkNum
C Mvr WorkDay
* Returning result to the calling procedure
C If WorkDay < 1
C Return WorkDay + 7
C Else
C Return WorkDay
C Endif
* Procedure definition end marker 2
P E
| |
RPGLE - This service program is a simple implementation of the Luhn MOD 10 algorithm which is often used to verify credit card numbers.
Posted By: Craig Caulfield Contact |
H DatFmt(*ISO) Option(*NoDebugIO) NoMain Debug(*Yes)
* Object ID : LUHNSRV
*
* Date : 28 January 2004
*
* Programmer : Craig Caulfield
*
* Description: Verifies a number according to the standard
* Luhn MOD 10 algorithm. If the procedure
* returns 0, the incoming number conforms to
* the algorithm. For any other return value,
* the number isn't valid.
*
* To create this service program:
*
* CRTRPGMOD MODULE(LUHNSRV)
* CRTSRVPGM SRVPGM(LUHNSRV) EXPORT(*ALL)
* Prototype for the procedure LuhnAlgorithm
D LuhnAlgorithm PR 1 0
D incomingNum 24A value
/eject
P LuhnAlgorithm B export
D LuhnAlgorithm PI 1 0
D incomingNum 24A value
* Local fields
D index S 3 0
D multiplier S 3 0 inz(1)
D workingNumber S 3 0
D workingLuhn S 3 0
/free
for index = %len(%trim(incomingNum)) downto 1 by 1;
workingNumber = %dec(%subst(incomingNum:index:1):3:0)
* multiplier;
if workingNumber >= 10;
workingLuhn += workingNumber - 9;
else;
workingLuhn += workingNumber;
endIf;
multiplier = 3 - multiplier;
endFor;
return %rem(workingLuhn : 10);
/end-free
P LuhnAlgorithm E
| |
RPGLE - Scan memory (or userspace) for a given string
Posted By: prithiviraj.D Contact |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* ScanSpc(): Scan memory (or userspace) for a given string
*
* Space = pointer to area of memory or user space to scan
* String = string to search for
* SpcSize = size of space to search
*
* Returns 0 if nothing found, otherwise the position of the
* string in the space.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P ScanSpc B
D ScanSpc PI 10I 0
D Space * value
D String 256A const varying options(*varsize)
D SpcSize 10I 0 value
* memchr(): Search memory for a character
D memchr PR * extproc('memchr')
D buf * value
D chartofind 10I 0 value
D bufsize 10I 0 value
* memcmp(): Compare two areas of memory
D memcmp PR 10I 0 extproc('memcmp')
D buf1 * value
D buf2 65535A const options(*varsize)
D size 10I 0 value
D DS
D Char 1A
D Num 3U 0 overlay(Char)
D p_search s *
D p_found s *
/free
if (%len(String) < 1);
return 0;
endif;
Char = %subst(String: 1: 1);
p_search = Space;
dou (memcmp(p_found: String: %len(String)) = 0);
p_found = memchr(p_search: Num: SpcSize);
if (p_found = *NULL);
return 0;
endif;
p_search = p_found + 1;
enddo;
return (p_found - space) + 1;
/end-free
P E
| |
RPGLE - CALENDAR
Posted By: Devendra Kumar R Contact |
**********************************************************************
* *
‚* Program Name : CALENDAR *
‚* Function : To Select date. *
* *
**********************************************************************
* šLogic :€It Uses output fields to display the date. *
* 1. Current date is obtained from system *
* 2. For the current month, the first day of *
* of the month and no. of days in the month *
* is calculated. *
* 3. Using this the datastructure is populated *
* then this value is copied to the display *
* fields. *
**********************************************************************
‚* Header Specifications
‚* =====================
*
H DFTACTGRP(*NO)
‚* Files Used
‚* ==========
*
š* Display file - Calendar
FCALENDARFMCF E WORKSTN
‚* Procedures Used
‚* ===============
*
š* To get the day of the week
D GetDay PR 1 0
D Date D Value
*
š* To get No of days in a month
D GetDate PR 2 0
D Date D Value
*
š* This will return the month(Text) for the numeric passed.
D GetMonth PR 9
D Month 2 0 Value
‚* Data Structures Used
‚* ====================
*
š* This DS is for Finding first day of the month.
D Date_DS_1 DS
D DS_1_Date D DATFMT(*USA) INZ
D DS_1_MM 2S 0 OVERLAY(DS_1_Date:1)
D DS_1_DD 2S 0 OVERLAY(DS_1_Date:4) inz(1)
D DS_1_YYYY 4S 0 OVERLAY(DS_1_Date:7)
*
š* This DS will hold current date values.
D Date_DS_2 DS
D DS_2_Date D DATFMT(*USA) INZ
D DS_2_MM 2S 0 OVERLAY(DS_2_Date:1) inz(5)
D DS_2_DD 2S 0 OVERLAY(DS_2_Date:4) inz(31)
D DS_2_YYYY 4S 0 OVERLAY(DS_2_Date:7) inz(2003)
‚* Variables Used
‚* ==============
*
D FirstDay S 1 0
D CurrDay S 1 0
D MaxDate S 2 0
D LiveMonth S 2 0
D LiveDate S 2 0
D LiveYear S 4 0
*
D Dates S 2 DIM(37)
D Count S 2 0
D Temp S 2 0
D I S 2 0
D Selected S N Inz(*Off)
D Res S 1
**********************************************************************
‚* M A I N L I N E P R O C E S S I N G *
**********************************************************************
˜* Exfmt the Calendar display till F3 or a date is Selected
C DoW Selected = *Off And *IN03 = *Off
˜* This calculates the date as per the (M+ or M-) and (Y+ or Y-)
˜* Triggered by the user and restores the display.
C Select
C When OptYearM = 1
C Eval DS_2_Date = DS_2_Date - %Years(1)
C MoveA '0010' *In(41)
C When OptMonthM = 1
C Eval DS_2_Date = DS_2_Date - %Months(1)
C MoveA '1000' *In(41)
C When OptMonthP = 1
C Eval DS_2_Date = DS_2_Date + %Months(1)
C MoveA '0100' *In(41)
C When OptYearP = 1
C Eval DS_2_Date = DS_2_Date + %Years(1)
C MoveA '0001' *In(41)
C EndSl
˜* Assigns the current values to the Datastructure one
˜* so that the maximum no of days and first day of the month
˜* is calculated.
C Eval Count = 0
C Eval DS_1_MM = DS_2_MM
C Eval DS_1_YYYY = DS_2_YYYY
˜* This gets the first day of the month
C Eval FirstDay = GetDay(DS_1_Date)
˜* This gets the Current day (Today)
C Eval CurrDay = GetDay(DS_2_Date)
˜* This gets the no of days in the month
C Eval MaxDate = GetDate(DS_1_Date)
˜* This gets the month(Text) of the month so that it can
˜* be displayed on the DSPF
C Eval Month = getMonth(DS_2_MM)
C Move DS_2_YYYY Year
˜* This Subroutine populates the Datastructure for the Current
˜* Selection(Month and Year)
C ExSr InitDates
˜* This Turns the required indicators for display
C ExSr SetIndicators
˜* This assigns the values from the datastructure to the DSPF fields
C ExSr SetValues
˜* Displays the Calendar for the Current month and Year Selection
C ExFmt CALENDAR
˜* If user strikes Enter key apart from F3 then we have to see
˜* whether user has chosed any date.
C If *In03 = *Off
C ExSr CheckSel
C EndIf
C EndDo
C If Selected = *On
C Move Dates(I) DS_2_DD
C DS_2_Date Dsply Res
C EndIf
C Eval *inlr = *on
**********************************************************************
‚* *INZSR ==> Initialize Sub-Routine *
**********************************************************************
C *INZSR BegSr
˜* Current date is retrieved for initial display
C Eval DS_2_Date = %Date()
C Eval LiveMonth = DS_2_MM
C Eval LiveYear = DS_2_YYYY
C Eval LiveDate = DS_2_DD
˜* This frames the string which is displayed at the bottom
C Eval OutPut = %Char(LiveDate) + ' ' +
C %Trim(getMonth(LiveMonth)) + ', ' +
C %Char(LiveYear)
C Eval *In41 = *On
C EndSr
**********************************************************************
‚* InitDates ==> Initialize the Datastructure *
‚* For Eg. consider the date September 2003 *
‚* 1. The month has got 30 days *
‚* 2. First day is Monday *
‚* Hence the DS is populated as follows: *
‚* --> DS(1) = *Blanks *
‚* --> DS(2) = '1' *
‚* --> DS(3) = '2' ..... *
‚* --> DS(32)= '30' *
‚* --> DS(33)= *Blanks ..... *
‚* --> DS(37)= *Blanks *
**********************************************************************
C InitDates BegSr
C Clear Dates
C Eval Temp = MaxDate + FirstDay
C For I = 1 to 37
C Select
C When I <= FirstDay Or I > Temp
C Eval Dates(I) = *BLANKS
C When I > FirstDay And I <= Temp
C Eval Count = Count + 1
C Move Count Dates(I)
C EndSl
C EndFor
C EndSr
**********************************************************************
‚* SetIndicators ==> Turn Reqd. Indicators for display *
**********************************************************************
C SetIndicators BegSr
C For I = 50 to 56
C Eval *In(I) = *Off
C EndFor
C For I = 60 to 96
C Eval *In(I) = *Off
C EndFor
C If LiveMonth = DS_2_MM And
C LiveYear = DS_2_YYYY
C Eval *In(50 + CurrDay) = *On
C Eval *In(60 + LiveDate + FirstDay - 1) = *On
C EndIf
C EndSr
**********************************************************************
‚* SetValues ==> Copies the DS to DSPF fields *
**********************************************************************
C SetValues BegSr
C Move Dates(1) SET1
C Move Dates(2) SET2
C Move Dates(3) SET3
C Move Dates(4) SET4
C Move Dates(5) SET5
C Move Dates(6) SET6
C Move Dates(7) SET7
C Move Dates(8) SET8
C Move Dates(9) SET9
C Move Dates(10) SET10
C Move Dates(11) SET11
C Move Dates(12) SET12
C Move Dates(13) SET13
C Move Dates(14) SET14
C Move Dates(15) SET15
C Move Dates(16) SET16
C Move Dates(17) SET17
C Move Dates(18) SET18
C Move Dates(19) SET19
C Move Dates(20) SET20
C Move Dates(21) SET21
C Move Dates(22) SET22
C Move Dates(23) SET23
C Move Dates(24) SET24
C Move Dates(25) SET25
C Move Dates(26) SET26
C Move Dates(27) SET27
C Move Dates(28) SET28
C Move Dates(29) SET29
C Move Dates(30) SET30
C Move Dates(31) SET31
C Move Dates(32) SET32
C Move Dates(33) SET33
C Move Dates(34) SET34
C Move Dates(35) SET35
C Move Dates(36) SET36
C Move Dates(37) SET37
C EndSr
**********************************************************************
‚* CheckSel ==> Checks whether user has msde any selection *
**********************************************************************
C CheckSel BegSr
C For I = 1 to 37
C If FLD = 'SET'+ %Char(I) and
C Dates(I) <> *Blanks
C Eval Selected = *ON
C Leave
C EndIf
C EndFor
C EndSr
**********************************************************************
‚* GetDay ==> This returns the day of the Date *
‚* The logic implemented is: *
‚* %Rem(((Date) - (Standard Date)) / 7) *
‚* The Standard date will be any Reference *
‚* Day. If the reminder is Zero then the *
‚* current day is standard day. If it is *
‚* '1' then its monday like so... *
**********************************************************************
P GetDay B
D GetDay PI 1 0
D Date D Value
D Days S 15P 0
D Day S 1 0
D Sunday C D'1999-12-19'
C Date SubDur Sunday Days:*DAYS
C Eval Day = %Rem(Days:7)
C If Day < 0
C Eval Day = Day + 7
C EndIf
C Return Day
P E
**********************************************************************
‚* GetDay ==> This returns the no of days in the month *
‚* The logic implemented is: *
‚* Difference between Current date and *
‚* (Current Date + One Month) in No of Days *
**********************************************************************
P GetDate B
D GetDate PI 2 0
D Date D Value
D Date1 S D
C Eval Date1 = Date + %Months(1)
C Return %Diff(Date1:Date:*D)
P E
**********************************************************************
‚* GetMonth ==> This returns the Month in Text for the *
‚* Numeric passed *
**********************************************************************
P GetMonth B
D GetMonth PI 9
D Month 2 0 VALUE
C Select
C When Month = 01
C Return 'January'
C When Month = 02
C Return 'February'
C When Month = 03
C Return 'March'
C When Month = 04
C Return 'April'
C When Month = 05
C Return 'May'
C When Month = 06
C Return 'June'
C When Month = 07
C Return 'July'
C When Month = 08
C Return 'August'
C When Month = 09
C Return 'September'
C When Month = 10
C Return 'October'
C When Month = 11
C Return 'November'
C When Month = 12
C Return 'December'
C Other
C Return ' '
C EndSl
P E
**======================================================
D D S
**======================================================
A*%%TS SD 20030717 173714 USC2643 REL-V5R1M0 5722-WDS
A*%%EC
A DSPSIZ(24 80 *DS3)
A CF03(03 'EXIT')
A MOUBTN(*ULP ENTER)
A R CALENDAR
A*%%TS SD 20030717 173714 USC2643 REL-V5R1M0 5722-WDS
A WINDOW(7 25 14 35)
A RTNCSRLOC(&REC &FLD)
A FLD 10A H
A REC 10A H
A 1 14'Calendar'
A DSPATR(BL)
A DSPATR(HI)
A 2 2'Month. .:'
A COLOR(BLU)
A 3 2'Year. . :'
A COLOR(BLU)
A YEAR 4A O 3 12COLOR(TRQ)
A 5 2'SUN'
A N50 COLOR(YLW)
A 50 COLOR(WHT)
A 5 7'MON'
A N51 COLOR(BLU)
A 51 COLOR(WHT)
A 5 12'TUE'
A N52 COLOR(BLU)
A 52 COLOR(WHT)
A 5 17'WED'
A N53 COLOR(BLU)
A 53 COLOR(WHT)
A 5 22'THU'
A N54 COLOR(BLU)
A 54 COLOR(WHT)
A 5 27'FRI'
A N55 COLOR(BLU)
A 55 COLOR(WHT)
A 5 32'SAT'
A N56 COLOR(YLW)
A 56 COLOR(WHT)
A SET1 2A O 6 3
A N60 COLOR(YLW)
A 60 COLOR(WHT)
A SET2 2A O 6 8
A N61 COLOR(GRN)
A 61 COLOR(WHT)
A SET3 2A O 6 13
A N62 COLOR(GRN)
A 62 COLOR(WHT)
A SET4 2A O 6 18
A N63 COLOR(GRN)
A 63 COLOR(WHT)
A SET5 2A O 6 23
A N64 COLOR(GRN)
A 64 COLOR(WHT)
A SET6 2A O 6 28
A N65 COLOR(GRN)
A 65 COLOR(WHT)
A SET7 2A O 6 33
A N66 COLOR(YLW)
A 66 COLOR(WHT)
A SET8 2A O 7 3
A N67 COLOR(YLW)
A 67 COLOR(WHT)
A SET9 2A O 7 8
A N68 COLOR(GRN)
A 68 COLOR(WHT)
A SET15 2A O 8 3
A N74 COLOR(YLW)
A 74 COLOR(WHT)
A SET16 2A O 8 8
A N75 COLOR(GRN)
A 75 COLOR(WHT)
A SET22 2A O 9 3
A N81 COLOR(YLW)
A 81 COLOR(WHT)
A SET23 2A O 9 8
A N82 COLOR(GRN)
A 82 COLOR(WHT)
A SET29 2A O 10 3
A N88 COLOR(YLW)
A 88 COLOR(WHT)
A SET30 2A O 10 8
A N89 COLOR(GRN)
A 89 COLOR(WHT)
A SET36 2A O 11 3
A N95 COLOR(YLW)
A 95 COLOR(WHT)
A SET37 2A O 11 8
A N96 COLOR(GRN)
A 96 COLOR(WHT)
A SET10 2A O 7 13
A N69 COLOR(GRN)
A 69 COLOR(WHT)
A SET11 2A O 7 18
A N70 COLOR(GRN)
A 70 COLOR(WHT)
A SET12 2A O 7 23
A N71 COLOR(GRN)
A 71 COLOR(WHT)
A SET13 2A O 7 28
A N72 COLOR(GRN)
A 72 COLOR(WHT)
A SET14 2A O 7 33
A N73 COLOR(YLW)
A 73 COLOR(WHT)
A SET17 2A O 8 13
A N76 COLOR(GRN)
A 76 COLOR(WHT)
A SET18 2A O 8 18
A N77 COLOR(GRN)
A 77 COLOR(WHT)
A SET19 2A O 8 23
A N78 COLOR(GRN)
A 78 COLOR(WHT)
A SET20 2A O 8 28
A N79 COLOR(GRN)
A 79 COLOR(WHT)
A SET21 2A O 8 33
A N80 COLOR(YLW)
A 80 COLOR(WHT)
A SET24 2A O 9 13
A N83 COLOR(GRN)
A 83 COLOR(WHT)
A SET25 2A O 9 18
A N84 COLOR(GRN)
A 84 COLOR(WHT)
A SET26 2A O 9 23
A N85 COLOR(GRN)
A 85 COLOR(WHT)
A SET27 2A O 9 28
A N86 COLOR(GRN)
A 86 COLOR(WHT)
A SET28 2A O 9 33
A N87 COLOR(YLW)
A 87 COLOR(WHT)
A SET31 2A O 10 13
A N90 COLOR(GRN)
A 90 COLOR(WHT)
A SET32 2A O 10 18
A N91 COLOR(GRN)
A 91 COLOR(WHT)
A SET33 2A O 10 23
A N92 COLOR(GRN)
A 92 COLOR(WHT)
A SET34 2A O 10 28
A N93 COLOR(GRN)
A 93 COLOR(WHT)
A SET35 2A O 10 33
A N94 COLOR(YLW)
A 94 COLOR(WHT)
A OUTPUT 25A O 13 2COLOR(PNK)
A OPTMONTHM 2Y 0B 2 24PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
A 41 DSPATR(PC)
A PSHBTNCHC(1 '-')
A OPTMONTHP 2Y 0B 2 29PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
A 42 DSPATR(PC)
A PSHBTNCHC(1 '+')
A OPTYEARM 2Y 0B 3 24PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
A 43 DSPATR(PC)
A PSHBTNCHC(1 '-')
A OPTYEARP 2Y 0B 3 29PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
A 44 DSPATR(PC)
A PSHBTNCHC(1 '+')
A 4 1'__________________________________-
A _'
A COLOR(BLU)
A 12 1'__________________________________-
A _'
A COLOR(BLU)
A MONTH 9A O 2 12COLOR(TRQ)
A R DUMMY
A KEEP
A ASSUME
A 1 3' '
| |
RPGLE - Clock Got ti of the FlyByNight Software Website NICE
Posted By: Rakesh Contact |
/************************************************************* +
** +
** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» +
** «» FlyByNight Software AS/400 Technical Specialists «» +
** «» Eclipse the competition - run your business on an IBM AS/400. «» +
** «» «» +
** «» Phone: +61 3 9419 0175 Mobile: +61 0411 091 400 «» +
** «» Fax: +61 3 9419 0175 mailto: shc@flybynight.com.au «» +
** «» «» +
** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» +
** +
** This program started as a copy of Simon's Clock Program ** +
** I appreciate his knowledge and have used it, but if ** +
** anything does not run right, that's me, not him. ** +
** Booth Martin 2/00 booth@Martinvt.com ** +
** ** +
************************************************************* */
DCLF FILE(CLKFIGFM) RCDFMT(*ALL)
/* Display file - digital clock */
DCL VAR(&HR) TYPE(*CHAR) LEN(2)
/* Hour component of the time */
DCL VAR(&MIN) TYPE(*CHAR) LEN(2)
/* Minute component of the time */
DCL VAR(&SEC) TYPE(*CHAR) LEN(2)
/* Second component of the time */
DCL VAR(&DAT6) TYPE(*CHAR) LEN(6)
/* Current Date */
DCL VAR(&DOW) TYPE(*CHAR) LEN(4)
/* Current Day of week */
DCL VAR(&COL1) TYPE(*CHAR) LEN(1)
/* Left component of the hour */
DCL VAR(&COL2) TYPE(*CHAR) LEN(1)
/* Right component of the hour */
DCL VAR(&COL3) TYPE(*CHAR) LEN(1)
/* Left component of the minute */
DCL VAR(&COL4) TYPE(*CHAR) LEN(1)
/* Right component of the minute */
DCL VAR(&COL5) TYPE(*CHAR) LEN(1)
/* Left component of the second */
DCL VAR(&COL6) TYPE(*CHAR) LEN(1)
/* Right component of the second */
DCL VAR(&SYSNAME) TYPE(*CHAR) LEN(8)
RTVNETA SYSNAME(&SYSNAME)
CHGVAR VAR(&TITLE) VALUE(' Official System Time +
for' *BCAT &SYSNAME *CAT ' ')
AGAIN: /* Get the current time */
RTVSYSVAL SYSVAL(QHOUR) RTNVAR(&HR)
RTVSYSVAL SYSVAL(QMINUTE) RTNVAR(&MIN)
RTVSYSVAL SYSVAL(QSECOND) RTNVAR(&SEC)
RTVSYSVAL SYSVAL(QDATE) RTNVAR(&DAT6)
RTVSYSVAL SYSVAL(QDAYOFWEEK) RTNVAR(&DOW)
/* Display fields: Date, Julian date, and day-of-week */
CVTDAT DATE(&DAT6) TOVAR(&JDAY) TOFMT(*JUL) TOSEP(/)
CVTDAT DATE(&DAT6) TOVAR(&DAT) TOFMT(*MDY) TOSEP(/)
IF COND(&DOW = '*SUN') THEN(CHGVAR VAR(&DOWEEK) +
VALUE(' Sunday'))
IF COND(&DOW = '*MON') THEN(CHGVAR VAR(&DOWEEK) +
VALUE(' Monday'))
IF COND(&DOW = '*TUE') THEN(CHGVAR VAR(&DOWEEK) +
VALUE(' Tuesday'))
IF COND(&DOW = '*WED') THEN(CHGVAR VAR(&DOWEEK) +
VALUE('Wednesday'))
IF COND(&DOW = '*THU') THEN(CHGVAR VAR(&DOWEEK) +
VALUE('Thursday'))
IF COND(&DOW = '*FRI') THEN(CHGVAR VAR(&DOWEEK) +
VALUE(' Friday'))
IF COND(&DOW = '*SAT') THEN(CHGVAR VAR(&DOWEEK) +
VALUE('Saturday'))
CHGVAR VAR(&COL1) VALUE(%SST(&HR 1 1))
CHGVAR VAR(&COL2) VALUE(%SST(&HR 2 1))
CHGVAR VAR(&COL3) VALUE(%SST(&MIN 1 1))
CHGVAR VAR(&COL4) VALUE(%SST(&MIN 2 1))
CHGVAR VAR(&COL5) VALUE(%SST(&SEC 1 1))
CHGVAR VAR(&COL6) VALUE(%SST(&SEC 2 1))
/* Set the indicators for the left digit of the hour */
/* -- leading zero is not shown */
IF COND(&COL1 *EQ '1') THEN(CHGVAR VAR(&IN11) +
VALUE('1'))
IF COND(&COL1 *EQ '2') THEN(CHGVAR VAR(&IN12) +
VALUE('1'))
/* Set the indicators for the right digit of the hour */
IF COND(&COL2 *EQ '0') THEN(CHGVAR VAR(&IN20) +
VALUE('1'))
IF COND(&COL2 *EQ '1') THEN(CHGVAR VAR(&IN21) +
VALUE('1'))
IF COND(&COL2 *EQ '2') THEN(CHGVAR VAR(&IN22) +
VALUE('1'))
IF COND(&COL2 *EQ '3') THEN(CHGVAR VAR(&IN23) +
VALUE('1'))
IF COND(&COL2 *EQ '4') THEN(CHGVAR VAR(&IN24) +
VALUE('1'))
IF COND(&COL2 *EQ '5') THEN(CHGVAR VAR(&IN25) +
VALUE('1'))
IF COND(&COL2 *EQ '6') THEN(CHGVAR VAR(&IN26) +
VALUE('1'))
IF COND(&COL2 *EQ '7') THEN(CHGVAR VAR(&IN27) +
VALUE('1'))
IF COND(&COL2 *EQ '8') THEN(CHGVAR VAR(&IN28) +
VALUE('1'))
IF COND(&COL2 *EQ '9') THEN(CHGVAR VAR(&IN29) +
VALUE('1'))
/* Set the indicators for the left digit of the minute */
IF COND(&COL3 *EQ '0') THEN(CHGVAR VAR(&IN30) +
VALUE('1'))
IF COND(&COL3 *EQ '1') THEN(CHGVAR VAR(&IN31) +
VALUE('1'))
IF COND(&COL3 *EQ '2') THEN(CHGVAR VAR(&IN32) +
VALUE('1'))
IF COND(&COL3 *EQ '3') THEN(CHGVAR VAR(&IN33) +
VALUE('1'))
IF COND(&COL3 *EQ '4') THEN(CHGVAR VAR(&IN34) +
VALUE('1'))
IF COND(&COL3 *EQ '5') THEN(CHGVAR VAR(&IN35) +
VALUE('1'))
IF COND(&COL3 *EQ '6') THEN(CHGVAR VAR(&IN36) +
VALUE('1'))
IF COND(&COL3 *EQ '7') THEN(CHGVAR VAR(&IN37) +
VALUE('1'))
IF COND(&COL3 *EQ '8') THEN(CHGVAR VAR(&IN38) +
VALUE('1'))
IF COND(&COL3 *EQ '9') THEN(CHGVAR VAR(&IN39) +
VALUE('1'))
/* Set the indicators for the right digit of the minute */
IF COND(&COL4 *EQ '0') THEN(CHGVAR VAR(&IN40) +
VALUE('1'))
IF COND(&COL4 *EQ '1') THEN(CHGVAR VAR(&IN41) +
VALUE('1'))
IF COND(&COL4 *EQ '2') THEN(CHGVAR VAR(&IN42) +
VALUE('1'))
IF COND(&COL4 *EQ '3') THEN(CHGVAR VAR(&IN43) +
VALUE('1'))
IF COND(&COL4 *EQ '4') THEN(CHGVAR VAR(&IN44) +
VALUE('1'))
IF COND(&COL4 *EQ '5') THEN(CHGVAR VAR(&IN45) +
VALUE('1'))
IF COND(&COL4 *EQ '6') THEN(CHGVAR VAR(&IN46) +
VALUE('1'))
IF COND(&COL4 *EQ '7') THEN(CHGVAR VAR(&IN47) +
VALUE('1'))
IF COND(&COL4 *EQ '8') THEN(CHGVAR VAR(&IN48) +
VALUE('1'))
IF COND(&COL4 *EQ '9') THEN(CHGVAR VAR(&IN49) +
VALUE('1'))
/* Set the indicators for the left digit of the second */
IF COND(&COL5 *EQ '0') THEN(CHGVAR VAR(&IN50) +
VALUE('1'))
IF COND(&COL5 *EQ '1') THEN(CHGVAR VAR(&IN51) +
VALUE('1'))
IF COND(&COL5 *EQ '2') THEN(CHGVAR VAR(&IN52) +
VALUE('1'))
IF COND(&COL5 *EQ '3') THEN(CHGVAR VAR(&IN53) +
VALUE('1'))
IF COND(&COL5 *EQ '4') THEN(CHGVAR VAR(&IN54) +
VALUE('1'))
IF COND(&COL5 *EQ '5') THEN(CHGVAR VAR(&IN55) +
VALUE('1'))
IF COND(&COL5 *EQ '6') THEN(CHGVAR VAR(&IN56) +
VALUE('1'))
IF COND(&COL5 *EQ '7') THEN(CHGVAR VAR(&IN57) +
VALUE('1'))
IF COND(&COL5 *EQ '8') THEN(CHGVAR VAR(&IN58) +
VALUE('1'))
IF COND(&COL5 *EQ '9') THEN(CHGVAR VAR(&IN59) +
VALUE('1'))
/* Set the indicators for the Right digit of the Second */
IF COND(&COL6 *EQ '0') THEN(CHGVAR VAR(&IN60) +
VALUE('1'))
IF COND(&COL6 *EQ '1') THEN(CHGVAR VAR(&IN61) +
VALUE('1'))
IF COND(&COL6 *EQ '2') THEN(CHGVAR VAR(&IN62) +
VALUE('1'))
IF COND(&COL6 *EQ '3') THEN(CHGVAR VAR(&IN63) +
VALUE('1'))
IF COND(&COL6 *EQ '4') THEN(CHGVAR VAR(&IN64) +
VALUE('1'))
IF COND(&COL6 *EQ '5') THEN(CHGVAR VAR(&IN65) +
VALUE('1'))
IF COND(&COL6 *EQ '6') THEN(CHGVAR VAR(&IN66) +
VALUE('1'))
IF COND(&COL6 *EQ '7') THEN(CHGVAR VAR(&IN67) +
VALUE('1'))
IF COND(&COL6 *EQ '8') THEN(CHGVAR VAR(&IN68) +
VALUE('1'))
IF COND(&COL6 *EQ '9') THEN(CHGVAR VAR(&IN69) +
VALUE('1'))
/* Display the clock face */
SNDRCVF RCDFMT(RFIGLET) WAIT(*NO)
MONMSG MSGID(CPF0887) EXEC(DO)
RCVMSG MSGTYPE(*EXCP)
RCVF
IF COND(&PB2 *EQ 01) THEN(WRKMSG MSGQ(*SYSOPR))
IF COND(&PB2 *EQ 02) THEN(GOTO CMDLBL(AGAIN))
IF COND(&PB2 *EQ 03) THEN(GOTO CMDLBL(ENDJOB))
IF COND(&IN03 *EQ '1') THEN(GOTO CMDLBL(ENDJOB))
IF COND(&IN06 *EQ '1') THEN(WRKMSG MSGQ(*SYSOPR))
ENDDO
DLYJOB DLY(1)
CHGVAR VAR(&IN11) VALUE('0')
CHGVAR VAR(&IN12) VALUE('0')
CHGVAR VAR(&IN20) VALUE('0')
CHGVAR VAR(&IN21) VALUE('0')
CHGVAR VAR(&IN22) VALUE('0')
CHGVAR VAR(&IN23) VALUE('0')
CHGVAR VAR(&IN24) VALUE('0')
CHGVAR VAR(&IN25) VALUE('0')
CHGVAR VAR(&IN26) VALUE('0')
CHGVAR VAR(&IN27) VALUE('0')
CHGVAR VAR(&IN28) VALUE('0')
CHGVAR VAR(&IN29) VALUE('0')
CHGVAR VAR(&IN30) VALUE('0')
CHGVAR VAR(&IN31) VALUE('0')
CHGVAR VAR(&IN32) VALUE('0')
CHGVAR VAR(&IN33) VALUE('0')
CHGVAR VAR(&IN34) VALUE('0')
CHGVAR VAR(&IN35) VALUE('0')
CHGVAR VAR(&IN36) VALUE('0')
CHGVAR VAR(&IN37) VALUE('0')
CHGVAR VAR(&IN38) VALUE('0')
CHGVAR VAR(&IN39) VALUE('0')
CHGVAR VAR(&IN40) VALUE('0')
CHGVAR VAR(&IN41) VALUE('0')
CHGVAR VAR(&IN42) VALUE('0')
CHGVAR VAR(&IN43) VALUE('0')
CHGVAR VAR(&IN44) VALUE('0')
CHGVAR VAR(&IN45) VALUE('0')
CHGVAR VAR(&IN46) VALUE('0')
CHGVAR VAR(&IN47) VALUE('0')
CHGVAR VAR(&IN48) VALUE('0')
CHGVAR VAR(&IN49) VALUE('0')
CHGVAR VAR(&IN50) VALUE('0')
CHGVAR VAR(&IN51) VALUE('0')
CHGVAR VAR(&IN52) VALUE('0')
CHGVAR VAR(&IN53) VALUE('0')
CHGVAR VAR(&IN54) VALUE('0')
CHGVAR VAR(&IN55) VALUE('0')
CHGVAR VAR(&IN56) VALUE('0')
CHGVAR VAR(&IN57) VALUE('0')
CHGVAR VAR(&IN58) VALUE('0')
CHGVAR VAR(&IN59) VALUE('0')
CHGVAR VAR(&IN60) VALUE('0')
CHGVAR VAR(&IN61) VALUE('0')
CHGVAR VAR(&IN62) VALUE('0')
CHGVAR VAR(&IN63) VALUE('0')
CHGVAR VAR(&IN64) VALUE('0')
CHGVAR VAR(&IN65) VALUE('0')
CHGVAR VAR(&IN66) VALUE('0')
CHGVAR VAR(&IN67) VALUE('0')
CHGVAR VAR(&IN68) VALUE('0')
CHGVAR VAR(&IN69) VALUE('0')
GOTO CMDLBL(AGAIN)
ENDJOB: ENDPGM
Display FIle
A*************************************************************
A**
A** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»
A** «» FlyByNight Software AS/400 Technical Specialists «»
A** «» Eclipse the competition - run your business on an IBM AS/400. «»
A** «» «»
A** «» Phone: +61 3 9419 0175 Mobile: +61 0411 091 400 «»
A** «» Fax: +61 3 9419 0175 mailto: shc@flybynight.com.au «»
A** «» «»
A** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»
A**
A** This program started as a copy of Simon's Clock Program **
A** I appreciate his knowledge and have used it, but if **
A** anything does not run right, that's me, not him. **
A** Booth Martin 2/00 Booth@MartinVT.com **
A** **
A*************************************************************
A*%%FD - clock -
A*%%EC
A DSPSIZ(24 80 *DS3)
A R RFIGLET
A*%%TS SD 20000223 104532 BOOTH REL-V4R4M0 5769-PW1
A CF03(03 'EXIT')
A CF06(06 'SYSOP Messages')
A CF08(08 'Settings')
A BLINK
A OVERLAY
A WINDOW(2 6 9 65 *NOMSGLIN)
A WDWBORDER((*COLOR WHT))
A WDWTITLE((*TEXT &TITLE))
A 11 2 1' _ '
A 11 3 1' / | '
A 11 4 1' | | '
A 11 5 1' | | '
A 11 6 1' |_| '
A 12 2 1' ____ '
A 12 3 1'|___ \ '
A 12 4 1' __) | '
A 12 5 1' / __/ '
A 12 6 1'|_____| '
A 21 2 10' _ '
A 21 3 10' / | '
A 21 4 10' | | '
A 21 5 10' | | '
A 21 6 10' |_| '
A 22 2 10' ____ '
A 22 3 10'|___ \ '
A 22 4 10' __) | '
A 22 5 10' / __/ '
A 22 6 10'|_____| '
A 23 2 10' _____ '
A 23 3 10'|___ / '
A 23 4 10' |_ \ '
A 23 5 10' ___) | '
A 23 6 10'|____/ '
A 24 2 10' _ _ '
A 24 3 10'| || | '
A 24 4 10'| || |_ '
A 24 5 10'|__ _|'
A 24 6 10' |_| '
A 25 2 10' ____ '
A 25 3 10'| ___| '
A 25 4 10'|___ \ '
A 25 5 10' ___) | '
A 25 6 10'|____/ '
A 26 2 10' __ '
A 26 3 10' / /_ '
A 26 4 10'| _ \ '
A 26 5 10'| (_) | '
A 26 6 10' \___/ '
A 27 2 10' _____ '
A 27 3 10'|___ | '
A 27 4 10' / / '
A 27 5 10' / / '
A 27 6 10' /_/ '
A 28 2 10' ___ '
A 28 3 10' ( _ ) '
A 28 4 10' / _ \ '
A 28 5 10'| (_) | '
A 28 6 10' \___/ '
A 29 2 10' ___ '
A 29 3 10' / _ \ '
A 29 4 10'| (_) | '
A 29 5 10' \__, | '
A 29 6 10' /_/ '
A 20 2 10' ___ '
A 20 3 10' / _ \ '
A 20 4 10'| | | | '
A 20 5 10'| |_| | '
A 20 6 10' \___/ '
A 31 2 25' _ '
A 31 3 25' / | '
A 31 4 25' | | '
A 31 5 25' | | '
A 31 6 25' |_| '
A 32 2 25' ____ '
A 32 3 25'|___ \ '
A 32 4 25' __) | '
A 32 5 25' / __/ '
A 32 6 25'|_____| '
A 33 2 25' _____ '
A 33 3 25'|___ / '
A 33 4 25' |_ \ '
A 33 5 25' ___) | '
A 33 6 25'|____/ '
A 34 2 25' _ _ '
A 34 3 25'| || | '
A 34 4 25'| || |_ '
A 34 5 25'|__ _|'
A 34 6 25' |_| '
A 35 2 25' ____ '
A 35 3 25'| ___| '
A 35 4 25'|___ \ '
A 35 5 25' ___) | '
A 35 6 25'|____/ '
A 36 2 25' __ '
A 36 3 25' / /_ '
A 36 4 25'| _ \ '
A 36 5 25'| (_) | '
A 36 6 25' \___/ '
A 37 2 25' _____ '
A 37 3 25'|___ | '
A 37 4 25' / / '
A 37 5 25' / / '
A 37 6 25' /_/ '
A 38 2 25' ___ '
A 38 3 25' ( _ ) '
A 38 4 25' / _ \ '
A 38 5 25'| (_) | '
A 38 6 25' \___/ '
A 39 2 25' ___ '
A 39 3 25' / _ \ '
A 39 4 25'| (_) | '
A 39 5 25' \__, | '
A 39 6 25' /_/ '
A 30 2 25' ___ '
A 30 3 25' / _ \ '
A 30 4 25'| | | | '
A 30 5 25'| |_| | '
A 30 6 25' \___/ '
A 41 2 34' _ '
A 41 3 34' / | '
A 41 4 34' | | '
A 41 5 34' | | '
A 41 6 34' |_| '
A 42 2 34' ____ '
A 42 3 34'|___ \ '
A 42 4 34' __) | '
A 42 5 34' / __/ '
A 42 6 34'|_____| '
A 43 2 34' _____ '
A 43 3 34'|___ / '
A 43 4 34' |_ \ '
A 43 5 34' ___) | '
A 43 6 34'|____/ '
A 44 2 34' _ _ '
A 44 3 34'| || | '
A 44 4 34'| || |_ '
A 44 5 34'|__ _|'
A 44 6 34' |_| '
A 45 2 34' ____ '
A 45 3 34'| ___| '
A 45 4 34'|___ \ '
A 45 5 34' ___) | '
A 45 6 34'|____/ '
A 46 2 34' __ '
A 46 3 34' / /_ '
A 46 4 34'| _ \ '
A 46 5 34'| (_) | '
A 46 6 34' \___/ '
A 47 2 34' _____ '
A 47 3 34'|___ | '
A 47 4 34' / / '
A 47 5 34' / / '
A 47 6 34' /_/ '
A 48 2 34' ___ '
A 48 3 34' ( _ ) '
A 48 4 34' / _ \ '
A 48 5 34'| (_) | '
A 48 6 34' \___/ '
A 49 2 34' ___ '
A 49 3 34' / _ \ '
A 49 4 34'| (_) | '
A 49 5 34' \__, | '
A 49 6 34' /_/ '
A 40 2 34' ___ '
A 40 3 34' / _ \ '
A 40 4 34'| | | | '
A 40 5 34'| |_| | '
A 40 6 34' \___/ '
A 51 2 49' _ '
A 51 3 49' / | '
A 51 4 49' | | '
A 51 5 49' | | '
A 51 6 49' |_| '
A 52 2 49' ____ '
A 52 3 49'|___ \ '
A 52 4 49' __) | '
A 52 5 49' / __/ '
A 52 6 49'|_____| '
A 53 2 49' _____ '
A 53 3 49'|___ / '
A 53 4 49' |_ \ '
A 53 5 49' ___) | '
A 53 6 49'|____/ '
A 54 2 49' _ _ '
A 54 3 49'| || | '
A 54 4 49'| || |_ '
A 54 5 49'|__ _|'
A 54 6 49' |_| '
A 55 2 49' ____ '
A 55 3 49'| ___| '
A 55 4 49'|___ \ '
A 55 5 49' ___) | '
A 55 6 49'|____/ '
A 56 2 49' __ '
A 56 3 49' / /_ '
A 56 4 49'| _ \ '
A 56 5 49'| (_) | '
A 56 6 49' \___/ '
A 57 2 49' _____ '
A 57 3 49'|___ | '
A 57 4 49' / / '
A 57 5 49' / / '
A 57 6 49' /_/ '
A 58 2 49' ___ '
A 58 3 49' ( _ ) '
A 58 4 49' / _ \ '
A 58 5 49'| (_) | '
A 58 6 49' \___/ '
A 59 2 49' ___ '
A 59 3 49' / _ \ '
A 59 4 49'| (_) | '
A 59 5 49' \__, | '
A 59 6 49' /_/ '
A 50 2 49' ___ '
A 50 3 49' / _ \ '
A 50 4 49'| | | | '
A 50 5 49'| |_| | '
A 50 6 49' \___/ '
A 61 2 58' _ '
A 61 3 58' / | '
A 61 4 58' | | '
A 61 5 58' | | '
A 61 6 58' |_| '
A 62 2 58' ____ '
A 62 3 58'|___ \ '
A 62 4 58' __) | '
A 62 5 58' / __/ '
A 62 6 58'|_____| '
A 63 2 58' _____ '
A 63 3 58'|___ / '
A 63 4 58' |_ \ '
A 63 5 58' ___) | '
A 63 6 58'|____/ '
A 64 2 58' _ _ '
A 64 3 58'| || | '
A 64 4 58'| || |_ '
A 64 5 58'|__ _|'
A 64 6 58' |_| '
A 65 2 58' ____ '
A 65 3 58'| ___| '
A 65 4 58'|___ \ '
A 65 5 58' ___) | '
A 65 6 58'|____/ '
A 66 2 58' __ '
A 66 3 58' / /_ '
A 66 4 58'| _ \ '
A 66 5 58'| (_) | '
A 66 6 58' \___/ '
A 67 2 58' _____ '
A 67 3 58'|___ | '
A 67 4 58' / / '
A 67 5 58' / / '
A 67 6 58' /_/ '
A 68 2 58' ___ '
A 68 3 58' ( _ ) '
A 68 4 58' / _ \ '
A 68 5 58'| (_) | '
A 68 6 58' \___/ '
A 69 2 58' ___ '
A 69 3 58' / _ \ '
A 69 4 58'| (_) | '
A 69 5 58' \__, | '
A 69 6 58' /_/ '
A 60 2 58' ___ '
A 60 3 58' / _ \ '
A 60 4 58'| | | | '
A 60 5 58'| |_| | '
A 60 6 58' \___/ '
A 3 20' _ '
A 4 20'(_)'
A 5 20' _ '
A 6 20'(_)'
A 3 44' _ '
A 4 44'(_)'
A 5 44' _ '
A 6 44'(_)'
A TITLE 50 P
A PB2 2Y 0B 9 1PSHBTNFLD((*GUTTER 1))
A PSHBTNCHC(1 'M>essages' CF06)
A PSHBTNCHC(2 'S>ettings' CF08)
A PSHBTNCHC(3 'E>xit' CF03)
A DOWEEK 9A O 8 56COLOR(WHT)
A DAT 8A O 9 57COLOR(WHT)
A 8 49'Day:'
A JDAY 6A O 9 49COLOR(WHT)
| |
RPGLE - Convert spooled file to HTML. cmd
Posted By: Rakesh Contact |
F* OBJECT NAME....: CVTSPLHTMR */
F* DESCRIPTION....: Convert spooled file to HTML. */
F* RELEASE........: V4R2 */
F* COMPILE NOTES..: 1) Execute the following prior to compile: */
F* CRTPF FILE(QTEMP/FILEIN) + */
F* RCDLEN(202) SIZE(*NOMAX) */
F* CRTPF FILE(QTEMP/FILEOUT) + */
F* RCDLEN(1024) SIZE(*NOMAX) */
F* */
F* DATE WRITTEN...: 02/08/2001 */
F* AUTHOR.........: copy from ibm site */
F*************************************************************************/
F*
F*----------------------------------------------------------------
F* FILE DEFINITION
F*----------------------------------------------------------------
F*
FFILEIN IF F 202 DISK
FFILEOUT O F 1024 DISK A
E*
E*----------------------------------------------------------------
E* Tables/Arrays:
E*----------------------------------------------------------------
E*
E* String in (spooled file record).
E STI 202 1
E* String out (HTML).
E STO 1024 1
E*
E* HTML header usage.
E HTH 1 10 80
E*
E* HTML detail usage.
E HTD 1 4 80
E*
E* HTML footer usage
E HTF 1 3 80
I*
I*----------------------------------------------------------------
I* Named constants.
I*----------------------------------------------------------------
I*
I '0123456789' C KDIGTS
I '!@#' C KFROM
I '<>&' C KTO
I*
I*----------------------------------------------------------------
I* FILES
I*----------------------------------------------------------------
I*
IFILEIN NS 01
I 1 3 INSKPB
I 4 4 INSPCB
I 5 202 INDATA
C*
C*----------------------------------------------------------------
C* Main
C*----------------------------------------------------------------
C*
C EXSR INZ001
C EXSR HTHEAD
C EXSR HTDETL
C EXSR HTFOOT
C EXSR EXIT
C*
C*----------------------------------------------------------------
C* Initialize.
C*----------------------------------------------------------------
C INZ001 BEGSR
C*
C *ENTRY PLIST
C PARM P1LPP 3
C*
C* If LPP is not numeric, set default.
C KDIGTS CHECKP1LPP X
C X IFNE *ZEROS
C Z-ADD068 LPP 30
C ELSE
C MOVE P1LPP LPP
C ENDIF
C*
C* Initialize counters.
C Z-ADD*ZEROS WKLPP 30
C Z-ADD0 LADD 30
C Z-ADD0 LCNT 30
C Z-ADD0 LSKPB 30
C Z-ADD0 LSPCB 30
C*
C ENDSR
C*
C*----------------------------------------------------------------
C* Write HTML header records.
C*----------------------------------------------------------------
C HTHEAD BEGSR
C*
C DO 10 X 40
C MOVEAHTH,X WK80 80 P
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 OODTA1 P
C MOVE *BLANKS OODTA2 P
C MOVE *BLANKS OODTA3 P
C MOVE *BLANKS OODTA4 P
C EXCPTOUTDTA
C ENDDO
C*
C ENDSR
C*
C*----------------------------------------------------------------
C* Write HTML detail records.
C*----------------------------------------------------------------
C HTDETL BEGSR
C*
C DO *HIVAL
C*
C READ FILEIN 90
C*
C *IN90 IFEQ *ON
C LEAVE
C ENDIF
C*
C* Convert Skip-Before from alpha to numeric.
C INSKPB IFNE *BLANKS
C MOVE INSKPB LSKPB
C ELSE
C MOVE *ZEROS LSKPB
C ENDIF
C*
C* Convert Space-Before from alpha to numberic.
C INSPCB IFNE *BLANKS
C MOVE INSPCB LSPCB
C ELSE
C MOVE *ZEROS LSPCB
C ENDIF
C*
C* Skip before handling within current page.
C LSKPB IFNE *ZEROS
C LCNT ANDGT*ZEROS
C LCNT ANDLTLSKPB
C LSKPB SUB LCNT LADD
C SUB 1 LADD
C EXSR HTDET1 Add blank lines
C ELSE
C* :
C* Skip before handling to fill prior page & then start new page.
C LSKPB IFNE *ZEROS
C LCNT ANDGT*ZEROS
C LCNT ANDGTLSKPB
C LCNT ANDLELPP
C LPP SUB LCNT LADD
C EXSR HTDET1 Add blank lines
C Z-ADD*ZEROS LCNT
C LSKPB SUB 1 LADD
C EXSR HTDET1 Add blank lines
C ELSE
C* : :
C* Skip before handling to fill prior page & then start new page.
C LSKPB IFNE *ZEROS
C LCNT ANDGT*ZEROS
C LCNT ANDGTLSKPB
C LCNT ANDGTLPP
C*
C Z-ADDLPP WKLPP
C DO *HIVAL
C ADD LPP WKLPP
C WKLPP IFGE LCNT
C LEAVE
C ENDIF
C ENDDO
C*
C WKLPP SUB LCNT LADD
C EXSR HTDET1 Add blank lines
C Z-ADD*ZEROS LCNT
C LSKPB SUB 1 LADD
C EXSR HTDET1 Add blank lines
C ELSE
C* : : :
C* Skip before handling for new page.
C LSKPB IFNE *ZEROS
C LCNT ANDEQ*ZEROS
C LSKPB SUB 1 LADD
C EXSR HTDET1 Add blank lines
C ELSE
C* : : : :
C* Space before handling.
C LSPCB IFNE *ZEROS
C LSPCB ANDGT1
C LSPCB SUB 1 LADD
C EXSR HTDET1 Add blank lines
C ENDIF
C ENDIF
C ENDIF
C ENDIF
C ENDIF
C*
C* Convert non-blank lines
*
* Determine last non-blank character.
C ' ' CHEKRINDATA ENDPOS 30
C ENDPOS IFEQ *ZEROS
C Z-ADD200 ENDPOS
C ENDIF
*
* Convert characters in string/record.
C MOVEAINDATA STI
C MOVEA*BLANKS STO
C Z-ADD1 I 40
C Z-ADD1 O 40
*
C DO *HIVAL
*
* Leave if over max array size.
C I IFGT 200
C O ORGT 1024
C LEAVE
C ENDIF
*
* Set beginning of string.
C I IFEQ 1
C MOVEAHTD,2 WK80
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 LINF1B 6
C MOVEALINF1B STO,O
C ADD 6 O
C ENDIF
*
* If at end of string, set line feed and get out.
C I IFGT ENDPOS
C MOVEAHTD,3 WK80
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 LINF1E 5
C MOVEALINF1E STO,O
C ADD 7 O
C LEAVE
C ENDIF
*
* Skip if not in column range (ultimately pass parm)
C I IFLT 1
C I ORGT 200
C ITER
C ENDIF
*
* Convert spaces to hidden characters.
* (This eliminates the line wrap and makes things
* more difficult(tedious) for someone to manually
* copy/change the HTML code)
C STI,I IFEQ ' '
C MOVEAHTD,1 WK80
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 LINSPC 6
C MOVEALINSPC STO,O
C ADD 6 O
C ELSE
C MOVEASTI,I STO,O
C ADD 1 O
C ENDIF
C*
C ADD 1 I
C*
C ENDDO
C*
C* Skip duplicate lines when used for bold purposes.
C MOVEASTO,1 NWDTA1256 P
C MOVEASTO,257 NWDTA2256 P
C MOVEASTO,513 NWDTA3256 P
C MOVEASTO,769 NWDTA4256 P
C LSPCB IFEQ *ZEROS
C LSKPB ANDEQ*ZEROS
C NWDTA1 ANDEQOODTA1
C NWDTA2 ANDEQOODTA2
C NWDTA3 ANDEQOODTA3
C NWDTA4 ANDEQOODTA4
C ITER
C ENDIF
C*
C* Write non-blanks lines.
C MOVEASTO,1 OODTA1256 P
C MOVEASTO,257 OODTA2256 P
C MOVEASTO,513 OODTA3256 P
C MOVEASTO,769 OODTA4256 P
C EXCPTOUTDTA
C ADD 1 LCNT
C*
C* Reset line counter for page (if last line was just output)
C LCNT IFEQ LPP
C Z-ADD*ZEROS LCNT
C ENDIF
C*
C ENDDO
C*
C* LR time filling of last page.
C LCNT IFGT *ZEROS
C LPP SUB LCNT LADD
C EXSR HTDET1 Add blank lines
C ENDIF
C*
C ENDSR
C*
C*----------------------------------------------------------------
C* SR to add blank lines.
C*----------------------------------------------------------------
C HTDET1 BEGSR
C*
C LADD IFGT *ZERO
C DO LADD
C MOVEAHTD,4 WK80
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 LINF2B 4
C EXCPTOUTBLK
C ADD 1 LCNT
C ENDDO
C ENDIF
C*
C ENDSR
C*
C*----------------------------------------------------------------
C* Write HTML footer records.
C*----------------------------------------------------------------
C HTFOOT BEGSR
C*
C DO 3 X 40
C MOVEAHTF,X WK80 P
C KFROM:KTO XLATEWK80 WK80
C MOVELWK80 OODTA1 P
C MOVE *BLANKS OODTA2 P
C MOVE *BLANKS OODTA3 P
C MOVE *BLANKS OODTA4 P
C EXCPTOUTDTA
C ENDDO
C*
C ENDSR
C*
C*----------------------------------------------------------------
C* Exit subroutine.
C*----------------------------------------------------------------
C EXIT BEGSR
C*
C MOVE *ON *INLR
C RETRN
C*
C ENDSR
C*----------------------------------------------------------------
C* OUTPUT SPECS:
C*----------------------------------------------------------------
OFILEOUT EADD OUTBLK
O LINF2B 4
O EADD OUTDTA
O OODTA1 256
O OODTA2 512
O OODTA3 768
O OODTA4 1024
** HTH - HTML standard header usage
!HTML@
!HEAD@
!TITLE@Report created by CVTSPLHTM (Convert AS/400 Spooled File to HTML)!/TITLE@
!META NAME="Generator" CONTENT="CVTSPLHTM (Convert AS/400 Spooled File to HTML)"@
!META NAME="Author"CONTENT="CVTSPLHTM (Convert AS/400 Spooled File to HTML)"@
!style@
P {font-family:Courier New; font-weight:500; font-size:8.0 pt}
!/style@
!/HEAD@
!P@
** HTD - HTML detail usage
#nbsp;
!NOBR@
!/BR@
!BR@
** HTF - HTML standard footer usage
!/FONT@
!/BODY@
!/HTML@
=============================CMD=========================================
CMD PROMPT('CONVERT SPOOLED FILE TO HTML')
PARM KWD(FILE) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('SPOOLED FILE')
PARM KWD(DESTFIL) TYPE(*CHAR) LEN(8) +
MIN(1) ALWUNPRT(*NO) +
EXPR(*YES) PROMPT('DESTINATION FILE')
PARM KWD(DESTFLR) TYPE(*CHAR) LEN(80) +
DFT('HTML/REPORTS') EXPR(*YES) +
PROMPT('DESTINATION FOLDER')
PARM KWD(JOB) TYPE(QJOB) DFT(*) SNGVAL((*)) +
PROMPT('JOB NAME')
PARM KWD(SPLNBR) TYPE(*DEC) LEN(4) DFT(*LAST) +
RANGE(-1 9999) SPCVAL((*ONLY 0) (*LAST +
-1)) PROMPT('SPOOLED FILE NUMBER')
PDESTFLR: PMTCTL CTL(DESTFLR) COND((*EQ *RETRIEVE))
QJOB: QUAL TYPE(*NAME) LEN(10)
QUAL TYPE(*NAME) LEN(10) PROMPT('USER')
QUAL TYPE(*CHAR) LEN(6) RANGE('000000' '999999') +
PROMPT('NUMBER')
==============================CL Program=================================
/* OBJECT NAME....: CVTSPLHTMC */
/* DESCRIPTION....: Convert spooled file to HTML. */
/* RELEASE........: V4R2 */
/* COMPILE NOTES..: 1) Execute the following prior to compile: */
/* CRTPF FILE(QTEMP/CVTSPLHTMZ) RCDLEN(133) + */
/* MBR(*FILE) OPTION(*NOSOURCE) SIZE(*NOMAX) */
/* AUTHOR.........: Copy from IBM Site Eric Nepsund */
/*********************************************************************/
PGM PARM(&SPLFNAME &DESTFIL &DESTFLR &PMQUALJOB +
&SPLNBR)
/* Input variables */
DCL VAR(&SPLFNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&DESTFIL) TYPE(*CHAR) LEN(8)
DCL VAR(&DESTFLR) TYPE(*CHAR) LEN(80)
DCL VAR(&PMQUALJOB) TYPE(*CHAR) LEN(26)
DCL VAR(&SPLNBR) TYPE(*DEC) LEN(4)
/* Input variables (Qualified names) */
DCL VAR(&PMJBNM) TYPE(*CHAR) LEN(10)
DCL VAR(&PMUSNM) TYPE(*CHAR) LEN(10)
DCL VAR(&PMJBNO) TYPE(*CHAR) LEN(6)
/* Program variables */
DCL VAR(&PAGLEN) TYPE(*CHAR) LEN(3)
DCL VAR(&SPLNBRA) TYPE(*CHAR) LEN(4)
DCL VAR(&DESTFIL1) TYPE(*CHAR) LEN(12)
/* Program variables for default spool file number & page length */
DCL VAR(&PAGLENOVR) TYPE(*CHAR) LEN(3)
DCL VAR(&SPLNBROVR) TYPE(*CHAR) LEN(4)
DCL VAR(&SPLNMBGET) TYPE(*CHAR) LEN(5)
DCL VAR(&SPLRECTYP) TYPE(*CHAR) LEN(21)
/* Program variables for creating folder(s) to store HTML documents */
DCL VAR(&NWFLRFRM) TYPE(*DEC) LEN(3) VALUE(001)
DCL VAR(&NWFLRTO) TYPE(*DEC) LEN(3) VALUE(000)
DCL VAR(&NWFLRLEN) TYPE(*DEC) LEN(3) VALUE(000)
DCL VAR(&INFLRLEN) TYPE(*DEC) LEN(3) VALUE(1)
DCL VAR(&INFLRLEN) TYPE(*DEC) LEN(3) VALUE(1)
DCL VAR(&INFLR) TYPE(*CHAR) LEN(63)
DCL VAR(&NWFLR) TYPE(*CHAR) LEN(12)
DCL VAR(&FLRCNT) TYPE(*DEC) LEN(3) VALUE(000)
DCL VAR(&SCNSTR) TYPE(*CHAR) LEN(80)
DCL VAR(&SCNSTRLEN) TYPE(*DEC) LEN(3) VALUE(80)
DCL VAR(&SCNBEGPOS) TYPE(*DEC) LEN(3)
DCL VAR(&SCNPAT) TYPE(*CHAR) LEN(1)
DCL VAR(&SCNPATLEN) TYPE(*DEC) LEN(3)
DCL VAR(&SCNXLT) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&SCNTRM) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&SCNWLDCRD) TYPE(*CHAR) LEN(1) VALUE(' ')
DCL VAR(&SCNRTNVAL) TYPE(*DEC) LEN(3)
/* Standard variables. */
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(200)
DCL VAR(&MSGERR) TYPE(*LGL) LEN(1) VALUE('0')
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
/* Files */
DCLF FILE(CVTSPLHTMZ)
/*********************************************************************/
/* Standard logic */
/*********************************************************************/
/* Global message monitor. */
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(MSGSTART))
MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))
/* Global message monitor. */
CHGVAR VAR(&PMJBNM) VALUE(%SST(&PMQUALJOB 1 10))
CHGVAR VAR(&PMUSNM) VALUE(%SST(&PMQUALJOB 11 10))
CHGVAR VAR(&PMJBNO) VALUE(%SST(&PMQUALJOB 21 6))
/*********************************************************************/
/* Main logic. */
/*********************************************************************/
/* Delete temporary files, if they exist */
DLTF FILE(QTEMP/CVTSPLHTMX)
MONMSG MSGID(CPF0000)
DLTF FILE(QTEMP/CVTSPLHTMY)
MONMSG MSGID(CPF0000)
DLTF FILE(QTEMP/CVTSPLHTMZ)
MONMSG MSGID(CPF0000)
/* Retrieve job defaults. */
IF COND(&PMQUALJOB *EQ '*') THEN(DO)
RTVJOBA JOB(&PMJBNM) USER(&PMUSNM) NBR(&PMJBNO)
ENDDO
/* Set defaults for page length & spooled file number */
CHGVAR VAR(&PAGLEN) VALUE('068') /* Default */
CHGVAR VAR(&SPLNBRA) VALUE(&SPLNBR)
/* Retrieve default spooled file number for *LAST & *FIRST special */
/* values, and also the actual page length of the spooled file. */
CHGVAR VAR(&PAGLENOVR) VALUE(' ')
CHGVAR VAR(&SPLNBROVR) VALUE(' ')
CHGVAR VAR(&SPLNMBGET) VALUE(' ')
IF COND(&SPLNBR *EQ -1) THEN(DO)
CHGVAR VAR(&SPLNMBGET) VALUE('*LAST')
ENDDO
IF COND(&SPLNBR *EQ 0) THEN(DO)
CHGVAR VAR(&SPLNMBGET) VALUE('*ONLY')
ENDDO
IF COND(&SPLNMBGET *EQ ' ') THEN(DO)
CHGVAR VAR(&SPLNMBGET) VALUE(&SPLNBR)
ENDDO
CRTPF FILE(QTEMP/CVTSPLHTMZ) RCDLEN(133) +
MBR(*FILE) OPTION(*NOSOURCE) SIZE(*NOMAX)
OVRPRTF FILE(QPRTSPLQ) PRTTXT(*BLANK) HOLD(*YES) +
USRDTA(@TEMP@)
WRKSPLFA FILE(&SPLFNAME) JOB(&PMJBNO/&PMUSNM/&PMJBNM) +
SPLNBR(&SPLNMBGET) OUTPUT(*PRINT)
DLTOVR FILE(QPRTSPLQ)
CPYSPLF FILE(QPDSPSFA) TOFILE(CVTSPLHTMZ) +
SPLNBR(*LAST) MBROPT(*REPLACE) +
CTLCHAR(*FCFC)
DLTSPLF FILE(QPDSPSFA) SPLNBR(*LAST)
READLP: RCVF RCDFMT(CVTSPLHTMZ)
MONMSG CPF0864 EXEC(GOTO READLPX)
/* Retrieve spooled file number */
CHGVAR VAR(&SPLRECTYP) VALUE(%SST(&CVTSPLHTMZ 46 21))
IF COND(&SPLRECTYP *EQ 'Number . . . . . . :') THEN(DO)
IF COND(&SPLNMBGET *EQ '*LAST' *OR +
&SPLNMBGET *EQ '*ONLY') THEN(DO)
CHGVAR VAR(&SPLNBROVR) VALUE(%SST(&CVTSPLHTMZ 72 4))
IF COND((%SST(&SPLNBROVR 4 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&SPLNBROVR) VALUE(%SST(&SPLNBROVR 1 4))
GOTO CMDLBL(READLP)
ENDDO
IF COND((%SST(&SPLNBROVR 3 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&SPLNBROVR) VALUE('0' *CAT %SST(&SPLNBROVR 1 3))
GOTO CMDLBL(READLP)
ENDDO
IF COND((%SST(&SPLNBROVR 2 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&SPLNBROVR) +
VALUE('00' *CAT %SST(&SPLNBROVR 1 2))
GOTO CMDLBL(READLP)
ENDDO
IF COND((%SST(&SPLNBROVR 1 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&SPLNBROVR) +
VALUE('000' *CAT %SST(&SPLNBROVR 1 1))
GOTO CMDLBL(READLP)
ENDDO
ENDDO
IF COND((%SST(&SPLNBROVR 1 4)) *EQ ' ') THEN(DO)
CHGVAR VAR(&SPLNBROVR) VALUE('0000')
GOTO CMDLBL(READLP)
ENDDO
ENDDO
ENDDO
/* Retrieve page length */
CHGVAR VAR(&SPLRECTYP) VALUE(%SST(&CVTSPLHTMZ 4 21))
IF COND(&SPLRECTYP *EQ ' Length . . . . . . .') THEN(DO)
CHGVAR VAR(&PAGLENOVR) VALUE(%SST(&CVTSPLHTMZ 48 3))
IF COND((%SST(&PAGLENOVR 3 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&PAGLENOVR) VALUE(%SST(&PAGLENOVR 1 3))
GOTO CMDLBL(READLPX)
ENDDO
IF COND((%SST(&PAGLENOVR 2 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&PAGLENOVR) VALUE('0' *CAT %SST(&PAGLENOVR 1 2))
GOTO CMDLBL(READLPX)
ENDDO
IF COND((%SST(&PAGLENOVR 1 1)) *NE ' ') THEN(DO)
CHGVAR VAR(&PAGLENOVR) VALUE('00' *CAT %SST(&PAGLENOVR 1 1))
GOTO CMDLBL(READLPX)
ENDDO
IF COND((%SST(&PAGLENOVR 1 3)) *EQ ' ') THEN(DO)
CHGVAR VAR(&PAGLENOVR) VALUE('000')
GOTO CMDLBL(READLPX)
ENDDO
GOTO CMDLBL(READLPX)
ENDDO
GOTO CMDLBL(READLP)
READLPX: IF COND(&SPLNBROVR *GE '0001' +
*AND &SPLNBROVR *LE '9999') THEN(DO)
CHGVAR VAR(&SPLNBR) VALUE(&SPLNBROVR)
CHGVAR VAR(&SPLNBRA) VALUE(&SPLNBROVR)
ENDDO
IF COND(&PAGLENOVR *GE '001' +
*AND &PAGLENOVR *LE '999') THEN(DO)
CHGVAR VAR(&PAGLEN) VALUE(&PAGLENOVR)
ENDDO
/* Convert to HTML format in physical file */
CRTPF FILE(QTEMP/CVTSPLHTMX) RCDLEN(202) SIZE(*NOMAX)
CRTPF FILE(QTEMP/CVTSPLHTMY) RCDLEN(1024) SIZE(*NOMAX)
CPYSPLF FILE(&SPLFNAME) TOFILE(QTEMP/CVTSPLHTMX) +
JOB(&PMJBNO/&PMUSNM/&PMJBNM) +
SPLNBR(&SPLNBR) MBROPT(*ADD) CTLCHAR(*PRTCTL)
OVRDBF FILE(FILEIN) TOFILE(QTEMP/CVTSPLHTMX) MBR(*FIRST)
OVRDBF FILE(FILEOUT) TOFILE(QTEMP/CVTSPLHTMY) MBR(*FIRST)
CALL PGM(*LIBL/CVTSPLHTMR) PARM(&PAGLEN)
DLTOVR FILE(FILEIN)
DLTOVR FILE(FILEOUT)
/* Create QDLS folder(s) if they do not exist */
CHGVAR VAR(&SCNSTR) VALUE(&DESTFLR)
CHGVAR VAR(&SCNPAT) VALUE('/')
CHGVAR VAR(&SCNPATLEN) VALUE(001)
CHGVAR VAR(&SCNBEGPOS) VALUE(001)
IF COND(&SCNSTR *NE ' ') THEN(DO)
FLDRLP: CALL QCLSCAN PARM(&SCNSTR &SCNSTRLEN &SCNBEGPOS &SCNPAT +
&SCNPATLEN &SCNXLT &SCNTRM &SCNWLDCRD &SCNRTNVAL)
/* 2 or more folders */
IF COND(&SCNRTNVAL *GT 0) THEN(DO)
CHGVAR VAR(&FLRCNT) VALUE(&FLRCNT + 1)
CHGVAR VAR(&NWFLRFRM) VALUE(&SCNBEGPOS)
CHGVAR VAR(&NWFLRTO) VALUE(&SCNRTNVAL -1)
CHGVAR VAR(&NWFLRLEN) VALUE(&NWFLRTO - &NWFLRFRM +1)
CHGVAR VAR(&NWFLR) VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))
IF COND(&NWFLRFRM *EQ 1) THEN(DO)
CHGVAR VAR(&INFLR) VALUE('*NONE')
ENDDO
IF COND(&NWFLRFRM *GT 1) THEN(DO)
CHGVAR VAR(&INFLRLEN) VALUE(&NWFLRFRM -2)
CHGVAR VAR(&INFLR) VALUE(%SST(&SCNSTR 1 &INFLRLEN))
ENDDO
CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +
CVTSPLHTM command')
MONMSG MSGID(CPF0000)
MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))
CHGVAR VAR(&SCNBEGPOS) VALUE(&SCNRTNVAL +1)
GOTO CMDLBL(FLDRLP)
ENDDO
/* Only 1 folder */
IF COND(&FLRCNT *LE 0) THEN(DO)
CHGVAR VAR(&NWFLRFRM) VALUE(&SCNBEGPOS)
CHGVAR VAR(&NWFLRFRM) VALUE(&SCNBEGPOS)
CHGVAR VAR(&NWFLRTO) VALUE(&SCNBEGPOS + 12)
CHGVAR VAR(&NWFLRLEN) VALUE(12)
CHGVAR VAR(&NWFLR) VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))
CHGVAR VAR(&INFLR) VALUE('*NONE')
CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +
CVTSPLHTM command')
MONMSG MSGID(CPF0000)
MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))
ENDDO
/* Pickup last folder, if 2 or more folders */
IF COND(&FLRCNT *GE 1) THEN(DO)
CHGVAR VAR(&NWFLRFRM) VALUE(&SCNBEGPOS)
CHGVAR VAR(&NWFLRTO) VALUE(&SCNBEGPOS + 12)
CHGVAR VAR(&NWFLRLEN) VALUE(12)
CHGVAR VAR(&NWFLR) VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))
IF COND(&NWFLRFRM *GT 1) THEN(DO)
CHGVAR VAR(&INFLRLEN) VALUE(&NWFLRFRM -2)
CHGVAR VAR(&INFLR) VALUE(%SST(&SCNSTR 1 &INFLRLEN))
ENDDO
CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +
CVTSPLHTM command')
MONMSG MSGID(CPF0000)
MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))
ENDDO
ENDDO
/* Move HTML document into folder */
CHGVAR VAR(&DESTFIL1) VALUE(&DESTFIL *TCAT '.htm')
CPYTOPCD FROMFILE(*LIBL/CVTSPLHTMY) TOFLR(&DESTFLR) +
FROMMBR(*FIRST) TODOC(&DESTFIL1) +
REPLACE(*YES)
DLTF FILE(QTEMP/CVTSPLHTMX)
DLTF FILE(QTEMP/CVTSPLHTMY)
/* Return. */
/*********************************************************************/
/*Standard message handling routine. */
/*********************************************************************/
MSGSTART: IF COND(&MSGERR *EQ '1') THEN(SNDPGMMSG +
MSGID(CPF9999) MSGF(QCPFMSG) +
MSGTYPE(*ESCAPE))
CHGVAR VAR(&MSGERR) VALUE('1')
/*Move the diagnostic messages up to the next level.*/
MSGDIAG: RCVMSG MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)
IF COND(&MSGID *EQ ' ') THEN(GOTO +
CMDLBL(MSGCOMP))
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
GOTO CMDLBL(MSGDIAG)
/* Move the completion messages up to the next level.*/
MSGCOMP: RCVMSG MSGTYPE(*COMP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)
IF COND(&MSGID *EQ ' ') THEN(GOTO +
CMDLBL(MSGESC))
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*COMP)
GOTO CMDLBL(MSGCOMP)
/* Re-send the last escape message (if there is one).*/
MSGESC: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)
IF COND(&MSGID *EQ ' ') THEN(RETURN)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MSGSTART1: CHGVAR VAR(&MSGDTA) VALUE('** Not Authorized to +
Access Floder ' *CAT &NWFLR)
CHGVAR VAR(&MSGDTA) VALUE(&MSGDTA *TCAT ' Please Gain +
Access to folder from your System Admin and try Command Again. **')
/*SNDMSG MSG(&MSGDTA) TOUSR(&PMUSNM)*/
SNDPGMMSG MSGID(CPF9898) MSGF(*LIBL/QCPFMSG) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
ENDPGM
| |
RPGLE - Data Structure Array
Posted By: chris hayden Contact |
D Ds Inz
D errorArray 129 Dim(9999)
D err_polnbr 9a Overlay(errorArray)
D err_lname 25a Overlay(errorArray:*Next)
D err_efdate Overlay(errorArray:*Next)
D Like(cadmpedt)
D err_vehyear Overlay(errorArray:*Next)
D Like(cadmvehyr)
D err_vehmake Overlay(errorArray:*Next)
D Like(cadmvehmk)
D err_insvin Overlay(errorArray:*Next)
D Like(cadmivin)
D err_trntyp Overlay(errorArray:*Next)
D Like(cadmpcde)
D err_field1 10a overlay(errorArray:*Next)
D err_field2 10a overlay(errorArray:*Next)
D err_field3 20a overlay(errorArray:*Next)
C* load the array with the database fields
C Eval err_polnbr(X) = cadmpoln
C Eval err_lname(X) = cadmilnam
C Movel cadmpedt err_efdate(x)
C Eval err_vehyear(X) = cadmvehyr
C Eval err_vehmake(X) = cadmvehmk
C Eval err_insvin(X) = cadmivin
C Eval err_trntyp(X) = cadmpcde
C Eval err_field2(X) = Cadmtrer
C* print the array
P $PrtRecords B
D $PrtRecords PI
C Sorta errorArray
C Eval X = 1
C For z = 1 to %Elem(errorArray)
C If err_polnbr(X) <> *Blanks
C Eval R@POLNR = err_polnbr(X)
C Eval R@LNAME = err_lname(X)
C Eval R@EFDATE = err_efdate(X)
C Eval R@VEHYEAR = err_vehyear(X)
C Eval R@VEHMAKE = err_vehmake(X)
C Eval R@INSVIN = err_insvin(X)
C Eval R@TRNTYP = err_trntyp(X)
C Eval R@FIELD1 = err_field1(X)
C Eval R@FIELD2 = err_field2(X)
C Eval R@FIELD3 = err_field3(X)
C Callp $OverFlow
C Eval TotCount = TotCount + 1
C write DETAIL
C Endif
C Eval X = X + 1
C Endfor
C Callp $OverFlow
C write Totals
C write EndReport
P $PrtRecords E
| |
RPGLE - PRTF Utility.
Posted By: asrpg400 Contact |
PRTF Utility. This program reads a printer file
DDS source member, creates a RPG IV source member to print the
DDS, compiles and executes the RPG program. This is useful for
documenting external printer files and producing
prototypes during the development phase.
*************************************************************************
Place PRTF Object in a library and mention it in Call.
CALL PGM(LIBRARY/XPRTTST1) PARM(PRTF OBJECT NAME)
*************************************************************************
PGM PARM(&MBR)
DCL VAR(&MBR) TYPE(*CHAR) LEN(10)
/* CHECK WHETHER OBJECT IS AVALIABLE OR NOT */
CHKOBJ OBJ(QTEMP/QRPGLESRC) OBJTYPE(*FILE) MBR(PRTSAMPLE)
MONMSG CPF9801 EXEC(DO) /* FILE NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
/* IF OBJECT NOT FOUND THEN CREATE OBJECT */
CRTSRCPF FILE(QTEMP/QRPGLESRC) RCDLEN(112) MBR(*NONE) +
MAXMBRS(*NOMAX) SIZE(*NOMAX) AUT(*ALL)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* ADDING MEMBER TO SOURCE PF */
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(SAMPLE) +
SRCTYPE(RPGLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
ENDDO
/* ADDING MEMBER TO SOURCE PF WHEN FILE FOUND & MEMBER NOT FOUND */
MONMSG CPF9815 EXEC(DO) /* MEMBER NOT FOUND */
RCVMSG MSGTYPE(*EXCP) RMV(*YES)
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
SRCTYPE(RPGLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
ADDPFM FILE(QTEMP/QRPGLESRC) MBR(SAMPLE) +
SRCTYPE(RPGLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
ENDDO
/* CLEARING MEMBER PRTSAMPLE */
CLRPFM FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* OVRDBF TO INDICATE WHICH FILE AND MEMBER IS TO BE PROCESSED */
OVRDBF FILE(QRPGLESRC) TOFILE(QTEMP/QRPGLESRC) +
MBR(PRTSAMPLE)
MONMSG MSGID(CPF0000 CPF9999) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* GETTING FIELD DESCRIPTION OF &MBR */
DSPFFD FILE(&MBR) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPFFD)
/* CALLING RPGLE PROGRAM */
CALL PGM(XPRTTRY) PARM(&MBR)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* COMPILING PROGRAM */
CRTBNDRPG PGM(QTEMP/SAMPLE) SRCFILE(QTEMP/QRPGLESRC) +
DFTACTGRP(*NO) ACTGRP(*CALLER) OUTPUT(*NONE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* OVRPRTF &MBR TO CHANGE ATTRIBUTE PRTTXT */
OVRPRTF FILE(&MBR) PRTTXT(*BLANK)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
/* CALLING PGM TO GET THE SPOOL FILE */
CALL PGM(QTEMP/SAMPLE)
MONMSG MSGID(CPF0000) EXEC(DO)
GOTO CMDLBL(ABC)
ENDDO
ABC: ENDPGM
**************************************************************************************
f********* File Definition ***************
fdspffd if e disk
fqrpglesrc o f 112 disk
d********* Definitions *******************
d f_spec ds 112
d f_seq 1 6 0 inz
d f_id 18 18 inz('F')
d f_file 19 28
d f_o 29 29 inz('o')
d f_f 34 34 inz('e')
d f_dev 48 57 inz('printer')
d d_spec ds 112
d d_seq 1 6 0 inz
d d_id 18 18 inz('D')
d d_name 19 33
d d_External 34 34
d d_DefType 36 37
d d_From 38 44
d d_To 45 61
d d_datatype 52 52
d d_decimals 53 54
d d_keywords 56 92
d c_spec ds 112
d c_seq 1 6 0 inz
d c_id 18 18 inz('C')
d factor_1 24 37
d oper 38 47
d Factor_2 48 61
d Factor_2x 48 92
d Result 62 75
d record_name s 10
d rec_for s 10
d field_name s 10
d field_type s 1
d loop s 1 0
d do_once s n
c********** Starting Of Main PGM **********************************
c eval *in35 = *on
c eval *in45 = *on
c********** Starting With Once Subroutine (One Time Entry)*********
c if not do_once
c exsr once
c endif
c******************************************************************
c dow *in30 = *off
c start tag
c read QWHDRFFD 25
c*********** Process End Of File(One Time Entry @End Of Pgm)*******
c if *in25 = *on
c eval record_name = whname
c goto end
c endif
c******************************************************************
c move whflde field_name
c move whfldt field_type
c******** For Printing First Record Format(One Time Entry)*********
c if record_name <> whname
c and loop = 0
c and *in35 = *off
c eval oper = 'write'
c eval factor_2 = record_name
c eval f_seq = f_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval *in35 = *on
c eval loop = 1
c endif
c***Condition Check: Print Record Formates between 1st & Last RF*****
c if rec_for = whname
c and *in45 = *off
c goto sel
c endif
c if rec_for <> whname
c and *in45 = *off
c exsr rec1
c endif
c********** Select For Numeric and Character Operations **********
c sel tag
c eval *in45 = *on
c select
c when whfldt = 'L'
c or whfldt = 'T'
c or whfldt = 'Z'
c eval oper = 'time'
c eval result = field_name
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c when whfldt = 'B'
c or whfldt = 'B'
c or whfldt = 'S'
c or whfldt = 'P'
c or whfldt = 'F'
c exsr number
c when whfldt = 'A'
c exsr character
c endsl
c********** End Select **********************************************
c********** For Printing Last Record Format *************************
c end tag
c eval *in30 = *on
C exsr lr
c seton lr
c enddo
c********** Main PGM End *********************************************
c once begsr
c eval do_once = *on
c *entry plist
c parm file 10
c move file f_file
c eval f_seq = f_seq + 100
c write qrpglesrc f_spec
c eval d_seq = f_seq
c eval c_seq = d_seq
c eval oper = 'move'
c eval Factor_2 = '*off'
c eval Result = '*in'
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval oper = 'exsr'
c eval Factor_2 = 'print'
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval oper = 'eval'
c eval Factor_2x = '*inlr = *on'
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval factor_1 = 'print'
c eval oper = 'begsr'
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c endsr
c character begsr
c eval oper = 'move'
c eval factor_2 = '*all''X'''
c eval result = field_name
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval *in35 = *off
c exsr record
c endsr
c number begsr
c eval oper = 'z-sub'
c eval factor_2 = '*all''9'''
c eval result = field_name
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval *in35 = *off
c exsr record
c endsr
c lr begsr
c eval oper = 'write'
c eval factor_2 = record_name
c eval f_seq = f_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c eval oper = 'endsr'
c eval c_seq = c_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c endsr
c record begsr
c if record_name = *blanks
c or record_name = whname
c move whname record_name
c goto start
c endif
c if record_name <> whname
c and loop = 1
c eval rec_for = whname
c setoff 45
c goto start
c endif
c endsr
c rec1 begsr
c eval *in45 = *on
c eval record_name = rec_for
c eval oper = 'write'
c eval factor_2 = record_name
c eval f_seq = f_seq + 100
c write qrpglesrc c_spec
c reset c_spec
c goto sel
c endsr
************************************************************************
| |
RPGLE - Scan and replace - %scan / %replace
Posted By: Mike Haston Contact |
p #replace b export
d #replace pi 32767a varying
d inString 32767a value varying
d from 32767a value varying
d to 32767a value varying
/free
dow %scan( from : inString ) > 0 ;
inString = %replace( to : inString
: %scan( from : inString ) : %len( from ) );
enddo;
return inString;
p #replace e
| |
RPGLE - Use BIFF %REPLACE
Posted By: Matt Tyler Contact |
Using %REPLACE biff in RPG
Matt Tyler
11 Dec 2001
Rating: -3.09- (out of 5)
Stop concatenating strings together just to build command strings.
Now you can put your command string in your program as one
constant string and use the %REPLACE to run the command with
different parameters, similar to what PDM does with
option commands.
At (A), the command string is contained in one constant.
Each parameter I want to replace with different values
at each call all start with the "&" character and a
two-character string meant to represent something to
myself.
At (B) I use the %REPLACE biff to replace my "PDM option parameters"
with actual values from file OUTQP. The %REPLACE biff can replace
a varying number of characters with a varying number of characters.
That means you do not have to replace three characters with three
characters. The fourth parameter ("source length to replace")
tells the system to replace only that many characters of the
original string adding any remaining replacement characters
directly afterward. The effect is the command is expanded to
accommodate the replaced parameters.
When all parameters are replaced, I execute the command at (C).
Code:
* Input file build from TAATOOL, CVTOUTQ
FOUTQP IF E DISK
* Non-selected splf control TO outq
DDTAARA1 DS 150 DTAARA(DTAARA1 )
D OUTQ1 10
* Default printer outq
DDTAARA2 DS 128 DTAARA(DTAARA2)
D OUTQ2 10
** OS/400 Command processor.
DQcmdExc PR ExtPgm('QCMDEXC')
D CmdString 3000 OPTIONS(*VARSIZE) CONST
D CmdLength 15P 5 CONST
D CmdOpt 3 OPTIONS(*NOPASS)
* Stand-alone fields ****************
D cmdexc S 256
D cmdlen S 15 0
* Constants definitions ************
*******( A )*******
D ChgSplfa C 'CHGSPLFA FILE(&SF) JOB(&J#/&JU/&JN)-
D SPLNBR(&SN) OUTQ(&OQ)'
D DltSplf C 'DLTSPLF FILE(&SF) JOB(&J#/&JU/&JN)-
D SPLNBR(&SN)'
C IN DTAARA1
C IN DTAARA2
C READ OUTQP
C DOW NOT %eof(OUTQP)
C EVAL CmdExc = ChgSplfa
*******( B )*******
* Replace &SF with SPFILE (Splf name)
C EVAL CmdExc = %Replace(%trim(SPFILE) :
C CmdExc :
C %scan('&SF': CmdExc):
C 3)
* Replace &JN with SPJNAM (Splf job name)
C EVAL CmdExc = %Replace(%trim(SPJNAM) :
C CmdExc :
C %scan('&JN': CmdExc):
C 3)
* Replace &JU with SPUSER (Splf job user)
C EVAL CmdExc = %Replace(%trim(SPUSER) :
C CmdExc :
C %scan('&JU': CmdExc):
C 3)
* Replace &J# with SPJNBR (Splf job number)
C EVAL CmdExc = %Replace(%trim(SPJNBR) :
C CmdExc :
C %scan('&J#': CmdExc):
C 3)
* Replace &SN with SPFNBR (Splf number)
C EVAL CmdExc = %Replace(%trim(SPFNBR) :
C CmdExc :
C %scan('&SN': CmdExc):
C 3)
* Replace &OQ with RETLQ
C IF Outq2 = 'Y'
C EVAL CmdExc = %Replace(%trim(OUTQ2) :
C CmdExc :
C %scan('&OQ': CmdExc):
C 3)
C ELSE
* -OR - Replace &OQ with TOOUTQ
C EVAL CmdExc = %Replace(%trim(OUTQ1 ) :
C CmdExc :
C %scan('&OQ': CmdExc):
C 3)
C ENDIF
*******( C )*******
C EVAL CmdLen = %len(CmdExc)
C CALLP Qcmdexc(CmdExc: CmdlEN)
* Insert your code to do whatever with OUTQ entry.
* /
* :
* :
* :
* /
* Insert your code to do whatever with OUTQ entry.
C READ OUTQP
C ENDDO
C EVAL *INLR = *ON
| |
RPGLE - %Lookup on a data structure array
Posted By: Werner Noll Contact |
D Ds
D arySub Dim( 100)
D SumSub Like( GlSub ) Overlay(arySub:1)
D SubDl01 Like( GlExa ) Overlay(arySub:11
D GlSub S 10A
D GlExa S 10A
D SubToSum S 20A
C _Eval SubToSum = arySub(%Lookup(GlSub:SumSub))
C Return
I inserted some definitions to get it compiled.
| |
RPGLE - replace *Entry with prototypes
Posted By: chris hayden Contact |
D $Entry Pr extpgm('OE0094F')
D parmOrd 9 0
D parmThere 1a
D $Entry Pi
D parmOrd 9 0
D parmThere 1a
| |
RPGLE - %timestamp
Posted By: chris hayden Contact |
D DS
D TimeStamp z
D Cur_Date d Overlay(TimeStamp)
D Cur_Time t Overlay(TimeStamp:12)
timeStamp = %Timestamp;
| |
RPGLE - rpg free example
Posted By: chris hayden Contact |
// jobdat 8,0, jobtim 6,0
jobdat = %Uns( %Char( %Date( timeStamp ) : *ISO0 ) );
jobtim = %Uns( %Char( %Time( timeStamp ) : *HMS0 ) );
// convert character to numeric
dtseq = %Int(PDTSEQ);
// convert numeric to character
Rhdate = %Char(Rhjdt@);
// no more key lists
Setll (wrkCorp#: wrkCo#: wrkCust#) Arlcsmst;
Reade (wrkCorp#: wrkCo#: wrkCust#) Arlcsmst;
Chain (wrkCorp# : wkrCo# : wrkCust# ) Arlcsmst;
// get todays date
Date8s0 = %Uns(%Char(%Date():*ISO0));
Date8a0 = %Char(%Date():*USA0);
// TodaysDate defined as a "D" field
ToDaysDate = %Date();
BirthDate = %DATE(BirthYMD:*USA);
DaysOld = %DIFF(Today:BirthDate:*DAYS);
DaysOld = %DIFF(%DATE() :
%DATE(BirthYMD:*USA) :
*DAYS);
DueDate = InvDate + %DAYS(30);
//convert a date back to a character field
DateCharacter = %CHAR(Date:*ISO0);
DateNumeric = %UNS(%CHAR(Date:*ISO0));
// retrieve the month
MM = %SubDt(SomeDate : *Months);
// check the month
If %SubDt(SomeDate : *Months) = ReportMonth;
// scan for string, check result
If %Scan(SomeSrch : SomeString) > 0;
// thetimenow defined as a "T" field
TheTimeNow = %Time();
// Assuming the 8.0 Field is to be in YYYYMMDD Format:
// Assuming the 6.0 Field is to be in HHMMSS Format:
YYYYMMDD = %Int( %Char( ToDaysDate : *ISO0 ) );
HHMMSS = %Int( %Char( TheTimeNow : *HMS0 ) );
// You Need V5R2 to use %uns
YYYYMMDD = %uns( %char( %date : *ISO0 ) );
HHMMSS = %uns( %char( %time : *HMS0 ) );
Eval DueDate = LoanDate + %Years(YY) +
%Months(MM) +
%Days(DD);
OutDate = DueDate - %Days( 14 );
EndTime = StrTime + %Hours( 8 );
NbrDays = %Diff( DueDate : OutDate : *Days )
NbrHrs = %Diff( EndTime : StrTime : *Hours )
BirthYear = %SubDt( BirthDate : *Years );
CurHour = %SubDt( CurTime : *Hours );
SomeTimestamp = %Timestamp( CharTimestamp );
SomeDate = %Date( CharDate : *MDY0 )
SomeTime = %Time( CharTime : *USA )
ISODueDt = %Date( EurDueDt : *Eur ) ;
ISODate = %Date( NumericDate ) + %Days( 5 ) ;
YYYY = %SubDt( ISODate : *Years ) ;
MM = %SubDt( ISODate : *Months ) ;
DD = %SubDt( ISODate : *Days ) ;
count += 1; // increment count by 1
count -= 5; // decrement count
count *= (a+b); // multiply count by (a+b)
count /= 17; // divide count by 17
count **= 3; // cube the count
string += 'QED.'; // append to the end of string
ptr += %len(var); // increment pointer
date += %years(2) + %months(5) - %days(17);
// using procedures in expressions
if MyFunc1(string1) = %trim (MyFunc2(string2));
%subst(X(3))= MyFunc3('abc');
endif;
//only update certain fields available v5r2
UPDATE EmpRec %FIELDS(Salary:Status);
// no more EVAL
dataBaseField = screenField;
*inlr = *On;
// no more CALLP
$CopyNotes( Scr_OrgOrd : Scr_Ord# );
// julian dates
LongJulA = %Char(%Date(DMY:*DMY):*LongJul0) ;
// qualified data structure
Price = OrderDetail.Part.Cost;
// qualified data structure with arrays
price = Order(I+17). ItemList(p). Part. Cost;
// get the number of elements in the array
ArraySize = %elem (Array);
// convert string to decimal with positions
number = %dec(string:7:2);
// for loops
For Index = StartVal To EndVal By IncVal;
ExSr Process;
EndFor;
For Counter = 1 To NbrLoops;
ExSr Process;
EndFor;
// Monitor for Errors
Monitor;
Dou %EOF(TimeRecord);
Read TimeRecord;
If %EOF(TimeRecord);
Leave;
Else;
TotalPay = (RegHours * Rate)
+ (OvtHours * Rate * 1.5)
+ (DblHours * Rate * 2);
Update TimeRecord;
Endif;
Enddo;
On-error 1218; // Record locked
Dsply 'TimeRecord record locked.';
Leave;
On-error 1011:1211:*FILE; // File error
Dsply 'Unexpected file error occurred.';
Leave;
On-error *PROGRAM; // Non-file error
Dsply 'Unexpected program error occurred.';
Leave;
Endmon;
// Error Extension
Chain(E) SlcKey Master;
Select;
When %Error;
MasterIOErr();
When Not %Found( Master );
MasterNFnd();
Other;
ProcMaster();
EndSl;
// divide and remainder
quote = %div( total : count );
remain = %rem( total : count );
msg = 'total divided by count = ' +
%char(quote) + ' remainder ' +
%char(remain);
| |
RPGLE - Generate a random number
Posted By: jamie flanary Contact |
d instartnumber s 15 5
d inendnumber s 15 5
d inrandomnumber s 15 5
d wkseed s 9 9
d wkstartnumber s 6 0
d wkendnumber s 6 0
d wkrandomnumber s 6 0
d range s 6 0
d time s 12 0
c *entry plist
c parm instartnumber
c parm inendnumber
c parm inrandomnumber
*
c eval wkstartnumber = instartnumber
c eval wkendnumber = inendnumber
c eval wkrandomnumber = inrandomnumber
*
c if wkseed = *zeros
c time time
c .000000001 mult time wkseed
c endif
*
c if wkstartnumber = *zeros and
c wkendnumber = *zeros or
c wkendnumber < wkstartnumber
c eval wkstartnumber = 1
c eval wkendnumber = 999999
c endif
*
c eval range = (wkendnumber -wkstartnumber) + 1
*
c mult 9821 wkseed
c add .211327 wkseed
c eval wkrandomnumber = (wkseed * range) +
c wkstartnumber
c eval *inlr = *on
| |
RPGLE - QLGSORT - Use APi to sort subfile data
Posted By: jamie flanary Contact |
*==============================================================
* Subroutine - SortSfl
*
* For information on Sort API's see
* OS/400 National Language Support API Guide
* This subroutine sorts the subfile records.
*==============================================================
c $SortSFL begsr
*
* Initialize the key fields to sort on.
* Load S1PRO# field as key field, 07 byte, dec, ascending sequence.
*
c eval KeyStart = 1
c eval KeySize = 07
c eval KeyDtaTyp = 2
c eval KeyAscDesc = 1
c eval KeyInf(1) = KeyInfDs
*
* Load S1CNAM field as key field, 30 byte, char , descending sequence.
*
c eval KeyStart = 8
c eval KeySize = 30
c eval KeyDtaTyp = 6
c eval KeyAscDesc = 2
c eval KeyInf(2) = KeyInfDs
*
* Load other sort parameters.
*
c eval BlockLen = 80 + 16 * MaxKey
c eval NbrOfKeys = 2 Variable
c eval RecLen = %size(SFLRCD)
*
* Initialize Sort I/O API fields.
*
c eval IORecLen = RecLen
c eval IORecCnt = 1
*
* All done initializing.
* First step - Initialize the sort routine.
*
c call 'QLGSORT'
c parm SortBlock
c parm NotUsed
c parm NotUsed
c parm SizeList
c parm ReturnSize
c parm Error
*
* Next step - write records to I/O routine.
*
c eval IOType = 1
*
* read the entire subfile
*
c for count = 1 to Savrrn
*
c count chain SUB01
*
c if %found
*
c call 'QLGSRTIO'
c parm SortIOBloc
c parm SflRcd
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm Error
*
c endif
*
c endfor
*
* Next step - Signal end of input, clear subfile for reload.
*
c eval IOType = 2
c
c call 'QLGSRTIO'
c parm SortIOBloc
c parm SflRcd
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm Error
*
* Clear the subfile
*
c exsr $ClearSFL
*
* Final step - write the records back to the subfile.
*
c eval IOType = 3
*
*
* read the entire subfile
*
c for count = 1 to Savrrn
*
c call 'QLGSRTIO'
c parm SortIOBloc
c parm NotUsed
c parm SflRcd
c parm IORecLen
c parm NotUsed
c parm Error
*
c eval RRN1 = Count
c eval SCRRN = RRN1
c write Sub01
*
c endfor
c eval SubfileEnd = *on
c z-add SCRRN SavRrn
*
c if SavRrn = *Zeros And SubfileEnd
c eval DisplaySubfile = *Off
c else
c eval RRN1 = 1.
c eval SCRRN = 1.
c endif
*
c endsr
*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
* $PosSubfile - Position the subfile
*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
cSR $PosSubfile begsr
*
c for count = 1 to Savrrn
*
c count chain SUB01
c if %found and
c S1PRO# = C1PRO# or
c %found and
c S1PRO# > C1PRO# or
c count = Savrrn
*
c eval RRN1 = Count
c eval SCRRN = Count
*
* check to see last pink record and un-pink it
*
c if LastPinkRRN > *Zeros
c LastPinkRRN chain SUB01
c if %found
c eval Pink = *Off
c update SUB01
c clear LastPinkRRN
c endif
c endif
*
c Count chain SUB01
c if %found
c clear C1PRO#
c eval Pink = *On
c update SUB01
c eval Pink = *Off
c z-add Count LastPinkRrn
c leave
c endif
*
c endif
*
c endfor
*
c endsr
*
| |
RPGLE - DSPDEVU (6/8): DISPLAY LIST OF USER'S ACTIVE SCREEN
Posted By: bossé yvain Contact |
** LISTE DES SOURCES :
** DSPDEVU CMD
** DSPDEVUC CLP
** DSPDEVUD CLP
** DSPDEVUE DSPF
** DSPDEVUM CLP
** DSPDEVUS RPGLE
** QPDSPAJBL1 LF
** QPDSPAJBP PF
˜*************************************************************************
*˜
*˜Programme : DSPDEVU AFFICHAGE ECRANS D'UN USER (DSPDEVU)
*˜ DISPLAY ALL USER'S ACTIVE SCREEN
*˜
*˜Mode appel: CMD : DSPDEVU
*˜
*˜Remarques : POSSIBILITE D'ENVOYER UN MESSAGE A L'UTILISATEUR
*˜ POSSIBILITY TO SEND BREACK MESSAGE TO THIS USER
*˜
*˜Remarques : SOUS FICHIER EN CHARGEMENT DYNAMIQUE
*˜ DYNAMIC SUBFILE
*˜
*‚Date Créa.: xx/09/04 Auteur : Yvain Bossé
*‚ ybosse@wanadoo.fr
*‚ ybosse@free.fr
*‚Date Modif Objet modification
*‚°°°°°°°°°° °°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
*
*˜************************************************************************
‚* ------------------------------------------------------------------------
‚* DECLARATION DES FICHIERS
‚* ------------------------------------------------------------------------
‚* Fichier Ecran
FDSPDEVUE CF E WORKSTN
F SFILE(DSPDEV072:WREC72)
‚* Fichier des écrans actifs d'un utilisateur
FQPDSPAJBL1IF E K DISK
‚*
‚* ------------------------------------------------------------------------
‚* DECLARATION DES CONSTANTES/ZONES/TABLEAUX
‚* ------------------------------------------------------------------------
‚*
D SFLP72 C CONST(012)
‚*
D DS
D QNBJOB 1 6 0
D TNBJOB 1 6
‚*
‚* ------------------------------------------------------------------------
‚* PARAMETRES EN ENTREE/SORTIE
‚* ------------------------------------------------------------------------
‚*
C *ENTRY PLIST
C PARM REFRESH 1
‚*
‚* ------------------------------------------------------------------------
‚* LISTE DES CLES D'ACCES FICHIER
‚* ------------------------------------------------------------------------
‚*
‚* QPDSPAJBL1
C KDSPA1 KLIST
C KFLD QUSER
C KFLD QECRAN
C KFLD QNBJOB
‚*
‰**************************************************************************
‰*------------------------------------------------------------------------*
‰* ˆ DEBUT DE PROGRAMME // BEGIN PROGRAM ‰
‰*------------------------------------------------------------------------*
‰**************************************************************************
‚*
C SETON 02
‚*
C *INRT DOWEQ '0'
C *IN02 CASEQ '1' ECR02
C END
C END
C SETON LR
‚*
š**************************************************************************
š* ECR02 - LISTE DES ECRANS DU USER
š* DISPLAY ALL USER'S ACTIVE SCREEN
š**************************************************************************
‚*
C ECR02 BEGSR
‚*
C SETOFF 02
‚*
C DOU ERR02 = *OFF
‚*
C EXSR àFPG72
‚*
C WRITE DSPDEV082
C SETOFF 63
C SETON 65
‚*
?C ERR02 DOUEQ *OFF
C WRITE DSPDEV082
C WMAX72 COMP *ZERO 64
C EXFMT DSPDEV002
C MOVE *OFF ERR02 1
‚*
‚*F3 = FIN / END
ˆC *INKC IFEQ *ON
C EVAL *INRT = *ON
C LEAVE
ˆC ENDIF
‚* F5 = REACTUALISE / REFRESH
ˆC *INKE IFEQ *ON
C EVAL *INRT = *ON
C EVAL REFRESH = *ON
C LEAVE
ˆC ENDIF
‚* ROLLUP
ˆC *IN61 IFEQ *ON
C EXSR àRUP72
C EVAL ERR02 = *ON
ˆC ENDIF
‚*ROLLDOWN
ˆC *IN62 IFEQ *ON
C EXSR àRDW72
C EVAL ERR02 = *ON
ˆC ENDIF
‚*
ˆC IF NOT *INKL
C AND NOT *INKC
C AND WMAX72 > *ZEROS
C AND ERR02 = *OFF
C EVAL ERR02 = *ON
C READC DSPDEV072 90
˜C DOW NOT *IN90
C EXSR CTL72
C EVAL WCHX72 = ' '
C UPDATE DSPDEV072
šC IF ERR02 = *ON
C LEAVE
šC ENDIF
C READC DSPDEV072 90
˜C ENDDO
ˆC ENDIF
‚*
?C ENDDO
‚*
C ENDDO
‚*
C ENDSR
‚*
š**************************************************************************
š* àFPG72 - CHARGEMENT PREMIERE PAGE SFL SFL72
š* LOAD FIRST SCREEN OF THE SUBFILE
š**************************************************************************
‚*
C àFPG72 BEGSR
‚*
C MOVE *OFF àEOF72 1
C MOVE *ON àBOF72 1
C Z-ADD *ZERO WMAX72 4 0
‚*
C EXSR àRUP72
‚*
C ENDSR
‚*
š**************************************************************************
š* àLPG72 - CHARGEMENT DERNIERE PAGE SFL 72
š* LOAD LAST SCREEN OF THE SUBFILE
š**************************************************************************
‚*
C àLPG72 BEGSR
‚*
C MOVE *ON àEOF72
C MOVE *OFF àBOF72
C Z-ADD *ZERO WMAX72
‚*
C EXSR àRDW72
‚*
C ENDSR
‚*
š**************************************************************************
š* àCLR72 - REMISE A BLANC SFL 72
š* CLEAR SUBFILE
š**************************************************************************
‚*
C àCLR72 BEGSR
‚*
C Z-ADD *ZERO WMAX72 4 0
C SETON 6365
C SETOFF 64
C WRITE DSPDEV002
C SETON 6465
C SETOFF 63
‚*
C ENDSR
‚*
š**************************************************************************
š* àRUP72 - CHARGEMENT PAGE SUIVANTE SFL 72
š* LOAD NEXT SCREEN OF THE SUBFILE
š**************************************************************************
‚*
C àRUP72 BEGSR
‚*
ˆC IF àBOF72 = *ON
C MOVE 'S' àMODR 1
C EXSR àPOS72
ˆC ENDIF
‚*
C Z-ADD *ZERO àNBR72 3 0
‚*
C READ QDSPAJ 95
‚*
ˆC *IN95 DOUEQ *ON
C àNBR72 OREQ SFLP72
‚*
˜C àNBR72 IFEQ *ZERO
C EXSR àCLR72
˜C ENDIF
˜C *IN95 IFEQ *OFF
C EXSR àADD72
C ADD 1 àNBR72
šC IF àNBR72 = 1
C Z-ADD 1 WLIG72
šC ENDIF
˜C ENDIF
‚*
˜C àNBR72 IFLT SFLP72
C READ QDSPAJ 95
˜C ENDIF
‚*
ˆC ENDDO
‚*
ˆC *IN95 IFEQ *ON
C MOVE *ON àEOF72
C Z-ADD àNBR72 SVMAX72 3 0
ˆC ENDIF
‚*
C ENDSR
‚*
š**************************************************************************
š* àRDW72 - CHARGEMENT PAGE ARRIERE SFL 72
š* LOAD PREVIOUS SCREEN OF THE SUBFILE
š**************************************************************************
‚*
C àRDW72 BEGSR
‚*
‚** positionnement fichier type - clÉ UNIQUE -
ˆC WMAX72 IFEQ *ZERO
C MOVE 'F' àMODR
ˆC ELSE
C MOVE 'P' àMODR
ˆC ENDIF
C EXSR àPOS72
‚*
‚* chargement ss/fichier
C Z-ADD 0 àWN30 3 0
C SFLP72 ADD 1 àWN30
ˆC DO àWN30
C READP QDSPAJ 95
ˆC N95 ENDDO
‚** positionnement fichier type - clÉ UNIQUE -
‚*
ˆC *IN95 IFEQ *ON
C MOVE *ON àBOF72
ˆC ENDIF
‚*
C EXSR àRUP72
‚*
C ENDSR
‚*
š**************************************************************************
š* àPOS72 - POSITIONNEMENT SFL 72
š* FIND RECORD ON THE SUBFILE
š**************************************************************************
‚*
C àPOS72 BEGSR
‚*
ˆC àMODR IFEQ 'S'
C MOVE *OFF àBOF72
C *LOVAL SETLL QDSPAJ
ˆC ELSE
‚*
˜C àMODR IFEQ 'F'
C àMODR OREQ 'P'
C MOVE *OFF àEOF72
šC IF àMODR = 'P'
C MOVE *OFF àBOF72
šC ENDIF
šC IF WMAX72 > 0
C 1 CHAIN DSPDEV072 99
šC ELSE
C SVMAX72 CHAIN DSPDEV072 99
šC ENDIF
C KDSPA1 SETLL QDSPAJ
C
˜C ENDIF
ˆC ENDIF
‚*
C ENDSR
‚*
š**************************************************************************
š* àADD72 - AJOUT ENREGISTREMENT SFL 72
š* WRITE NEW RECORD IN THE SUBFILE
š**************************************************************************
‚*
C àADD72 BEGSR
‚*
C ADD 1 WMAX72 4 0
C Z-ADD WMAX72 WREC72 4 0
C WRITE DSPDEV072
C EVAL *IN40 = *OFF
‚*
C ENDSR
‚*
š**************************************************************************
š* àCTL72 - CONTROLE SFL 72
š* MAKE CONTROL ON THE CHOICE
š**************************************************************************
‚*
C CTL72 BEGSR
‚*
ˆC SELECT
‚* WRKJOB
ˆC WHEN WCHX72 = '5'
C CALL 'DSPDEVUD'
C PARM QUSER
C PARM QECRAN
C PARM TNBJOB
‚* SNDBRKMSG
ˆC WHEN WCHX72 = '1'
C CALL 'DSPDEVUM'
C PARM QECRAN
ˆC ENDSL
‚*
C ENDSR
‚*
š**************************************************************************
š* *INZSR - INITIALISATION PROGRAMME
š**************************************************************************
‚*
C *INZSR BEGSR
‚*
‚*
C ENDSR
‚*
| |
RPGLE - BIF - using %lookup
Posted By: jimmy octane Contact |
C Eval Idx = %LookUp( SrchArg : SomeAry )
C If Idx > *Zero
* Process information
C EndIf
C Eval Idx = %LookUp( SrchArg : SomeAry : 4 )
C If Idx > *Zero
* Process information
C EndIf
C Eval Idx = %LookUp( SrchArg : SomeAry : 4 : 5 )
C If Idx > *Zero
* Process information
C EndIf
C Eval Idx = %LookUpGE( SrchArg : SomeAry )
C If Idx > *Zero
* Process information
C EndIf
C Eval *In01 = %TLookUpLT( SrchArg : TabEmp )
C If *In01
* Process information
C EndIf
C If %TLookUpLT( SrchArg : TabEmp )
* Process information
C EndIf
| |
RPGLE - BIF - using %check
Posted By: jimmy octane Contact |
C Eval Pos = %Check( ' ' : SomeString )
C If Pos > *Zero
* Process information
C EndIf
C Eval Pos = %Check( ' ' : SomeString : 11 )
C If Pos > *Zero
* Process information
C EndIf
C Eval Pos = %Check( '0123456789' : SomeString )
C If Pos > *Zero
* Process information
C EndIf
C Eval Pos = %CheckR( ' ' : SomeString )
C If Pos > *Zero
* Process information
C EndIf
C Eval Pos = %CheckR( ' ' : SomeString : 30 )
C If Pos > *Zero
* Process information
C EndIf
| |
RPGLE - Timing Out a Subfile
Posted By: jimmy octane Contact |
==>DDS
A DSPSIZ(24 80 *DS3)
A INVITE
A R S01 SFL
A FLD001 3Y 0O 7 8EDTCDE(Z)
A R C01 SFLCTL(S01)
A SFLSIZ(0020)
A SFLPAG(0005)
A CA03(03)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A N01 SFLEND(*MORE)
A 2 5'Msg:'
A COLOR(WHT)
A CTLMSG 11A O 2 11
A R K01
A 13 6'F3=Exit'
A COLOR(BLU)
==> RPG
FTestD CF E WorkStn Sfile( S01: Rrn )
F MaxDev( *File )
F InfDs( TestdDs )
D RRN S 3P 0
D I S 3P 0
D TestdDs DS
D Sts *Status
* Fill the subfile
C Eval RRN = *Zero
C Do 8 I
C Eval Fld001 = I
C Eval RRN = RRN + 1
C Write S01
C EndDo
C DoU *In03 = *On
C Write K01
C Write C01
C Read TestD 99
C If Sts = 1331
C Eval CtlMsg = 'Timed Out'
C Else
C If *In03 = *On
C Leave
C EndIf
C Eval CtlMsg = 'No Time Out'
C EndIf
C EndDo
C Eval *InLR = *On
| |
RPGLE - Day of week/Week of year prototypes
Posted By: jimmy octane Contact |
H NoMain
* ------------------------------------------------------------- Prototypes
D DayOfWeek PR 5I 0
D D Value
D WeekOfYear PR 5I 0
D D Value
* ------------------------------------------------------------------------
*
* Procedure: DayOfWeek
* Description: Retrieve day of week using ISO 8601 standard
* (0=Monday … 6=Sunday)
*
P DayOfWeek B Export
D DayOfWeek PI 5I 0
D DateIn D Value
D NbrDays S 10I 0
D Monday C D('2001-01-04')
/Free
NbrDays = %DIFF(DateIn:Monday:*DAYS);
Return = %REM( %REM(NbrDays:7) + 7 : 7);
/End-Free
P DayOfWeek E
* ------------------------------------------------------------------------
*
* Procedure: WeekOfYear
* Description: Retrieve week of year using ISO 8601 standard
* (Year starts on Monday of week containing January 4)
*
P WeekOfYear B Export
D WeekOfYear PI 5I 0
D DateIn D Value
D DS
D Jan04Date D INZ(D'0001-01-04')
D Jan04Year 4 0 Overlay(Jan04)
D FirstMonday S D
D Jan04DOW S 5I 0
/Free
// Change Jan04Date to target year,
// then calculate first Monday of target year
Jan04Year = %SUBDT(DateIn:*Y);
Jan04DOW = DayOfWeek(Jan04Date);
FirstMonday = Jan04Date - %DAYS(Jan04DOW);
// If target date is before first Monday, switch to prior year
If DateIn < FirstMonday;
Jan04Year = Jan04Year - 1;
Jan04DOW = DayOfWeek(Jan04Date);
FirstMonday = Jan04Date - %DAYS(Jan04DOW);
Endif;
// Return week number (number of full weeks since first Monday + 1)
Return %DIV(%DIFF(DateIn:FirstMonday:*DAYS):7) + 1;
/End-Free
P WeekOfYear E
| |
RPGLE - Prototype to retrive calling program name
Posted By: jimmy octane Contact |
H NoMain
* Prototype
D CallingPgm PR 10
D DummyPrm 1 Options( *Omit )
* Get the calling program's name
P CallingPgm B Export
D CallingPgm PI 10
D DummyPrm 1 Options( *Omit )
* Local variables
D MsgId S 7 Inz( 'CPF9898' )
D QlMsgf S 20 Inz( 'QCPFMSG *LIBL' )
D MsgDta S 1 Inz( *Blank )
D LenMsgDta S 10I 0 Inz( %Size( MsgDta ) )
D MsgType S 10 Inz( '*INFO' )
D ClStkEntry S 10
D ClStkCounter S 10I 0
D MsgKey S 4
D ApiErr DS
D AeBytesPrvd 10U 0 Inz( 272 )
D AeBytesAvl 10U 0
D AeMsgId 7
D 1
D AeMsgDta 256
D MsgInf DS
D MiBytesRetd 10U 0
D MiBytesAvl 10U 0 Inz( 120 )
D MiPgmName 111 120
D LenMsgInf S 10U 0 Inz( %Size( MsgInf ) )
D FmtName S 8 Inz( 'RCVM0200' )
D WaitTime S 10U 0 Inz( *Zero )
D MsgAction S 10 Inz( '*REMOVE' )
* Send a dummy message to the calling program
C Eval ClStkEntry = '*PGMBDY'
C Eval ClStkCounter = 1
C Call 'QMHSNDPM'
C Parm MsgId
C Parm QlMsgf
C Parm MsgDta
C Parm LenMsgDta
C Parm MsgType
C Parm ClStkEntry
C Parm ClStkCounter
C Parm MsgKey
C Parm ApiErr
* Receive the message back and pick up the program name
C Eval ClStkEntry = '*'
C Eval ClStkCounter = 0
C Call 'QMHRCVPM'
C Parm MsgInf
C Parm LenMsgInf
C Parm FmtName
C Parm ClStkEntry
C Parm ClStkCounter
C Parm MsgType
C Parm MsgKey
C Parm WaitTime
C Parm MsgAction
C Parm ApiErr
C Return MiPgmName
P CallingPgm E
==========call example=============
D CallingPgm PR 10
D DummyPrm 1 Options( *Omit )
D PgmName S 10
C Eval PgmName = CallingPgm( *Omit )
| |
RPGLE - Retrieve deleted records from file
Posted By: jimmy octane Contact |
D TotalC S 9S 0
D Len S 9B 0 Inz( 265 )
D Fmt S 8 Inz( 'MBRD0200' )
D FilNam S 20 Inz( 'LOCDTP LOCATOR ' )
D MbrNam S 10 Inz( '*FIRST' )
D OvrPrs S 1 Inz( '0' )
D Error S 30
D Out DS 265
D BytRet 1 4B 0
D BytAvl 5 8B 0
D MbrName 29 38
D PFLF 137 137
D Total 141 144B 0
D DelRcd 145 148B 0
D NoMbrs 157 160B 0
C APIList PList
C Parm Out
C Parm Len
C Parm Fmt
C Parm FilNam
C Parm MbrNam
C Parm OvrPrs
C Parm Error
C Call 'QUSRMBRD' APIList
C Z-Add Total TotalC
C BytRet Dsply
C BytAvl Dsply
C MbrName Dsply
C PFLF Dsply
C TotalC Dsply
C DelRcd Dsply
C NoMbrs Dsply
C Eval *InLR = *On
| |
RPGLE - compile time array lookup example
Posted By: jimmy octane Contact |
*====================================
*
*====================================
d CODE s 2 DIM(8) CTDATA PERRCD(4)
d DESC s 10 DIM(4) CTDATA PERRCD(1)
d x s 3 0
d INCODE s 2
d OUTDSC s 10
*
c eval x = 1
c INCODE LOOKUP CODE(x) 99
c if %Found
c eval OUTDSC = %trim(DESC(X))
c endif
*
c *entry plist
c parm INCODE
c parm OUTDSC
*
C eval *INLR = *on
*====================================
**
A1A2A3A4
**
Import
Local
Production
Return
| |
RPGLE - Finding a pattern in a list
Posted By: Prithiviraj.D Contact |
* -- Input Date SplitUp
DInDate DS
D Month 2 Overlay(Indate)
D Day 2 Overlay(Indate:*Next)
D Year 4 Overlay(Indate:*Next)
* -- List Of Months with 31 Days
D W31Days S 100A Inz('01 03 05 07 08 10 12')
D InvalidDate S N
C *InzSr BegSr
C
C *Entry PLIST
C PARM MMDDYYYY
C PARM InvalidDate
C
C If MMDDYYYY <> *Blanks
C Eval InDate = MMDDYYYY
C Else
C Eval InvalidDate = *On
C Eval *Inlr = *On
C Return
C EndIf
Main Logic
/Free
// Check whether the Month has 31 days
If %Scan(%Trim(Month):W31Days) > 0;
If Day >= '01' And Day <= '31';
InvalidDate = *Off;
Else;
InvalidDate = *On;
EndIf;
Else;
If Day >= '01' And Day <= '30';
InvalidDate = *Off;
Else;
InvalidDate = *On;
EndIf;
EndIf;
/End-Free
| |
RPGLE - Centering Text on a Display Field
Posted By: Prithiviraj.D Contact |
Simulation of IBM's logic for centering text in SDA
H DFTACTGRP(*NO) BNDDIR('QC2LE')
FSEU CF E WORKSTN
D string S 60A Inz
D len S 8 0 Inz
D diff S 8 0 Inz
D i S 8 0 Inz
D rem S 8F Inz
D abs PR 8F Extproc('fabs')
D input 8F
C ExFmt Center
/Free
string = %trim(Cfld);
len = %len(%trim(string));
diff = (60-len);
rem = %div(diff:2);
i = abs(rem);
/End-Free
* CFLD is the Screen fld and is in DDS screen
* CENTER
C Eval Cfld = *ALL' '
C Eval Cfld = %replace(string:Cfld:i+1:0)
C ExFmt Center
C Eval *Inlr = *On
| |
RPGLE - API - QSYGETPH (validate Password)
Posted By: Jimmy Octane Contact |
V5R3 Version
*this api validates an as400 username and password:
DWkUser S 10A inz('FLANARY')
DWKPassword S 10A inz('PIZZA')
DProfileHandle S 12A
DPassWordLength S 10i 0 inz(10)
DCCSID S 10i 0 inz(37)
D*
DQUSEC DS
D* Qus EC
D QUSBPRV 1 4B 0
D* Bytes Provided
D QUSBAVL 5 8B 0
D* Bytes Available
D QUSEI 9 15
D* Exception Id
D QUSERVED 16 16
D* Reserved
D ERRC0100 17 274 Varying
d error S n
C*
C Call 'QSYGETPH'
C Parm WKUser
C Parm WKPassword
C Parm ProfileHandle
C Parm QUSEC
C Parm PasswordLength
C Parm CCSID
C*
C If QUSBAVL > 0
C Eval Error = *ON
C Endif
C*
c eval *inlr = *on
| |
RPGLE - RPGLE - Batch Program
Posted By: Michael Noll Contact |
h debug(*yes) option(*nodebugio:*expdds)
¹*
¹*****************************************************************
¹* Program Name: O6TRKR Author: Michael Noll *
¹* *
¹* Purpose: Print all open orders for a customer that have *
¹* 'TRK' in the Price Category Code, or the product *
¹* description contains any of the following: *
¹* 'TRK' - 'EXTRUS' - 'ROD-' *
¹* Or the Part Number is either of the following: *
¹* 'CUTTING CHARGE' - 'NONSTOCKTRACK' *
¹* *
¹* Include any Parent Part #'s for Kit Bills. *
¹* Include any comments for selected line items, as *
¹* well as any order comments. *
¹* *
¹* Copyright (c) 2004 *
¹* Harken Incorporated *
¹* *
¹* This unpublished material is proprietary to Harken *
¹* Incorporated All rights reserved The methods and *
¹* techniques described herein are considered trade secrets *
¹* and/or confidential Reproduction or distribution, in *
¹* whole or in part, is forbidden except by express written *
¹* permission of Harken Incorporation *
¹* *
¹*****************************************************************
¹* To compile this program use PDM option 14. *
¹* To debug, use DBGVIEW of *SOURCE when compiling. *
¹*****************************************************************
¹* Modifications: *
¹* Int Date Description *
¹* ---- ---------- -------------------------------------- *
¹* hrk 07/14/2004 Added '*** REPRINT ***' verbiage to *
¹* report. Using the O4FFC1 = 'R'. *
¹* *
¹* hrk1 9/22/2004 Added Barcode with Order #/Suffix to *
¹* report. *
¹* *
¹* hrk2 9/29/2004 Added verbiage of '***COD***' for COD *
¹* orders. Add verbiage of 'Consisting of' *
¹* for kits, in the O5Comments. *
¹* *
¹* hrk3 10/12/2004 Clean up of comment lines printing for *
¹* kits, when there were no track/extrus *
¹* kits. *
¹* *
¹* hrk4 10/13/2004 Omit Parts that have been omitted through *
¹* O6CUST program PMUSR = 'TRKOMT' *
¹* *
¹*****************************************************************
¹*
fcm1 if e k disk
¹* CM1P by Customer #
¹*
fnf if e k disk
¹* Notes File
¹*
fo2 if e k disk
¹* O2P by Ord #, Sufx & Item
¹*
fo4 if e k disk
¹* Sales Order Detail, Billing Header File
¹*
fo5 if e k disk
¹* O5P by Ord #, Sufx & Item
¹*
fo605 if e k disk
¹* Sales Order Detail, Line Items File
¹*
foh if e k disk
¹* OHP by Ord #, Sufx & Item
¹*
fpm if e k disk
¹* Product Master File
¹*
fo6trkpr o e printer oflind(overflow)
f infds(printer_ds)
¹* O6TRK Print File - by Customer #/Order #/Date Combination
¹*
¹*---------------------------------------------------------*
¹* System Data Structure *
¹*---------------------------------------------------------*
¹*
d sds
d program *proc
d status *status
d username 254 263
¹*
¹*---------------------------------------------------------*
¹* Data Structures *
¹*---------------------------------------------------------*
¹*
¹* Printer Info DS (get line # for Overflow)
d printer_ds ds
d line 367 368b 0
¹*
¹* Indicator Data Structure
d indicator s * inz(%addr(*in))
d ds based(indicator)
d overflow 1 1n
d numeric 91 91n
d alpha 92 92n
d null 93 93n
hrk d reprint 94 94n
hrk2 d cod 95 95n
d skip 99 99n
¹*
d @msg ds 42
d type 1 1
d #ord# 2 7
d #sufx 8 9
d #filler 10 42
¹*
¹*---------------------------------------------------------*
¹* Constants *
¹*---------------------------------------------------------*
¹*
d cutting c const('CUTTING CHARGE')
d extrus c const('EXTRUS')
d extrusset c const('EXTRUS SET')
d nonstock c const('NONSTOCKTRACK')
hrk4 d omit c const('TRKOMT')
d rod c const('ROD-')
d rollbatt c const('ROLLER BATTEN')
d track c const('TRK')
d trk_riser c const('TRK RISER')
¹*
¹* Component Comment Lines
hrk2 *consist c const('CONSISTING OF')
hrk2 *consst2 c const('.............................+
hrk2 * .....................')
¹*
¹*---------------------------------------------------------*
¹* Stand-Alone Fields *
¹*---------------------------------------------------------*
¹*
d item1 s 5 2 inz(.01)
d item2 s 5 2 inz(.02)
d note_type s 2
d null_date s d datfmt(*iso)
d ordtxt s 8s 0 inz
hrk2 d order# s 6s 0 inz
d single_ord s n inz(*off)
hrk2 d suffix s 2s 0 inz
d suffix1 s 2s 0 inz(-1)
hrk3 d svcomponent s like(o6item)
d svcust s like(o4stky)
hrk3 d svitem s 3s 0
d svitem05 s like(o6item)
d svitem06 s like(o6item)
d svord# s like(o6ord#)
d svparent s like(odpn)
d svsufx s like(o6sufx)
d svprod s like(odpn)
d sv_item s like(o6item)
hrk2 d sv_item6 s like(o6item)
¹*
¹* Date Work Fields
d mdy_date s d datfmt(*mdy)
d prtdate s d datfmt(*iso)
d reqdate s d datfmt(*iso)
d today s d datfmt(*iso)
d today_min1 s d datfmt(*iso)
¹*
¹*---------------------------------------------------------*
¹* Key Lists *
¹*---------------------------------------------------------*
¹*
¹* NF Key List (Type, Numb)
c k_nf klist
c kfld note_type
c kfld odcarr
¹*
¹* O2 Key List (Ord#, Sufx, Item) - Bill To Override
c k_o2bill klist
c kfld order#
c kfld suffix1
c kfld item2
¹*
¹* O2 Key List (Ord#, Sufx, Item) - Ship To Override
c k_o2 klist
c kfld order#
c kfld suffix1
c kfld item1
¹*
¹* O4 Key List (Ord#, Sufx, Item)
c k_o4 klist
c kfld order#
c kfld suffix
¹*
¹* O5 Key List (Ord#, Sufx, Item)
c k_o5 klist
c kfld order#
c kfld suffix
c kfld svitem05
¹*
¹* O605 Key List (BkyY, Ord#, Sufx, Pn)
c k_o6 klist
c kfld svord#
c kfld svsufx
c kfld svitem06
¹*
¹* O605 Key List (BkyY, Ord#, Sufx, Pn)
c k_o605 klist
c kfld o4ord#
c kfld o4sufx
¹*
¹*---------------------------------------------------------*
¹* Mainline - Main Processing *
¹*---------------------------------------------------------*
¹*
c dou %eof(o4)
¹*
c read o4
c if not %eof(o4)
c k_o605 setll o605
c read o605
c o4ord# chain oh
hrk c if odprtd <> *zeros
c eval prtdate = %date(odprtd: *mdy)
hrk C else
c eval prtdate = null_date
c end
¹*
c if prtdate >= today
c or @msg <> *blanks
hrk c if o4ffc1 = 'R'
hrk c eval reprint = *on
hrk c else
hrk c eval reprint = *off
hrk c end
c write rhead
c if @msg = *blanks
c eval order# = o4ord#
c eval suffix = o6sufx
c end
c exsr $header
c exsr $detail
hrk c else
hrk c iter
c end
c end
¹*
c if single_ord
c leave
c end
¹*
c enddo
¹*
c eval *inlr = *on
¹*
¹*---------------------------------------------------------*
¹* $Header - Set Up Header Fields *
¹*---------------------------------------------------------*
¹*
c $header begsr
¹*
c eval skip = *off
¹* Clear Ship To Fields
c clear sst#1
c clear sst#2
c clear sst#3
c clear sst#4
c clear sst#5
¹* Clear Sold To Fields
c clear sbt#1
c clear sbt#2
c clear sbt#3
c clear sbt#4
c clear sbt#5
¹*
¹* Get Sold To Info
c k_o2bill chain(e) o2
c if %found(o2)
c eval sbt#1 = odname
c if odadr2 <> *blanks
c eval sbt#2 = odadr2
c eval skip = *off
c else
c if not skip
c eval sbt#2 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if odadr3 <> *blanks
c eval sbt#3 = odadr3
c eval skip = *off
c else
c if not skip
c eval sbt#3 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if odadr4 <> *blanks
c eval sbt#4 = odadr4
c eval skip = *off
c else
c if not skip
c eval sbt#4 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if sbt#2 <> *blanks
c and sbt#3 <> *blanks
c and sbt#4 <> *blanks
c and not skip
c eval sbt#5 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *off
c else
c eval sbt#5 = *blanks
c end
c end
c if not %found(o2)
c ohbtky chain(e) cm1
c if %found(cm1)
c eval sbt#1 = cmname
c if cmlne1 <> *blanks
c eval sbt#2 = cmlne1
c eval skip = *off
c else
c if not skip
c eval sbt#2 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if cmlne2 <> *blanks
c eval sbt#3 = cmlne2
c eval skip = *off
c else
c if not skip
c eval sbt#3 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if cmlne3 <> *blanks
c and not skip
c eval sbt#4 = cmlne3
c eval skip = *off
c else
c if not skip
c eval sbt#4 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if sbt#2 <> *blanks
c and sbt#3 <> *blanks
c and sbt#4 <> *blanks
c and not skip
c eval sbt#5 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *off
c else
c eval sbt#5 = *blanks
c end
c else
c eval sbt#1 = *blanks
c eval sbt#2 = *blanks
c eval sbt#3 = *blanks
c eval sbt#4 = *blanks
c eval sbt#5 = *blanks
c end
c end
¹*
c eval skip = *off
¹* Get Ship To Info
c k_o2 chain(e) o2
c if %found(o2)
c eval sst#1 = odname
c if odadr2 <> *blanks
c eval sst#2 = odadr2
c eval skip = *off
c else
c if not skip
c eval sst#2 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if odadr3 <> *blanks
c eval sst#3 = odadr3
c eval skip = *off
c else
c if not skip
c eval sst#3 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if odadr4 <> *blanks
c eval sst#4 = odadr4
c eval skip = *off
c else
c if not skip
c eval sst#4 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *on
c end
c end
c if sst#2 <> *blanks
c and sst#3 <> *blanks
c and sst#4 <> *blanks
c and not skip
c eval sst#5 = %subst(odadr5: 1: 20) + ' ' +
c %subst(odadr5: 21)
c eval skip = *off
c else
c eval sst#5 = *blanks
c end
c end
c if not %found(o2)
c o4stky chain(e) cm1
c if %found(cm1)
c eval sst#1 = cmname
c if cmlne1 <> *blanks
c eval sst#2 = cmlne1
c eval skip = *off
c else
c if not skip
c eval sst#2 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if cmlne2 <> *blanks
c eval sst#3 = cmlne2
c eval skip = *off
c else
c if not skip
c eval sst#3 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if cmlne3 <> *blanks
c and not skip
c eval sst#4 = cmlne3
c eval skip = *off
c else
c if not skip
c eval sst#4 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *on
c end
c end
c if sst#2 <> *blanks
c and sst#3 <> *blanks
c and sst#4 <> *blanks
c and not skip
c eval sst#5 = cmcity + ' ' + cmst + ' ' + cmzip
c eval skip = *off
c else
c eval sst#5 = *blanks
c end
c end
c end
¹*
c eval order# = o4ord#
c eval suffix = o4sufx
c eval po# = ohspo#
c if ohentd <> *zeros
c *mdy move ohentd mdy_date
c move mdy_date p_ordd
c end
c if o6reqd <> *zeros
c eval mdy_date = %date(o6reqd: *mdy)
c move mdy_date p_shpd
c end
¹*
c eval note_type = 'CC'
¹* Get Carrier Name
c k_nf chain(e) nf
c if %found(nf)
c eval p_carr = nfdesc
c else
c eval p_carr = *blanks
c end
¹*
¹* Ship Via
c if odinst <> *blanks
c eval p_via = odinst
c else
c eval p_via = odvia
c end
¹*
¹* Barcode
hrk1 c eval ordertxt = %char(o4ord#)
hrk1 c + %editc(o6sufx: 'X')
¹*
¹* Verbiage '***COD***'
hrk2 c if %scan('COD': ohnot1) > *zeros
hrk2 c or %scan('COD': ohnot2) > *zeros
hrk2 c or %scan('COD': ohnot3) > *zeros
hrk2 c or %scan('COD': ohnot4) > *zeros
hrk2 c or %scan('COD': ohnot5) > *zeros
hrk2 c eval cod = *on
hrk2 c else
hrk2 c eval cod = *off
hrk2 c end
¹*
¹* Write Out Headings
c if not overflow
c write rheader
c write rhead2
c else
c exsr $overflow
c write rheader
c write rhead2
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $Detail - Setup Detail Fields *
¹*---------------------------------------------------------*
¹*
c $detail begsr
¹*
c clear svitem05
c clear svitem06
hrk3 c clear svcomponent
hrk3 c clear sv_item6
¹*
¹* Write any comments
c eval sv_item = item1
c exsr $o5comment
¹*
c dou o6ord# <> order#
c or o6sufx <> suffix
c or %eof(o605)
¹*
c exsr $desc
¹*
c if %scan(track: odpcc) > *zeros
c or %scan(track: pmdesc) > *zeros
c or %scan(extrus: pmdesc) > *zeros
c or %scan(rod: pmdesc) > *zeros
c or %scan(nonstock: odpn) > *zeros
c or %scan(cutting: odpn) > *zeros
c or %scan(rollbatt: pmdesc) > *zeros
¹*
¹* Skip and Extrus Set or TRK Riser Parts
c if %scan(extrusset: p_desc) = *zeros
c and %scan(trk_riser: p_desc) = *zeros
hrk4 c and pmusr3 <> omit
¹*
c if odxtrf = 'P'
c read o605
c iter
c end
¹*
¹* If Component Part, Get Parent #/Description/Comments
c if odxtrf = 'C'
c eval svcust = o4stky
c eval svord# = o4ord#
c eval svsufx = o4sufx
c eval svprod = odpn
hrk2 c eval svitem06 = sv_item
hrk2 c eval sv_item6 = o6item
¹*
¹* Find last component in kit
c dou odxtrf <> 'C'
c read o605
c if odxtrf <> 'C'
c readp o605
c eval svcomponent = o6item
c if o6item > sv_item6
c dou o6item = sv_item6
c readp o605
c enddo
c endif
c leave
c endif
c end
¹*
c exsr $parent
hrk2 c eval svitem06 = sv_item6
c k_o6 setll o605
c read o605
c exsr $desc
c end
¹*
c eval svitem06 = o6item
c eval sv_item6 = o6item
c eval p_wh = odloc#
c eval p_ordq = odbalq
c eval p_ords = odrelq
c eval p_ordb = odbalq - odrelq
c eval p_part# = odpn
c if odprmd <> *zeros
c eval mdy_date = %date(odprmd: *mdy)
c move mdy_date p_reqd
c end
¹*
¹* Write O6 Record
c exsr $o6write
¹*
¹* Write any line item comments
hrk3 c if o6item <> svcomponent
hrk3 c eval svitem05 = o6item
hrk3 c exsr $o5comment
hrk3 c end
¹*
c end
c end
¹*
c read o605
¹*
¹* Write any missed line item comments
hrk3 c if o6item > svcomponent
hrk3 c and svcomponent <> *zeros
hrk3 c readp o605
hrk3 c eval svitem05 = o6item
hrk3 c exsr $o5comment
hrk3 c read o605
hrk3 c end
¹*
c enddo
¹*
¹* Write any comments after all O6 Records
hrk3 c if svcomponent <> *zeros
hrk3 c readp o605
hrk3 c eval svitem05 = o6item
c exsr $o5comment
hrk3 c end
¹*
c if not %eof(o605)
c exsr $overflow
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $Desc - Get Part Description *
¹*---------------------------------------------------------*
¹*
c $desc begsr
¹*
¹* Get Part # Description
c odpn chain(e) pm
c if %found(pm)
c eval p_desc = pmdesc
c else
c eval p_desc = *blanks
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $Parent - Get Parent Part # *
¹*---------------------------------------------------------*
¹*
c $parent begsr
¹*
c dou odxtrf = 'P'
¹*
c readp o605
¹*
c if odxtrf = 'P'
c and svparent <> odpn
c eval p_wh = odloc#
c eval p_ordq = odorgq
c eval p_ords = odshpq
c eval p_ordb = odbalq
c eval p_part# = odpn
c if odprmd <> *zeros
c eval mdy_date = %date(odprmd: *mdy)
c move mdy_date p_reqd
c end
c exsr $desc
c eval svparent = odpn
c exsr $o6write
c eval svitem05 = o6item
c eval sv_item = o6item
c exsr $o5comment
c end
¹*
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $O6Write - Print o6 Detail Line(s) per Product *
¹*---------------------------------------------------------*
¹*
c $o6write begsr
¹*
c if not overflow
c write ro6p
c else
c write roflwp
c exsr $overflow
c write rheader
c write rhead2
c write ro6p
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $O5Comment - Print O5 Comment Line(s) (Per product) *
¹*---------------------------------------------------------*
¹*
c $o5comment begsr
¹*
hrk3 c eval svitem = o6item + 1
c k_o5 setll(e) o5
¹*
c dou o5ord# <> order#
c or o5sufx <> suffix
¹*
¹* Get Product Comment Lines
c read(e) o5
¹*
c if not %eof(o5)
c and o5ord# = order#
c and o5sufx = suffix
¹*
hrk3 c if (o5item > o6item
hrk3 c and o5item < sv_item6)
¹*
hrk3 c or (odxtrf = 'C'
hrk3 c and o5item > o6item
hrk3 c and o6item = svcomponent
hrk3 c and o5item = svcomponent + .5
hrk3 c and o5item < svitem)
¹*
hrk3 c or (odxtrf = *blanks
hrk3 c and o5item >= o6item + .5
hrk3 c and o5item < svitem
hrk3 c and sv_item6 <> *zeros)
¹*
hrk3 c or (o5item < 1)
¹*
c if not overflow
c write ro5p
c eval sv_item = o5item
c else
c write roflwp
c exsr $overflow
c write rheader
c write rhead2
c write ro5p
c eval sv_item = o5item
c end
¹*
c else
¹*
c eval sv_item = o5item
c leave
¹*
c end
¹*
c else
¹*
hrk2 c eval o5item = sv_item
c leave
¹*
c end
¹*
c end
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* $Overflow - Overflow *
¹*---------------------------------------------------------*
¹*
c $overflow begsr
¹*
c dou line = 66 or overflow
c write blank
c end
¹*
c write blank
c eval overflow = *off
¹*
c endsr
¹*
¹*---------------------------------------------------------*
¹* *InzSr - Initialization *
¹*---------------------------------------------------------*
¹*
c *inzsr begsr
¹*
c *entry plist
c parm @msg
¹*
c eval today = %date()
c clear svcust
c clear svitem05
c clear svitem06
c clear svord#
c clear svsufx
c clear svprod
¹*
c if #ord# <> *blanks
c testn #ord# 919293
c if numeric
c move #ord# order#
c else
c clear order#
c end
c testn #sufx 919293
c if numeric
c move #sufx suffix
c else
c clear #sufx
c end
c eval single_ord = *on
c k_o4 setll o4
c else
c eval single_ord = *off
c end
¹*
c endsr
¹*
| |
RPGLE - Example For Copy Book
Posted By: Sam400 Contact |
Copy Book Illustartion.
/* Main Program CBR1 */
FEMPCB UF A E DISK
C IF *IN55 = *ON
C* EVAL *INLR = *ON
C ENDIF
C IF *IN55 = *OFF
C EXSR T8
C ENDIF
C EXSR T9
C/COPY $CB1
C/COPY $CB2
C T8 BEGSR
C move 'X1' EMPID
C move 'X' EMPFN
C move 'XY' EMPLN
C WRITE RECCB
C EVAL *IN55 = *ON
C ENDSR
=======================================================
/* Copy Book CB$1 */
C**************************************************
c T9 begsr
c call 'CBR2'
c exsr T7
c endsr
C**************************************************
=======================================================
/* Copy Book CB$2 */
C**************************************************
c T7 begsr
c call 'CBR3'
C EVAL *INLR = *ON
c endsr
C**************************************************
=======================================================
/* Program CBR2 */
FEMPCB UF A E DISK
C DOW *IN45 = *OFF
C read EMPCB 45
C IF *IN45 = *ON
C EVAL *INLR = *ON
C ENDIF
C ENDDO
=======================================================
/* Program CBR2 */
FEMPCB UF A E DISK
C IF *IN65 = *OFF
C move 'X2' EMPID
C move 'A' EMPFN
C move 'AB' EMPLN
C WRITE RECCB
C EVAL *IN65 = *ON
C ENDIF
C EVAL *INLR = *ON
=======================================================
/* Physical File - EMPCB */
R RECCB
EMPID 10A
EMPFN 50A
EMPLN 50A
=======================================================
| |
RPGLE - Random
Posted By: Jaime López Patiño Contact |
dCOSEED s 5i 0
dCORNDNBR s 8f
dNUMGEN s 10i 0
dNUMERO s 3 0
*
c callb 'CEERAN0'
c parm COSEED
c parm CORNDNBR
c parm *omit
*
c eval NUMERO = CORNDNBR * 1000
c exsr F3EXIT
*
*================================================================
* Terminar programa
*================================================================
*
c F3EXIT begsr
*
*%.. terminate program
c eval *inlr = *on
*
c endsr
*
| |
RPGLE - the trigger for file
Posted By: xichun Wang Contact |
1,create file in dds
[code]
A R CUSREC TEXT('CLIENT')
A CUSNUM 6S 0 TEXT('CUST#')
A CUSIDX 6S 0 TEXT('INDEX')
A DFT(10)
A CUSNAM 30O TEXT('CUST NAME')
A CUSPHN 10O TEXT('CUST PHONE#')
A CUSSLS 4S 0 TEXT('CUSTS SALESPERSON')
A K CUSNUM
[/code]
2,create dtaara clientda:
CRTDTAARA DTAARA(WXC999/CLIENTDA) TYPE(*CHAR) LEN(6) VALUE('000006')
3,create rpgle:
[code]
DCLIENTDA DS Dtaara(CLIENTDA)
D Last# 6S 0
*
DpBefore S *
DpAfter S *
*
DBefore E DS ExtName(CLIENT) Prefix(B_)
D Based(pBefore)
DAfter E DS ExtName(CLIENT) Prefix(A_)
D Based(pAfter)
*---------------------------------------------------------------
* Trigger Buffer and Trigger Buffer Length Declarations
*---------------------------------------------------------------
DBufferLen S 10I 0
*
*
DTrigBuff DS
D TrigFile 10A
D TrigLib 10A
D TrigMbr 10A
D TrigEvent 1A
D TrigTime 1A
D TrigCommit 1A
D TrigRes1 3A
D TrigCCSID 10I 0
D TrigRRN 10I 0
D TrigRes2 4A
D TrigB4OS 10I 0
D TrigB4Len 10I 0
D TrigB4NBM 10I 0
D TrigB4NBL 10I 0
D TrigAftOS 10I 0
D TrigAftLen 10I 0
D TrigAfNBM 10I 0
D TrigAfNBL 10I 0
*-----------------------------------------------------------------
* Trigger Constants
*-----------------------------------------------------------------
D@Insert C '1'
D@Delete C '2'
D@Update C '3'
D@Before C '2'
D@After C '1'
*-----------------------------------------------------------------
* Input parameters are passed automatically when the trigger
* fires. Passed are the trigger buffer and trigger buffer length.
*-----------------------------------------------------------------
C *Entry PList
C Parm TrigBuff
C Parm BufferLen
*-----------------------------------------------------------------
* Map the data structures for the before and after images to
* the offset location in the trigger buffer using pointers.
*-----------------------------------------------------------------
C Eval pBefore = %Addr(TrigBuff) + TrigB4OS
C Eval pAfter = %Addr(TrigBuff) + TrigAftOS
*
*-----------------------------------------------------------------
* Only assign employee number on inserts.
*-----------------------------------------------------------------
C If TrigEvent = @Insert
*-----------------------------------------------------------------
C *Lock In CLIENTDA
C Eval LAST# = LAST# + 1
C Out CLIENTDA
C Eval A_CUSIDX = LAST#
C Endif
*
C Return
[/code]
4,create trigger for file
[code]ADDPFTRG FILE(EMPLOYEE) TRGTIME(*BEFORE)+
TRGEVENT(*INSERT) PGM(DB006R) ALWREPCHG(*YES)
[/code]
| |
RPGLE - To write the record count to the PF
Posted By: Nanda Kishore Perisetla Contact |
FRECCNT IF E DISK
FCOUNTF O E DISK
C* *ENTRY PLIST
C* PARM TFILE 10
C* PARM TCOUNT 10
C READ QWHFDMBR 40
C *IN40 DOWEQ*OFF
C MOVELMBFILE FILE
C MOVE MBNRCD COUNT
C WRITECOUNTFR
C READ QWHFDMBR 40
C ENDDO
C* MOVE TCOUNT TEMP 100
C* MOVELTFILE FILE
C* MOVE TEMP COUNT
C* WRITECOUNTFR
C SETON LR
| |
RPGLE - Free check for numberic in char field (FREE)
Posted By: bob cozzi Contact |
If %Check('0123456789': myField) > 0
// you have non-numeric data in the fields
Else
// the field is all numeric. It is okay!
Endif
| |
RPGLE - thank for you help
Posted By: WENGZHANGLIN Contact |
I am a beginner
| |
RPGLE - RPGLE Free format bit operation
Posted By: Tho Phan Contact |
¹*---------------------------------------------------------------------
¹*
¹* |0|1|2|3|4|5|6|7| One byte in OS400
¹*
¹* |0|1|2|3| |4|5|6|7| Divide into two for hex presenstation
* High order Low order
* bit bit
¹*
¹* |8|4|2|1| |8|4|2|1| Hex numerical number per bit
¹*
¹*
¹* | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |
¹* Decimal number per bit
¹* 1 6 3 1 8 4 2 1
¹* 2 4 2 6
¹* 8
¹*---------------------------------------------------------------------
¹*
¹* |1|0|0|0| |0|0|0|0| Bit 0 = x'80'
¹* or Bit 0 = 128
¹* |0|1|0|0| |0|0|0|0| Bit 1 = x'40'
¹* or Bit 1 = 64
¹* |0|0|1|0| |0|0|0|0| Bit 2 = x'20'
¹* or Bit 2 = 32
¹* |0|0|0|1| |0|0|0|0| Bit 3 = x'10'
¹* or Bit 3 = 16
¹* |0|0|0|0| |1|0|0|0| Bit 4 = x'08'
¹* or Bit 4 = 8
¹* |0|0|0|0| |0|1|0|0| Bit 5 = x'04'
¹* or Bit 5 = 4
¹* |0|0|0|0| |0|0|1|0| Bit 6 = x'02'
¹* or Bit 6 = 2
¹* |0|0|0|0| |0|0|0|1| Bit 7 = x'01'
¹* or Bit 7 = 1
¹* On & Off fields are defined as:
¹*
¹* Off s 1 Inz(x'00')
¹* On s 1 Inz(x'FF')
¹* Alpha s 1 Inz(x'F0')
¹* Pack s 1 inz(x'40')
¹*
¹*
¹*
¹* Test Bit 0 of Pack field for On
¹* If %BitAnd(Pack:x'80')=x'80'
¹* Or
¹* IF %BitAnd(Pack:128)=128 Numeric field
¹*
¹* Set bit 4 of field Alpha to On
¹* Alpha = %BitOr(Alpha:%BitAnd(On:x'08'))
¹* Alpha = %BitOr(Alpha:%BitAnd(x'FF':x'08'))
¹* Or
¹* Alpha = %BitOr(Alpha:%BitAnd(On:8)=8))
¹*
¹*
¹* If bit 0 of Pack field is On
¹* then set bit 4 of field Alpha to On
¹* If %BitAnd(Pack:x'80')=x'80'
¹* Alpha = %BitOr(Alpha:%BitAnd(On:x'08'))
¹* Endif
¹*
¹* Test Bit 1 for on
¹* *In01 = %BitAnd(Pack:x'40')=x'40'
¹* *In01 = %BitAnd(Pack:64)=64
¹* Or If bit 1 of pack field is On
¹* then set bit 5 of field Alpha to On
¹* Alpha = %BitOr(Alpha:%BitAnd(On:x'04'))
¹* Alpha = %BitOr(Alpha:%BitAnd(On:4)=4))
¹*
¹* Test Bit 2 for on
¹* *In01 = %BitAnd(Pack:x'20')=x'20'
¹* *In01 = %BitAnd(Pack:32)=32
¹* Or If bit 2 of pack field is On
¹* then set bit 6 of field Alpha to On
¹* Alpha = %BitOr(Alpha:%BitAnd(On:x'02'))
¹* Alpha = %BitOr(Alpha:%BitAnd(On:2)=2))
¹*
¹* Test Bit 3 for on
¹* IF %BitAnd(Pack:x'10')=x'10'
¹* IF %BitAnd(PacK:16)=16
¹* If bit 3 of pack field is On
¹* then set bit 7 of field Alpha to On
¹* Alpha = %BitOr(Alpha:%BitAnd(On:x'01'))
¹* Alpha = %BitOr(Alpha:%BitAnd(On:1)=1))
¹*
¹* Summary:
¹* Bit Off operation
¹* Off defined as x'00'
¹*
¹* Bit Off bit 4 of Alpha field
¹* Alpha = %BitAnd(Alpha:8=(%BitAnd(Off:x'01')=x'01'))
¹* Alpha = %BitAnd(Alpha:8=(%BitAnd(x'00':x'01')=x'01'))
¹* Or
¹* Alpha = %BitOr(Alpha:8=(%BitOr(Off:1)=1))
¹* Alpha = %BitOr(Alpha:8=(%BitOr(x'00':1)=1))
¹*
¹*
¹* Bit On operation
¹* On defined as x'FF'
¹*
¹* Bit On bit 4 of Alpha field
¹* Alpha = %BitAnd(Alpha:8=(%BitAnd(On:x'01')=x'01'))
¹* Alpha = %BitAnd(Alpha:8=(%BitAnd(x'FF:x'01')=x'01'))
¹* Or
¹* Alpha = %BitOr(Alpha:8=(%BitOr(On:1)=1))
¹* Alpha = %BitOr(Alpha:8=(%BitOr(x'FF':1)=1))
¹*
¹* Test Bit operation
¹* Test Bit 0 of Pack field for On
¹* If %BitAnd(Pack:x'80')=x'80'
¹* Or
¹* IF %BitAnd(Pack:128)=128
¹*
d A s 1 Inz(x'F0')
d Off s 1 Inz(x'00')
d On s 1 Inz(x'FF')
d Pack s 1 inz(x'40')
¹*
/Free
If %Bitand(Pack:x'80')=x'80';
// If bit 0 of Pack is On
A = %BitOr(A:%bitand(On:x'08'));
// Then set bit 4 of Alpha to On
EndIf;
If %Bitand(Pack:x'40')=x'40';
// If bit 1 of Pack is On
A = %BitOr(A:%bitand(On:x'04'));
// Then set bit 5 of Alpha to On
EndIf;
If %Bitand(Pack:x'20')=x'20';
// If bit 2 of Pack is On
A = %BitOr(A:%bitand(On:x'02'));
// Then set bit 6 of Alpha to On
EndIf;
If %Bitand(Pack:x'10')=x'10';
// If bit 3 of Pack is On
A = %BitOr(A:%bitand(On:x'01'));
// Then set bit 7 of Alpha to On
EndIf;
Return;
/End-Free
¹******************************************
| |
RPGLE - Update dataarea from within RPG program
Posted By: jimmy octane - dataarea update Contact |
*=================================================================
* data area somespace is created in QTEMP for the example
* This program takes in a 256 char string of data from a dataarea
* then it breaks the fields up using a data-structure and then
* updates info in the dataarea usind the data-structure and the
* OUT opcode.
*==================================================================
*
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
*
* Variable Definition
*
d AreaName s 10 inz('SomeSpace')
d CmdString s 256
d CmdLength s 15 5
d Q s 1 inz('''')
d TodayIso s D
*
* you may also use a physical file to define the
* fields rather than defining them in
* the program.
*
d**>somespace e ds extname(DTAAPF)
*
* else it would look like this
*
d someSpaceDS ds 256 dtaara(SomeSpace)inz
d PgmUser 10
d PgmDate 8 0
d PgmTime 6 0
d PgmSeq 7 0
d Therest 225
*
* ================================================
* M A I N L I N E
* ================================================
*
* Create the data area in qtemp
* CRTDTAARA DTAARA(QTEMP/DATAAREA) TYPE(*CHAR) LEN(256) TEXT('test data area')
*
c eval CmdString = 'CRTDTAARA DTAARA(QTEMP/'+
c %trim(AreaName) + ' ) TYPE(*CHAR) LEN(256)' +
c ' TEXT(' + Q + 'test data area' + Q + ')'
c eval CmdLength = %len(%trim(CmdString))
c call(e) 'QCMDEXC'
c parm CmdString
c parm CmdLength
*
* get the info from the data area - we lock it cause we are going to
* update
*
c *lock in somespaceDs
*
* populate the data structure
*
c if PgmUser = *blanks
c clear PgmSeq
c endif
*
c eval PgmUser = @User
c eval TodayIso = %date()
c clear PgmDate
c eval PgmDate =
c %uns(%char(%Date():*Iso0))
*
c clear PgmTime
c time PgmTime
*
* Increment the counter
*
c eval PgmSeq += 1
*
c out somespaceDs
*
c eval *INLR = *on
| |
RPGLE - Blok
Posted By: mykotaksurat@yahoo.com Contact |
‚***---------------------------------------------------------------------------------------***€
‚***€ Program Name :CHKBLO ‚***€
‚***€ Description :CHECK BLOCK PROCESSING ‚***€
‚***€ Date created :12/03/2005€ ‚***€
‚***€ Created by :Puji € ‚***€
‚***---------------------------------------------------------------------------------------***€
‚***€ ‚***€
‚***€ Modification logs :€ ‚***€
‚***€ ‚***€
‚***€ Init€Ref.#€Date€ Description € ‚***€
‚***---------------------------------------------------------------------------------------***€
FSSPARO IF E K DISK
F
C
C BLOKEY KLIST
C KFLD NWPROG
C KFLD WHFNAM
C
C *ENTRY PLIST
C PARM NWPROG 10
C PARM WHFNAM 10
C PARM FLAG 1
C
C BLOKEY CHAIN RSSPARO 88
C IF *IN88 = *OFF
C MOVE 'Y' FLAG
C ELSE
C MOVE *BLANKS FLAG
C ENDIF
C
C MOVE '1' *INLR
C RETURN
| |
RPGLE - Generate random number
Posted By: Scott Klement Contact |
Q: I need the simplest code possible for selecting a random
number between 2 given numbers. It should be ILE RPG code,
if possible. National security is NOT involved, so it doesn't
have to be fool-proof... just easy enough for a fool to
understand, and use!
A: RPG does not have built-in support for random numbers, but
there are several ways to generate them with APIs. The one
that's probably the easiest is the CEERAN0 API.
(Note that the API name ends with the number zero, not the letter O!)
This API generates a random number between 0 and 1, exclusive.
That may sound strange at first, but if you stop to think
about it, it's actually quite convenient. Think about this:
If you multiply any number by 0, it'll result in 0. If
you multiply any number by 1, it'll result in the
number that you started with. Therefore, if you multiply
by a random number in-between, the result will be a random
number between and the number you started with.
See? It's convenient.
For example, let's say that you wanted to simulate rolling dice.
Typical dice have six sides, each side containing a number
from one to six.
To do that, calculate a random number using CEERAN0.
Multiply the result by 6. The result will be a number
between 0 and 6, exclusive. "Exclusive" means that 0 and 6
will never occur... you'll get a number
between 0.000000001 and 5.99999999. Next, use the %int()
BIF to chop off the fraction, so that you'll have a random
number between 0 and 5. Finally, add 1 and the random number
will be between 1 and 6.
In RPG, you'd code this as follows:
H DFTACTGRP(*NO) ACTGRP('QILE')
D CEERAN0 PR
D seed 10I 0
D ranno 8F
D fc 12A options(*omit)
D seed s 10I 0 inz(0)
D rand s 8F
D result s 5P 0
/free
CEERAN0( seed : rand : *omit );
result = %int(rand * 6) + 1;
// "result" now contains a number between 1 and 6.
return;
/end-free
That same algorithm can be used to calculate a number between two
arbitrary numbers. Just use variables for the upper and lower ends
of the range. The following code demonstrates this by receiving
parameters called LOWNO and HIGHNO. It returns the result in a
third parameter called RESULT:
H DFTACTGRP(*NO) ACTGRP('QILE')
D RANDOM PR extpgm('RANDOM')
D lowno 5P 0 const
D highno 5P 0 const
D result 5P 0
D RANDOM PI
D lowno 5P 0 const
D highno 5P 0 const
D result 5P 0
D CEERAN0 PR
D seed 10I 0
D ranno 8F
D fc 12A options(*omit)
D seed s 10I 0 inz(0)
D rand s 8F
D range s 5P 0
/free
range = (highno - lowno) + 1;
CEERAN0( seed : rand : *omit );
result = %int(rand * range) + lowno;
return;
/end-free
Random numbers on computers are generated by an equation.
When the equation has the same input value, it'll always give
the same results. To make them seem random, we use a seed value.
Therefore it's important that the seed value is different every
time you call this API.
For CEERAN0, if you pass a seed of 0, the API will generate a
seed from the current time. That way, it will be different each
time the program is called. CEERAN0 will output a new seed that
can be used to help randomize subsequent calls.
If you look closely at the examples above, you'll see that they
don't set on *INLR. The reason for this is that the program will
remain in memory and it will retain the seed value. That way, if
you call it again, it'll use the seed value that was retained
from the previous call.
| |
RPGLE - Generate a Random Rumber
Posted By: Randy Weber Contact |
ˆˆ /Title Generate a "Random" NumberŠ...€
ˆH Debug NoMain
// *----------------------------------------------------------------*
// *‚ Precision Sytems, Inc. € *
// *----------------------------------------------------------------*
// * *
// * System name. . :‚ *Any € *
// * Module/Program :‚ GETRANDNUM € *
// * Text . . . . . :‚ Generate a "Random" Number € *
// * Author . . . . :‚ Randy Weber € *
// * ‚ PrecisionSystems@comcast.net € *
// * *
// * Remarks . . . : This module uses SQL to retrieve a *
// * random number using the Microseconds *
// * portion of the current timestamp to *
// * seed the SQL RAND routine. *
// * *
// * €„Parameters:€ *
// * 1. Random - Packed 9,8 *
// * *
// * €„Sample Create Command€ *
// * *
// * CRTSQLRPGI *
// * OBJ(MyLib/GETRANDNUM) *
// * SRCFILE(MyLib/QRPGLESRC) *
// * SRCMBR(GETRANDNUM) *
// * COMMIT(*NONE) *
// * OBJTYPE(*MODULE) *
// * REPLACE(*YES) *
// * DBGVIEW(*SOURCE) *
// * *
// * €„Sample GETRANDNUM Usage€ *
// * *
// * // ‚Random number interface€ *
// * D GetRandNum PR 9P 8 *
// * *
// * D Random S 9P 8 *
// * *
// * // ‚Free-form calc specs€ *
// * Random = GetRandNum() ; *
// * *
// * *
// *----------------------------------------------------------------*
//‚Module interface
D GetRandNum PR 9P 8
ˆ /Title Use SQL to Get a Random NumberŠ...€
// ‚***********************************************************
P GetRandNum B Export
// ‚***********************************************************
D GetRandNum PI 9P 8
// ‚Stand Alone Fields
D Random S 9P 8
C Eval Random = *Zeros
// ‚Run the SQL statement
C/EXEC SQL
C+
C+ SELECT Dec(
C+ Rand(
C+ Int(
C+ Substr(
C+ Char(Current_TimeStamp),21,6
C+ )
C+ )
C+ ),9,8
C+ ) Into :Random
C+ FROM QsqpTabl With NC
C+
C/END-EXEC
C Eval Random = %Abs(Random)
C Return Random
P GetRandNum E
ˆˆ /Title Generate a "Random" NumberŠ...€
| |
RPGLE - what is opnqry?where we can use it in real time
Posted By: jagadesh Contact |
| |
RPGLE - Use Data Structures to change the date format
Posted By: Les Contact |
I know not many shops still have legacy dates stored in numeric fields
in stead of true dates (I wish.) But I have always hated to use
C ADATE MULT 10000.01 FIELD1 FIELD2
to change the format. So I do this instead.
D date_fmt ds
D ymd 1 8 0
D yr1 1 4 0
D mm 5 6 0
D dd 7 8 0
D yr2 9 12 0
D mdy 5 12 0
*********************************************
* Date Format Change Subroutine - MDY > YMD *
*********************************************
C mdy2ymd begsr
*
C eval mdy = my_mdy_field
C eval yr1 = yr2
C eval my_ymd_field = ymd
*
C endsr
empty data structure
,--YMD--,
,--MDY--,
YR1 MMDDYR2
00000000000
MDY loaded with date
,--MDY--,
YR1 MMDDYR2
000007132005
yr1 set to yr2
YR1 MMDDYR2
200507132005
YMD now loaded
,--YMD--,
YR1 MMDDYR2
200507132005
I hope some one finds this useful.
| |
RPGLE - Using API QWDLSJBQ to list job queue entries for a subsystem
Posted By: Pieter Henrico Contact |
The following RPGLE source code uses API QWDLSJBQ to retrieve the job queue entries for a subsystem. The
source code does not do anything with the info yet (like writing it out to a file), but just export all the
information to a userspace, and then run in a loop through the user space.
*
* Program Name: RTVJOBQE#R
* Author : Pieter Henrico
* Date : 2005/7/14
* Description : Retrieve Job Queue Entries from a Subsystem description
*
*
*
* API generic Header
*
DJobQEInfo DS
D JQInitStart 10i 0 inz(113)
D JQInitLength 10i 0 inz(28)
D JQReserved1 10i 0 inz(0)
D JQRecStart 10i 0 inz(0)
D JQReserved2 10i 0 inz(0)
D JQTotalNbr 10i 0 inz(0)
D JQRecLength 10i 0 inz(0)
*
* API Error Structure
*
DApiError DS
D apierrprv 1 4b 0 INZ(67)
D apierrrcv 5 8b 0
D apierrid 9 15
D apierrpdt 16 67
*
* Data structure to use with retrieved JOBQ Entries
*
D JobQEntryList ds
D JobQName 1 10
D JobQLib 11 20
D JobSeqNbr 21 24B 0
D JobAlcNbr 25 34
D Reserved1 35 36
D JobMaxAct 37 40B 0
D JobPrio1 41 44B 0
D JobPrio2 45 48B 0
D JobPrio3 49 52B 0
D JobPrio4 53 56B 0
D JobPrio5 57 60B 0
D JobPrio6 61 64B 0
D JobPrio7 65 68B 0
D JobPrio8 69 72B 0
D JobPrio9 73 76B 0
*
* User space parameters
*
D USpaceName s 20 inz('LSTJOBQE QTEMP ')
D USpaceDesc s 50 inz('Job queue Entries ')
D USpaceEnt s 10 inz('*ALL')
D USpaceFmt s 10 inz('SJQL0100')
D USpaceHDL s 16 inz(' ')
D USpaceInf s 10i 0 inz(0) dim(7)
D USpaceINI s 1
D USpaceAttr s 10
D USpaceAut s 10
D USpaceRPL s 10
D USpaceISize s 9b 0 inz(65536)
C *Entry PList
C Parm SBSName SBSName 20
*
* Delete user space
*
C call 'QUSDLTUS' DLTUSRSPC
C parm USpaceName
C parm ApiError
*
* Create user space
*
C call 'QUSCRTUS' CRTUSRSPC
C parm USpaceName
C parm 'RTVJOBQ' USpaceAttr
C parm USpaceISize
C parm ' ' USpaceINI
C parm '*ALL' USpaceAut
C parm USpaceDesc
C parm '*YES' USpaceRpl
C parm ApiError
*
* List Job Queue Entries
*
C call 'QWDLSJBQ' Entries
C parm USpaceName
C parm USpaceFmt
C parm SbsName
C parm ApiError
*
* Get user space properties
*
C call 'QUSRTVUS'
C parm USpaceName
C parm JQINitStart
C parm JQInitLength
C parm JobQEInfo Basic info
*
C eval JQRecStart = JQRecStart + 1 First entr
*
* Loop over the user space entries
*
C 1 do JQTotalNbr
*
C call 'QUSRTVUS'
C parm USpaceName
C parm JQRecStart Position
C parm JQRecLength Length
C parm JobQEntryList
*
C eval JQRecStart = JQRecStart + JQRecLength
*
C enddo
*
C eval *inlr = *on
*
| |
RPGLE - rpgle programs
Posted By: nitin gupta Contact |
| |
RPGLE - find and replace
Posted By: jimmy octane Contact |
We submit jobs from within RPG programs, so finding an easier way to insert the parameters in the submit
string would help, which lead to creating FindReplace. The procedure finds the specified value and replaces it
with the supplied string. Only the first occurrence is changed and capitalization is ignored. This procedure
eliminated the need to worry about array locations, concatenating strings, changes to the string messing up
substitutions, etc. (the target, " ((Content component not found.)) ", could be any sequence of characters).
We're finding new uses for this every day.
D CM S 80 ctdata
perrcd(1) dim(1)
* Change all occurrences of FIND to REPLACE in SOURCE
d FindReplace pr 1024
d Source 1024 varying value
d Find 255 varying value
d Replace 255 varying value
c eval target=findreplace(
c cm(1)
c :' ((Content component not found.)) '
c :'January'
c )
c eval *inlr=*on
* Change 1st occurrence of FIND to REPLACE in SOURCE
p FindReplace b
d pi 1024
d Source 1024 varying value
d Find 255 varying value
d Replace 255 varying value
d Work s like(Source)
c eval Work = Source
c if %scan(Find:Work) > 0
c eval Work = %replace(Replace
c :Work
c :%scan(Find:Work)
c :%len(Find)
c )
c endif
c return Work
p e
** SUBMIT COMMAND ARRAY CM
SBMJOB CCCHECKSOK CDAJOBD CMD(CALL CC0012 PARM(' ((Content component not found.)) '))
| |
RPGLE - RPG/RPGLE
Posted By: pbj Contact |
| |
RPGLE - Calculate date of yesterday
Posted By: Josef Kindl Contact |
DYESTR S D DATFMT(*ISO)
C *ENTRY PLIST
C YESTR PARM YESTR
C MOVEL *DATE YESTR
C YESTR ADDDUR -1:*DAYS YESTR
C RETURN
| |
RPGLE - types of array
Posted By: srinivasareddy Contact |
complile time array,run time array and pre run time array programming examples
| |
RPGLE - Display file field attributes without indicators
Posted By: Stuart Payne Contact |
* A snap shot of the screen file.
A DSPSIZ(24 80 *DS3)
A CA03
A CA06
A R I5541081 TEXT('Header Record 1')
*
A OVERLAY
A 1 28'Enter Branch'
A 3 2'Branch'
A BRANCH 12 B 3 9DSPATR(&BRANCHATTR)
A BRANCHATTR 1 P
*
A R I5541082 TEXT('Bottom Line')
A OVERLAY
A MSGLINE 78 O 24 2DSPATR(&MSGLINEATT)
A MSGLINEATT 1 P
// Copy book of display attributes
// Will not work for MDT (Set changed data tag when displayed),
// OID (Operator identification),
// PC (Position Cursor) or
// SP (Select by light pen)
// Valid P-field values Non-protected for display files
// Ledgend: Bl - Blink, Cs - Column separator, HI - High intensity,
// RI - Revers image, and Un - Underscore
// Colors: B - Blue, G - Green, R - Red, P - Pink, T - Turquoise,
// W - White, and Y - Yellow
// Non protected fields.
D NP_Normal c x'20' Green
D NP_RI c x'21' Green
D NP_HI c x'22' White
D NP_HI_RI c x'23' White
D NP_Un c x'24' Green
D NP_Un_RI c x'25' Green
D NP_Un_HI c x'26' White
D NP_Nondisplay1 c x'27' Nondisplay
D NP_Bl c x'28' Red
D NP_Bl_RI c x'29' Red
D NP_Bl_HI c x'2A' Red
D NP_Bl_HI_RI c x'2B' Red
D NP_Bl_Un c x'2C' Red
D NP_Bl_Un_RI c x'2D' Red
D NP_Bl_Un_HI c x'2E' Red
D NP_Nondisplay2 c x'2F' Non display
D NP_Cs c x'30' Turquoise
D NP_RI_Cs c x'31' Turquoise
D NP_HI_Cs c x'32' Turquoise
D NP_HI_RI_Cs c x'33' Turquoise
D NP_Un_Cs c x'34' Turquoise
D NP_Un_RI_Cs c x'35' Turquoise
D NP_Un_HI_Cs c x'36' Turquoise
D NP_Nondisplay3 c x'37' Nondisplay
D NP_Bl_Cs c x'38' Pink
D NP_Bl_RI_Cs c x'39' Pink
D NP_Bl_HI_Cs c x'3A' Blue
D NP_Bl_HI_RI_Cs c x'3B' Blue
D NP_Bl_Un_Cs c x'3C' Pink
D NP_Bl_Un_RI_Cs c x'3D' Pink
D NP_Bl_Un_HI_Cs c x'3E' Pink
D NP_Nondisplay4 c x'3F' Nondisplay
// Valid P-field values for Protected display files
D P_Normal c x'A0' Green
D P_RI c x'A1' Green
D P_HI c x'A2' White
D P_HI_RI c x'A3' White
D P_Un c x'A4' Green
D P_Un_RI c x'A5' Green
D P_Un_HI c x'A6' White
D P_Nondisplay1 c x'A7' Nondisplay
D P_Bl c x'A8' Red
D P_Bl_RI c x'A9' Red
D P_Bl_HI c x'AA' Red
D P_Bl_HI_RI c x'AB' Red
D P_Bl_Un c x'AC' Red
D P_Bl_Un_RI c x'AD' Red
D P_Bl_Un_HI c x'AE' Red
D P_Nondisplay2 c x'AF' Non display
D P_Cs c x'B0' Turquoise
D P_RI_Cs c x'B1' Turquoise
D P_HI_Cs c x'B2' Turquoise
D P_HI_RI_Cs c x'B3' Turquoise
D P_Un_Cs c x'B4' Turquoise
D P_Un_RI_Cs c x'B5' Turquoise
D P_Un_HI_Cs c x'B6' Turquoise
D P_Nondisplay3 c x'B7' Nondisplay
D P_Bl_Cs c x'B8' Pink
D P_Bl_RI_Cs c x'B9' Pink
D P_Bl_HI_Cs c x'BA' Blue
D P_Bl_HI_RI_Cs c x'BB' Blue
D P_Bl_Un_Cs c x'BC' Pink
D P_Bl_Un_RI_Cs c x'BD' Pink
D P_Bl_Un_HI_Cs c x'BE' Pink
D P_Nondisplay4 c x'BF' Nondisplay
// Basic Code
FV5541080 cf E workstn InfDS(Ws_Ds)
D error s n inz('0')
D msgBranch c 'Enter the Branch Plant F3 = Exit'
D msgBranchInv c 'The branch is invalid. Please re-
D enter. F3 = Exit'
D msgF3Exit c 'F3 = Exit'
// if the default branch doesn't exist then have the user enter it on
msgLine = msgBranch;
msgLineAtt = P_HI;
branchAttr = Np_Un;
dou dfltBranch <> *blanks and error = *off;
error = *off;
write I5541082;
exfmt I5541081;
if cmd_Key = F3;
*inlr = *on;
return;
endIf;
evalR branch = %trim(branch);
evalr dfltBranch = branch;
if dfltBranch = *blanks;
iter;
endIf;
// verify that the branch entered is valid
error = verifyBranch(dfltBranch);
if error;
msgLine = msgBranchInv;
msgLineAtt = P_Hi;
branchAttr = Np_Un_RI;
endIf;
endDo;
| |
RPGLE - commit
Posted By: deepa.v Contact |
pgm for 2phase commit , ddmf under commit
| |
RPGLE - Digital clock
Posted By: Pavan Kumar Pokala Contact |
DIGITAL CLOCK
********************************************************************8
main cl program to show clock NAME---CLKCL
*********************************************************************
PGM
DCLF FILE(CLK) RCDFMT(*ALL)
DCL VAR(&HR) TYPE(*CHAR) LEN(2)
DCL VAR(&MIN) TYPE(*CHAR) LEN(2)
DCL VAR(&SEC) TYPE(*CHAR) LEN(2)
DCL VAR(&COL1) TYPE(*CHAR) LEN(1)
DCL VAR(&COL2) TYPE(*CHAR) LEN(1)
DCL VAR(&COL3) TYPE(*CHAR) LEN(1)
DCL VAR(&COL4) TYPE(*CHAR) LEN(1)
DCL VAR(&COL5) TYPE(*CHAR) LEN(1)
DCL VAR(&COL6) TYPE(*CHAR) LEN(1)
AGAIN:
RTVSYSVAL SYSVAL(QHOUR) RTNVAR(&HR)
RTVSYSVAL SYSVAL(QMINUTE) RTNVAR(&MIN)
RTVSYSVAL SYSVAL(QHOUR) RTNVAR(&HR)
RTVSYSVAL SYSVAL(QMINUTE) RTNVAR(&MIN)
RTVSYSVAL SYSVAL(QSECOND) RTNVAR(&SEC)
CHGVAR VAR(&COL1) VALUE(%SST(&HR 1 1))
CHGVAR VAR(&COL2) VALUE(%SST(&HR 2 1))
CHGVAR VAR(&COL3) VALUE(%SST(&MIN 1 1))
CHGVAR VAR(&COL4) VALUE(%SST(&MIN 2 1))
CHGVAR VAR(&COL5) VALUE(%SST(&SEC 1 1))
CHGVAR VAR(&COL6) VALUE(%SST(&SEC 2 1))
CALL PGM(NARESH/CLKLE) PARM(&COL1 &COL2 &COL3 +
&COL4 &COL5 &COL6 &IN50 &IN51 &IN52 &IN53 +
&IN54 &IN55 &IN56 &IN57 &IN58 &IN59 &IN60 +
&IN61 &IN62 &IN63 &IN64 &IN65 &IN66 &IN67 +
&IN68 &IN69 &IN70 &IN71 &IN72 &IN73 &IN74 +
&IN75 &IN76 &IN77 &IN78 &IN79 &IN80 &IN81 +
&IN82 &IN83 &IN84 &IN85 &IN86 &IN87 &IN88 +
&IN89 &IN90 &IN91)
SNDRCVF RCDFMT(DIG) WAIT(*NO)
MONMSG MSGID(CPF0887) EXEC(GOTO CMDLBL(ENDJOB))
DLYJOB DLY(1)
IF COND(&IN03 *EQ '1') THEN(GOTO CMDLBL(ENDJOB))
GOTO CMDLBL(AGAIN)
ENDJOB: ENDPGM
***********************************************************************************8
rpg le program name -- CLKLE
************************************************************************************
FCLKPF IF E K DISK
C *ENTRY PLIST
C PARM I1 1
C PARM I2 1
C PARM I3 1
C PARM I4 1
C PARM I5 1
C PARM I6 1
C PARM J50 1
C PARM J51 1
C PARM J52 1
C PARM J53 1
C PARM J54 1
C PARM J55 1
C PARM J56 1
C PARM J57 1
C PARM J58 1
C PARM J59 1
C PARM J60 1
C PARM J61 1
C PARM J62 1
C PARM J63 1
C PARM J64 1
C PARM J65 1
C PARM J66 1
C PARM J67 1
C PARM J68 1
C PARM J69 1
C PARM J70 1
C PARM J71 1
C PARM J72 1
C PARM J73 1
C PARM J74 1
C PARM J75 1
C PARM J76 1
C PARM J77 1
C PARM J78 1
C PARM J79 1
C PARM J80 1
C PARM J81 1
C PARM J82 1
C PARM J83 1
C PARM J84 1
C PARM J85 1
C PARM J86 1
C PARM J87 1
C PARM J88 1
C PARM J89 1
C PARM J90 1
C PARM J91 1
C KEY1 KLIST
C KFLD TST 1
C MOVEL I1 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J50
C MOVE A2 J51
C MOVE A3 J52
C MOVE A4 J53
C MOVE A5 J54
C MOVE A6 J55
C MOVE A7 J56
C MOVEL I2 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J57
C MOVE A2 J58
C MOVE A3 J59
C MOVE A4 J60
C MOVE A5 J61
C MOVE A6 J62
C MOVE A7 J63
C MOVEL I3 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J64
C MOVE A2 J65
C MOVE A3 J66
C MOVE A4 J67
C MOVE A5 J68
C MOVE A6 J69
C MOVE A7 J70
C MOVEL I4 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J71
C MOVE A2 J72
C MOVE A3 J73
C MOVE A4 J74
C MOVE A5 J75
C MOVE A6 J76
C MOVE A7 J77
C MOVEL I5 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J78
C MOVE A2 J79
C MOVE A3 J80
C MOVE A4 J81
C MOVE A5 J82
C MOVE A6 J83
C MOVE A7 J84
C MOVEL I6 TST
C KEY1 CHAIN CLKPF
C MOVE A1 J85
C MOVE A2 J86
C MOVE A3 J87
C MOVE A4 J88
C MOVE A5 J89
C MOVE A6 J90
C MOVE A7 J91
c RETURN
**********************************************************************************
physical file required NAME---CLKPF
***********************************************************************************
A R REC1
A A11 1A
A A1 1A
A A2 1A
A A3 1A
A A4 1A
A A5 1A
A A6 1A
A A7 1A
A K A11
****************************************************************************
RECORDS IN ABOVE PF
****************************************************************************
A11 A1 A2 A3 A4 A5 A6 A7
0 1 1 1 1 1 1 0
1 0 0 1 0 0 1 0
2 0 1 1 1 1 0 1
3 0 1 1 0 1 1 1
4 1 0 0 0 0 1 1
5 1 1 0 0 1 1 1
6 1 1 0 1 1 1 1
7 0 1 1 0 0 1 0
8 1 1 1 1 1 1 1
9 1 1 1 0 1 1 1
******************************************************************************
DISPLAY FILE --- NAME --CLK
****************************************************************************
A*%%TS SD 20051117 135547 MUMTRG REL-V5R2M0 5722-WDS
A*%%EC
A DSPSIZ(24 80 *DS3)
A R DIG
A*%%TS SD 20051117 135547 MUMTRG REL-V5R2M0 5722-WDS
A CA03(03 'exit')
A 50 4 10'|'
A 51 3 11'___'
A 52 4 14'|'
A 53 6 10'|'
A 54 7 11'___'
A 55 6 14'|'
A 56 5 11'___'
A 57 4 16'|'
A 58 3 17'___'
A 59 4 20'|'
A 60 6 16'|'
A 60 6 16'|'
A 61 7 17'___'
A 62 6 20'|'
A 63 5 17'___'
A 64 4 22'|'
A 65 3 23'___'
A 66 4 26'|'
A 67 6 22'|'
A 68 7 23'___'
A 69 6 26'|'
A 70 5 23'___'
A 71 4 28'|'
A 72 3 29'___'
A 73 4 32'|'
A 74 6 28'|'
A 75 7 29'___'
A 76 6 32'|'
A 77 5 29'___'
A 78 4 34'|'
A 79 3 35'___'
A 80 4 38'|'
A 81 6 34'|'
A 82 7 35'___'
A 83 6 38'|'
A 84 5 35'___'
A 85 4 40'|'
A 86 3 41'___'
A 87 4 44'|'
A 88 6 40'|'
A 89 7 41'___'
A 90 6 44'|'
A 91 5 41'___'
*********************************************************************************************8
| |
RPGLE - Retrieving SFLPAG with QDFRTVFD API
Posted By: Sander P Contact |
********************************************************************
* APPLICATION DESCRIPTION :
* -------------------------
* This program retrieves the display file information with help of
* API QDFRTVFD
*
********************************************************************
* Compiler options: Default
*
********************************************************************
H NOMAIN
********************************************************************
* Data structures belonging to used API's *
********************************************************************
D/COPY QSYSINC/QRPGLESRC,QDFRTVFD
D/COPY QSYSINC/QRPGLESRC,QUSEC
*****************************************************************
* Prototype for Call to API QDFRTVFD
*****************************************************************
D QDFRTVFDx PR ExtPgm('QDFRTVFD') Named QDFRTVFDx 'cuz
D pRcvVar 32767A QDFRTVFD already is
D pRcvLen 10I 0 used as copymember
D pFormat 8A
D pQDspFil 20A
D pApiErrDs 7A
*
D pRcvVar S 32767A
D pRcvLen S 10I 0 Inz(%Size(pRcvVar))
D pFormat S 8A Inz('DSPF0100')
D pQDspFil S 20A
D pApiErrDs S 7A
P*================================================================
P* Procedure : GetSflPag
P* Purpose : Retrieves SFLPAG of diplay file
P* Conditions : Call with all parameters :
P* Parameter 1 : Dsiplay file (10A) and library name (10A)
P*================================================================
D GetSflPag PR 3P 0
D pDspFil 20A
P GetSflPag B EXPORT
D GetSflPag PI 3P 0
D pDspFil 20A
*****************************************************************
* Single fields
*****************************************************************
D hCount S 3S 0 Inz(1)
D hAlpha1 S 1A
D hSflPag S 3P 0
D hDFARFTE S 10I 0
D hDFFRINF S 10I 0
D hDFFSFCR S 10I 0
**************************************************************************
/Free
// Fill parameter
pQdspFil = pDspFil ;
// Retrieve display file description ( QDFRTVFD ) API
Callp QDFRTVFDx(pRcvVar:pRcvLen:pFormat:pQdspFil:QUsec) ;
// No Errors
If QUsbAvl = *Zeros ;
// Base file section
QDFFBASE = %SubSt(pRcvVar:1:%Size(QDFFBASE)) ;
// File header section
QDFFINFO = %SubSt(pRcvVar:QDFFINOF+1:%Size(QDFFINFO)) ;
hDFARFTE = QDFFINOF + 1 + QDFFDFLO ;
// Find SFLCTL record - Begin For Loop
For hCount = 1 to QDFFFRCS ;
// Record format table
QDFARFTE = %SubSt(pRcvVar:hDFARFTE:%Size(QDFARFTE)) ;
// Record header section
hDFFRINF = QDFFINOF + 1 + QDFARFOF ;
QDFFRINF = %SubSt(pRcvVar:hDFFRINF:%Size(QDFFRINF)) ;
// Check if SFLCTL record. If so, leave do loop.
If %BitAnd(%SubSt(QDFBITS09:1:1):x'20') = x'20' ;
Leave ;
EndIf ;
// Next record
hDFARFTE = hDFARFTE + 16 ;
EndFor ;
// Subfile control record start position
If %BitAnd(%SubSt(QDFBITS09:1:1):x'20') = x'20' ;
hDFFSFCR = hDFFRINF + QDFFRAOF ;
// Subfile control entry - SFLPAG !!
QDFFSFHR=%SubSt(pRcvVar
:hDFFSFCR+%Size(QDFFSFCR)
:%Size(QDFFSFHR));
hSflPag = QDFFSFPG ;
Return hSflPag ;
EndIf ;
EndIf ;
Return 0 ;
/End-free
P GetSflPag E
| |
RPGLE - Clear the field
Posted By: M.S.Sridhar Contact |
Clear CHLPRC prior to creating ‘-888’ part number in OELDETAL.
| |
RPGLE - SEU Line Commands
Posted By: Chamara Withanachchi Contact |
*----------------------------------------------------------------------
* SEULNCMDS - Program to process user-defined SEU line commands
*------------------------------------------------------------------------
* Author: Chamara Withanachchi
* Written: Dec. 02, 2005
*------------------------------------------------------------------------
* Currently supported line commands:
* LC - "L"ower"c"ase command will change all characters on selected line
* to lowercase.
* UC - "U"pper"c"ase command will change all characters on selected line
* to uppercase.
*------------------------------------------------------------------------
* Variable definitions
* pointers to user space
D pHeader s *
D pHeader2 s *
D pRtn s *
D pLine1 s *
D pLine s *
D pData s *
* data structures for accessing user space
* line command header info
D dsHeader ds based(pHeader2)
D hdRecLen 1 4b 0
D hdCsrRrn 5 8b 0
D hdCsrCol 9 12b 0
D hdNbrRecs 17 20b 0
D hdFuncKey 61 61a
D hdMode 62 62a
D hdSplit 63 63a
D hdRtnCd 65 65a
D hdRecsOut 69 72b 0
D hdSeqUpd 73 79a
* source code header info
D srcHdr ds Based(pLine)
D srcCmd 1 7a
D srcRtnCd 8 8a
D srcSeq 9 14a
D srcChgDt 15 20a
* actual souce code
D srcDta ds Based(pData)
D srcCode 1 999a
* Lowercase and uppercase strings
D lo c const('abcdefghijklmnopqrstuvwxyz')
D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
* comparison flags
D Yes c const('Y')
D No c const('N')
* work fields
D rec# s 10i 0
D wkCode s 999a
D hldCmd s 3a
D lastRec s 1 inz('N')
*------------------------------------------------------------------------
*- Mainline
*------------------------------------------------------------------------
C *entry plist
C parm pHeader
C parm pRtn
C parm pLine1
C eval pHeader2 = pHeader
* if F7 or F8 then do nothing
C if hdFuncKey = '7' or
C hdFuncKey = '8'
C eval *inlr = *on
C return
C endif
* otherwise process all records in workspace
C do hdNbrRecs rec#
C eval pLine = pLine1 + ((hdRecLen + %len(srchdr))
C * (rec# - 1))
C eval pData = pLine + %len(srcHdr)
* save multi-line command when it is encountered
C if hldCmd = *blanks
C select
C when srcCmd = 'UCC'
C eval hldCmd = 'UCC'
C when srcCmd = 'LCC'
C eval hldCmd = 'LCC'
C endsl
C else
* if this is the second occurrence of the multi-line command then this is
* the last line to apply the multi-line command to.
C if hldCmd = srcCmd
C eval lastRec = Yes
C endif
C endif
* check which command is being used
C select
* uppercase - UC
C when srcCmd = 'UC'
C or hldCmd = 'UCC'
C eval wkCode = %subst(srcCode:1:hdRecLen)
C lo:up xlate wkCode wkCode
C eval %subst(srcCode:1:hdRecLen) =
C %subst(wkCode:1:hdRecLen)
C eval srcRtnCd = '0'
C eval srcCmd = *blanks
* lowercase - LC
C when srcCmd = 'LC'
C or hldCmd = 'LCC'
C eval wkCode = %subst(srcCode:1:hdRecLen)
C up:lo xlate wkCode wkCode
C eval %subst(srcCode:1:hdRecLen) =
C %subst(wkCode:1:hdRecLen)
C eval srcRtnCd = '0'
C eval srcCmd = *blanks
C endsl
* clear multi-line command after encountering second line command
C if lastRec = Yes
| | | | |
