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 - 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 - 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
C eval hldCmd = *blanks
C endif
C enddo
C eval hdRecsOut = hdNbrRecs - 1
C eval hdRtnCd = '2'
C eval *inlr = *on
C return
RPGLE - RPG/RPGLE
Posted By: Muhammad Saleem Contact
RPGLE - Send e-mail from iSeries
Posted By: A. le Cour Contact
A tool for sending mails from iSeries programming in Free RPG.
RPGLE - Send e-mail from iSeries
Posted By: A. le Cour Contact
A tool for sending mails from iSeries programming in Free RPG.
RPGLE - Envoi de courriel à partir de iSeries
Posted By: A. le Cour Contact
Source ILE en format libre SNDEMAIL
H BndDir('QC2LE') BndDir('SENDMAIL') DatEdit(*DMY) DatFmt(*EUR)
H Debug Option(*SrcStmt)
//=============================================================//
// Identification de la procédure //
//-------------------------------------------------------------//
// Nom : SNDEMAIL //
// Libellé : Envoi de courriel avec ou sans pièce(s) jointe(s) //
// //
// Auteur : A. le Cour //
// Date : Mardi 31 Janvier 2006 //
// //
//=============================================================//
// Liste des modifications //
//-------------------------------------------------------------//
// ___________________________________________________________ //
// | Révision | Date | Modifié par | //
// |__________|__________|___________________________________| //
// | .... | ../../.. | ..................................| //
// |__________|__________|___________________________________| //
// | Objet modification : ..................................| //
// | ........................................................| //
// |_________________________________________________________| //
// //
//=============================================================//
// Description de la procédure //
//-------------------------------------------------------------//
// Cette procédure a pour but d'envoyer un courriel avec ou //
// sans pièce(s) jointe(s). //
//=============================================================//
//=============================================================//
// Environnement de la procédure //
//=============================================================//
D DsPrc SDS
D PrcName 10 Overlay(DsPrc)
D StsCode 5S 0 Overlay(DsPrc:*Next)
D PrvSts 5S 0 Overlay(DsPrc:*Next)
D LineNum 8 Overlay(DsPrc:*Next)
D Routine 8 Overlay(DsPrc:*Next)
D NbParms 3S 0 Overlay(DsPrc:*Next)
D PgmMsgId 7 Overlay(DsPrc:*Next)
D MsgRoot 3 Overlay(PgmMsgId)
D MsgKeys 4 Overlay(PgmMsgId:*Next)
D 4 Overlay(DsPrc:*Next)
D WrkAreaMsg 30 Overlay(DsPrc:*Next)
D PgmLib 10 Overlay(DsPrc:*Next)
D MsgData 80 Overlay(DsPrc:*Next)
D ExcpId 4 Overlay(DsPrc:*Next)
D 16 Overlay(DsPrc:*Next)
D PgmDate 8 Overlay(DsPrc:*Next)
D RunYear 2S 0 Overlay(DsPrc:*Next)
D LastFileOp 8 Overlay(DsPrc:*Next)
D FileSts 35 Overlay(DsPrc:*Next)
D QualJobNam 26 Overlay(DsPrc:*Next)
D JobName 10 Overlay(QualJobNam)
D UsrName 10 Overlay(QualJobNam:*Next)
D JobNum 6S 0 Overlay(QualJobNam:*Next)
D JobDate 6S 0 Overlay(DsPrc:*Next)
D RunDate 6S 0 Overlay(DsPrc:*Next)
D RunTime 6S 0 Overlay(DsPrc:*Next)
D DateCrt 6 Overlay(DsPrc:*Next)
D TimeCrt 6 Overlay(DsPrc:*Next)
D LvlCompil 4 Overlay(DsPrc:*Next)
D SrcFile 10 Overlay(DsPrc:*Next)
D SrcLib 10 Overlay(DsPrc:*Next)
D SrcMbrName 10 Overlay(DsPrc:*Next)
D PgmName 10 Overlay(DsPrc:*Next)
D ModName 10 Overlay(DsPrc:*Next)
D 76 Overlay(DsPrc:*Next)
//=============================================================//
// Paramètres d'entrée //
//=============================================================//
D SndEmail Pr
D Ds01 LikeDs(RecareaMod)
D 255a
D 80a
D Ds02 LikeDs(AttachmentMod)
D 256a
D 512a
D SndEmail Pi
D RecArea LikeDs(RecAreamod)
D Originator 255a
D OriginName 80a
D Attachment LikeDs(AttachmentMod)
D Subject 256a
D Message 512a
//=============================================================//
// Prototypes divers //
//=============================================================//
// Ajoût de destinataires
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D AddRecipient Pr 280a
D EmailAddr 256a Const
D RecipType 3a Const
// Conversion de l'adresse E-mail en CCSID - 500
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Conv500 Pr
D Addr500 256a
D QtqIconvOpen Pr ExtProc('QtqIconvOpen')
D Like(iconv_t)
D ToCode Likeds(qtqcode_t) Const
D FromCode Likeds(qtqcode_t) Const
D Iconv Pr 10i 0 ExtProc('iconv')
D Cd Like(iconv_t) Value
D InBuf *
D InBytesLeft 10u 0
D OutBuf *
D OutBytesLeft 10u 0
D Iconv_Close Pr 10i 0 ExtProc('iconv_close')
D Cd Like(iconv_t) Value
D Do_Iconv Pr 256a Varying
D Trans Likeds(iconv_t) Const
D Text 256a Varying Value
// API QtmmSendMail (envoi de courriel depuis un programme i-Series)
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D*QtmmSendMail Pr ExtProc('QtmmSendMail')
D EnvoiCourriel Pr ExtProc('QtmmSendMail')
D FileName 255 Const
D FileLen 10i 0 Const
D Originator 255 Const
D Originlen 10i 0 Const
D Recipient 32767 Const Options(*VarSize)
D TotalRecp 10i 0 Const
D b Like(DsEc)
// Encodage base 64
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Base64_Encode Pr 10u 0
D Input * Value
D InputLen 10u 0 Value
D OutPut * Value
D OutPutSize 10u 0 Value
// Envoi de message programme (SndPgmMsg)
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D SndPgmMsg Pr ExtPgm('QMHSNDPM')
D MessageId 7 Const
D QualMsgf 20 Const
D MsgData 256 Const
D MsgDtaLen 10i 0 Const
D MsgType 10 Const
D CallStkEnt 10 Const
D CallStkCnt 10i 0 Const
D MessageKey 4
D ErrorCode 32766 Options(*VarSize)
//=============================================================//
// Prototypes IFS //
//=============================================================//
// Ouverture d'un fichier IFS
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Open Pr 10i 0 ExtProc('open')
D FileName * Value
D OpenFlags 10i 0 Value
D Mode 10u 0 Value Options(*Nopass )
D CodePage 10u 0 Value Options(*Nopass )
// Lecture d'un fichier IFS
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Read Pr 10i 0 ExtProc('read')
D FileHandle 10i 0 Value
D DataReceived * Value
D Nbytes 10u 0 Value
// Ecriture d'un fichier IFS
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Write Pr 10i 0 ExtProc('write')
D FileHandle 10i 0 Value
D DataToWrite * Value
D Nbytes 10u 0 Value
// Fermeture d'un fichier IFS
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D Close Pr 10i 0 ExtProc('close')
D FileHandle 10i 0 Value
// Numéro erreur
// ¯¯¯¯¯¯¯¯¯¯¯¯¯
D ErrNo Pr 10i 0
// Texte erreur
// ¯¯¯¯¯¯¯¯¯¯¯¯
D StrError Pr * ExtProc('strerror')
D ErrNum 10i 0 Value
//=============================================================//
// Structures de données //
//=============================================================//
D Iconv_t Ds Qualified
D Based(StructureTemplate)
D Return_Value 10i 0
D Cd 10i 0 Dim(12)
D QtqCode_t Ds Qualified
D CcsId 10i 0 Inz
D ConValt 10i 0 Inz
D SubsAlt 10i 0 Inz
D ShiftAlt 10i 0 Inz(1)
D InplenOp 10i 0 Inz(0)
D ErrorOpt 10i 0 Inz(1)
D Reserved 8a Inz(*Allx'00')
D Conv Ds LikeDs(Iconv_t)
D Conv_From Ds LikeDs(QtqCode_t)
D Inz(*LikeDs)
D Conv_To Ds LikeDs(QtqCode_t)
D Inz(*LikeDs)
D RecDisplCmt Ds
D RecDspla 2a
D d 5i 0 Overlay(RecDspla)
// Paramètre adresses
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D RecAreamod Ds
D RecNbr 5i 0
D RecRec 8000a
D Rec Ds
D RecDim Dim(15)
D RecDspl 5u 0 Overlay(RecDim)
D RecAddr 256a Overlay(RecDim:*Next)
D RecType 3a Overlay(RecDim:*Next)
D RecName 256a Overlay(RecDim:*Next)
// Tableau des pièces jointes
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D AttachmentMod Ds
D NbrFiles 5i 0
D AttachFile 256a Dim(30)
// Erreur API
// ¯¯¯¯¯¯¯¯¯¯
D DsEc Ds
D DsEcBytesp 10i 0 Inz(%Size(DsEc ))
D DsEcBytesa 10i 0 Inz
D DsEcMsgId 7
D DsEcReserv 1
D DsEcMsgDta 256
//=============================================================//
// Constantes IFS //
//=============================================================//
// Modes d'accès fichier pour Open()
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D O_RdOnly s 10i 0 Inz(1)
D O_WrOnly s 10i 0 Inz(2)
D O_RdWr s 10i 0 Inz(4)
// Valeurs de Oflag pour Open()
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D O_Creat s 10i 0 Inz(8)
D O_Excl s 10i 0 Inz(16)
D O_Trunc s 10i 0 Inz(64)
// Statut flags fichier pour Open() et Fcntl
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D O_NonBlock s 10i 0 Inz(128)
D O_Append s 10i 0 Inz(256)
// Valeurs du mode partagé de Oflag pour Open()
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D O_Share_None s 10i 0 Inz(2000000)
D O_Share_RdOnly s 10i 0 Inz(0200000)
D O_Share_RdWr s 10i 0 Inz(1000000)
D O_Share_WrOnly s 10i 0 Inz(0400000)
// Autorisations fichier
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D S_Irusr s 10i 0 Inz(256)
D S_Iwusr s 10i 0 Inz(128)
D S_Ixusr s 10i 0 Inz(64)
D S_Irwxu s 10i 0 Inz(448)
D S_Irgrp s 10i 0 Inz(32)
D S_Iwgrp s 10i 0 Inz(16)
D S_Ixgrp s 10i 0 Inz(8)
D S_Irwxg s 10i 0 Inz(56)
D S_Iroth s 10i 0 Inz(4)
D S_Iwoth s 10i 0 Inz(2)
D S_Ixoth s 10i 0 Inz(1)
D S_Irwxo s 10i 0 Inz(7)
// Misc
// ¯¯¯¯
D O_TextData s 10i 0 Inz(16777216)
D O_CodePage s 10i 0 Inz(8388608)
// Variables diverses
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
D z s 5u 0
D msgdta s 256a
D wwmsglen s 10i 0
D wwthekey s 4a
D FileName s 255a DtaAra(MIMEFILE)
D FileLen s 10i 0
D OriginLen s 10i 0
D Attachname s 256a
D AsciiCodePage s 10u 0 Inz(819)
D TotalRecp s 10i 0
D FileDesc s 10i 0
D BytesWrt s 10i 0
D Data s 9999a
D AttachDesc s 10i 0
D BytesRead s 10i 0
D DataRead s 57a
D TextData s 76a
D CRLF s 2a Inz(X'0D25')
D Null s 1a Inz(X'00')
D FullName s 512a
D ReturnInt s 10i 0
D Len_Text s 10i 0
D Pos s 5u 0
D SavePos s Like(Pos)
D i s Like(Pos)
D j s Like(Pos)
D mSender s 256a
D mDateTime s 256a
D mFrom s 256a
D mMimever s 256a
D mType s 256a Inz
D mTo s 256a Inz
D mCc s 256a Inz
D mCci s 256a Inz
D mSubject s 256a
D mBoundary s 256a Inz('--PART.BOUNDARY.1')
D Recip s 32767a
D Seton s n Inz(*On)
//=========================//
// Début de la procédure //
//=========================//
/Free
*InLr = Seton;
// Initialisation
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯
In *DtaAra;
FileLen = %Len(%Trim(FileName));
%Subst(FileName:FileLen+1:2) = X'0000';
OriginLen = %Len(%Trim(Originator));
TotalRecp = RecArea.RecNbr;
// Adresse destinataires
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
j = 1;
For i = 1 To RecArea.RecNbr; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
RecDspla = %Subst(RecArea.RecRec:j:2); // |
d += 1; // |
RecAddr(i) = %Subst(RecArea.RecRec:d:256); // |
d += 256; // |
RecType(i) = %Subst(RecArea.RecRec:d:3); // |
d += 3; // |
RecName(i) = %Subst(RecArea.RecRec:d:26); // |
// |
// Concatener destinataires dans Recip // |
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ // |
// |
Recip = %Trim(Recip) + // |
%Trim(AddRecipient(RecAddr(i): // |
RecType(i))); // |
j += 2; // |
EndFor; //______________________E01
// Création du fichier MIME
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
ExSr WriteHdr;
// Conversion du caractère "@" en "à" pour l'API
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Originator = %Xlate('@':'à':Originator);
Recip = %Xlate('@':'à':Recip);
// Appel de l'API d'envoi du courriel
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
EnvoiCourriel(FileName : FileLen : Originator :
OriginLen : Recip : TotalRecp : DsEc);
// Envoi d'un message d'erreur
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
If DsEcBytesa <> 0; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
MsgDta = DsEcMsgDta; // |
ExSr SndInfMsg; // |
Clear MsgDta; // |
MsgDta = X'29' + // |
' Une erreur s''''est produite lors de l''''appel + // |
de l''''API QtmmSendMail (' + dsECMsgID + ')'; // |
ExSr SndEscMsg; // |
Else; // X01
MsgDta = X'39' + ' La distribution a ' + // |
'été effectuée. ' + X'20'; // |
ExSr SndInfMsg; // |
EndIf; //______________________E01
//=========================//
// Fin de la procédure //
//=========================//
Return;
//==================================//
// Envoi d'un message d'information //
//==================================//
BegSr SndInfMsg;
If DsEcMsgId = *Blanks; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
DsEcMsgId = 'CPF9897'; // |
EndIf; //______________________E01
SndPgmMsg(DsEcMsgId : 'QCPFMSG *LIBL' :
MsgDta : %Len(%Trimr(MsgDta)): '*INFO':
'*PGMBDY': 1: wwTheKey: DsEc);
EndSr;
//==================================//
// Envoi d'un message d'échappement //
//==================================//
BegSr SndEscMsg;
If DsEcMsgId = *Blanks; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
DsEcMsgId = 'CPF9897'; // |
EndIf; //______________________E01
SndPgmMsg(DsEcMsgId : 'QCPFMSG *LIBL' :
MsgDta : %Len(%Trimr(MsgDta)) : '*ESCAPE':
'*PGMBDY': 1: wwTheKey : DsEc);
EndSr;
//================================================//
// Ecriture d'une portion de l'entête du fichier //
//================================================//
BegSr WriteHdr;
FullName = %Trimr(FileName) + Null;
If Open(%Addr(FullName) //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
: O_Creat + O_WrOnly + O_Trunc + // |
O_CodePage // |
: S_Irwxu + S_Iroth // |
: AsciiCodePage) < 0; // |
DsEcMsgId = 'CPE' + %Char(ErrNo); // |
MsgDta = %Trim(%Str(StrError(ErrNo))) + // |
' - API Open()'; // |
ExSr SndEscMsg; // |
EndIf; //______________________E01
ReturnInt = Close(FileDesc);
FileDesc = Open(%Addr(FullName)
: O_TextData + O_RdWr);
// Construire zones entête MIME
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
mSender =
'Sender: ' + Originator;
mDateTime =
'Date: ';
mFrom =
'From: ' +
%Trimr(OriginName) + ' <' +
%Trimr(Originator) + '>';
mMimever =
'MIME-Version: 1.0';
// Type de destinataires
// ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
For i = 1 To RecArea.RecNbr; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
Select; //_____________________B02|
// ||
When RecType(i) = 'CC'; // ||
If mCc <> ' '; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
mCc = %Trimr(mCc) + '; '; // |||
EndIf; //____________________E03||
mCc = %Trimr(mCc) + // ||
'"' + %Trimr(RecName(i)) + '"' + // ||
' <' + %Trimr(RecAddr(i)) + '>'; // ||
// ||
When RecType(i) = 'CCI'; // ||
If mCci <> ' '; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
mCci = %Trimr(mCci) + '; '; // |||
EndIf; //____________________E03||
mCci = %Trimr(mCci) + // ||
'"' + %Trimr(RecName(i)) + '"' + // ||
' <' + %Trimr(RecAddr(i)) + '>'; // ||
// ||
Other; // ||
If mTo <> ' '; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
mTo = %Trimr(mTo) + '; '; // |||
EndIf; //____________________E03||
mTo = %Trimr(mTo) + // ||
'"' + %Trimr(RecName(i)) + '"' + // ||
' <' + %Trimr(RecAddr(i)) + '>'; // ||
// ||
EndSl; //_____________________E02|
EndFor; //______________________E01
If mTo <> *Blanks; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
mTo = 'To: ' + %Trimr(mTo); // |
EndIf; //______________________E01
If mCc <> *Blanks; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
mCc = 'Cc: ' + %Trimr(mCc); // |
EndIf; //______________________E01
If mCci <> *Blanks; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
mCci= 'Cci: ' + %Trimr(mCci); // |
EndIf; //______________________E01
If Subject > *Blanks; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
mSubject = // |
'Subject: ' + Subject; // |
Else; // X01
mSubject = // |
'Subject: '; // |
EndIf; //______________________E01
Data = %Trimr(mSender) +
CRLF +
%Trimr(mDateTime) +
CRLF +
%Trimr(mFrom) +
CRLF +
%Trimr(mMimever) +
CRLF;
If mTo <> ' '; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
Data = %Trimr(data) + %Trimr(mTo) + CRLF; // |
EndIf; //______________________E01
If mCc <> ' '; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
Data = %Trimr(Data) + %Trimr(mCc) + CRLF; // |
EndIf; //______________________E01
If mCci<> ' '; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
Data = %Trimr(Data) + %Trimr(mCci) + CRLF; // |
EndIf; //______________________E01
Data = %Trimr(Data) +
%Trimr(mSubject) +
CRLF +
'Content-Type: multipart/mixed; boundary=' +
'"' + %trimr(mboundary) + '"' +
CRLF +
CRLF +
'This is a multi-part message in MIME ' +
'format.' + CRLF + CRLF +
'--' + %trimr(mboundary) +
CRLF +
// Codification international en 8 bits
'Content-Type: text/plain; ' +
'charset=iso8859-1' + CRLF +
'Content-Transfer-Encoding: 8bit' +
CRLF + CRLF +
// Message
%trimr(message) +
CRLF + CRLF + CRLF + CRLF +
'--' + %Trimr(mBoundary);
// Ajoût de pièces jointes si requis
If Attachment.NbrFiles > *Zero /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
and Attachment.Attachfile(1) <> '*NONE'; // |
ExSr writefile; // |
// |
DoW z < Attachment.NbrFiles; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B02|
z += 1; // ||
Clear SavePos; // ||
Pos = %Scan('/':Attachment.Attachfile(z):1); // ||
DoW Pos > *Zero; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
SavePos = Pos; // |||
Pos = %Scan('/':Attachment.Attachfile(z):Pos+1); // |||
EndDo; //____________________E03||
// ||
If SavePos <> *Zero; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
Attachname = %Subst(Attachment.Attachfile(z):SavePos+1);// |||
Else; // X03||
Attachname = Attachment.Attachfile(z); // |||
EndIf; //____________________E03||
// ||
Data = CRLF + // ||
'Content-Type: application/octet' + // ||
'-stream; name="' + // ||
%trimr(attachname) + '"' + // ||
CRLF + // ||
'Content-Disposition: inline; filename="' + // ||
%trimr(attachname) + '"' + // ||
CRLF + // ||
'Content-Transfer-Encoding: base64' + // ||
CRLF + CRLF; // ||
// ||
ExSr WriteFile; // ||
// ||
// Ouverture de la pièce jointe // ||
FullName = %Trimr(Attachment.Attachfile(z)) + Null; // ||
Attachdesc = Open(%Addr(FullName) // ||
: o_rdonly ); // ||
// ||
// Lecture du fichier et écriture du fichier MIME // ||
BytesRead = Read(Attachdesc // ||
: %Addr(DataRead) // ||
: %Size(DataRead)); // ||
// ||
// Pièce jointe non trouvé // ||
If BytesRead < 0; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
// |||
// Envoi d'un message d'échappement // |||
MsgDta = X'29' + // |||
' Pièce jointe ' + %Trimr(FullName) + // |||
' non trouvée'; // |||
ExSr SndEscMsg; // |||
EndIf; //____________________E03||
// ||
DoW BytesRead > 0; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
Len_Text = Base64_Encode( // |||
%Addr(DataRead) // |||
: BytesRead // |||
: %Addr(TextData) // |||
: %Size(TextData) ); // |||
// |||
BytesWrt = Write(FileDesc // |||
: %Addr(TextData) // |||
: Len_Text ); // |||
// |||
BytesWrt = Write(FileDesc // |||
: %Addr(CRLF) // |||
: %Size(CRLF)); // |||
// |||
BytesRead = Read(AttachDesc // |||
: %Addr(DataRead) // |||
: %Size(DataRead)); // |||
EndDo; //____________________E03||
// ||
// Fermeture de la pièce jointe et écriture du fichier MIM// ||
// ||
ReturnInt = Close(Attachdesc); // ||
// ||
If z >= Attachment.NbrFiles; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B03||
Data = CRLF + // |||
'--' + %Trimr(mBoundary) + '--' + // |||
CRLF + CRLF; // |||
Else; // X03||
Data = CRLF + // |||
'--' + %Trimr(mBoundary); // |||
EndIf; //____________________E03||
// ||
ExSr WriteFile; // ||
EndDo; //_____________________E02|
// |
Else; // X01
// |
// Ecriture de la fin du fichier MIME sans pièce jointe // |
// |
Data = %Trimr(Data) + '--' + CRLF + CRLF; // |
ExSr WriteFile; // |
EndIf; //______________________E01
// Fermeture du fichier
ReturnInt = Close(FileDesc);
EndSr;
//
// Ecriture du fichier
//
BegSr WriteFile;
BytesWrt = Write(FileDesc :
%Addr(data) :
%Len(%Trimr(Data)));
EndSr;
/End-Free
//
// Ajoût de destinataire
//
P AddRecipient B
D AddRecipient Pi 280a
D EmailAddr 256a Const
D RecipType 3a Const
// Data structure of recipient info.
D Recipient Ds
D Offset 10i 0
D AddrLen 10i 0
D Format 8a
D DistrType 10i 0
D Reserved 10i 0
D Address 256a
// Type of recipient
D dTo c Const(0)
D dCc c Const(1)
D dBcc c Const(2)
/Free
Format = 'ADDR0100';
Select;
// CC = Carbon Copy
When RecipType = 'CC ';
DistrType = dCc;
// BC = Blind Carbon Copy
When RecipType = 'CCI';
DistrType = dBcc;
//
Other;
DistrType = dTo;
EndSl; //______________________E01
Reserved = 0;
address = EmailAddr;
Conv500(Address);
AddrLen = %Len(%Trim(Address));
Offset = 24 + AddrLen;
Return Recipient;
/End-Free
P E
//
// Conversion en CCSID 500
//
P Conv500 B
D Conv500 Pi
D addr500 256a
/Free
Conv_From.Ccsid = 0;
Conv_To.Ccsid = 500;
Conv = qtqiconvopen(Conv_To : Conv_From);
Addr500 = Do_Iconv(Conv: Addr500);
iconv_close(conv);
Return;
/End-Free
P E
//
// Encodage base 64
//
P Base64_Encode B
D Base64_Encode Pi 10u 0
D Input * Value
D InputLen 10u 0 Value
D Output * Value
D OutputSize 10u 0 Value
D B64_Alphabet Ds Static
D Alphabet 64a Inz('-
D ABCDEFGHIJKLMNOPQRSTUVWXYZ-
D abcdefghijklmnopqrstuvwxyz-
D 0123456789+/')
D Base64 1a Dim(64)
D Overlay(alphabet)
D Ds
D Numb 1 2u 0 Inz(0)
D Byte 2 2a
D Data Ds Based(Input)
D B1 1a
D B2 1a
D B3 1a
D OutData s 4a Based(output)
D Out s 4a
D Pos s 10i 0
D OutLen s 10i 0
D Save s 1a
/Free
Pos = 1;
DoW Pos <= InputLen; //¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯B01
// |
Byte = %Bitand(B1: X'FC'); // |
Numb /= 4; // |
%Subst(Out:1) = Base64(Numb+1); // |
// |
Byte = %Bitand(B1: X'03'); // |
Numb *= 16; // |
// |
If (Pos+1) <= InputLen; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯2|
Save = Byte; // ||
Byte = %Bitand(B2: X'F0'); // ||
Numb /= 16; // ||
Byte = %Bitor(Save: Byte); // ||
EndIf; //_____________________E02|
// |
%Subst(Out: 2) = Base64(Numb+1); // |
// |
If (Pos+1 > InputLen); /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯2|
%Subst(Out:3) = '='; // ||
Else; // X02|
Byte = %Bitand(B2: X'0F'); // ||
Numb *= 4; // ||
// ||
If (Pos+2 <= InputLen); /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯3||
Save = Byte; // |||
Byte = %Bitand(B3: X'C0'); // |||
Numb /= 64; // |||
Byte = %Bitor(Save: Byte); // |||
EndIf; //____________________E03||
// ||
%Subst(Out:3) = Base64(Numb+1); // ||
EndIf; //_____________________E02|
// |
// |
If (Pos+2 > InputLen); /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯2|
%Subst(Out:4:1) = '='; // ||
Else; // X02|
Byte = %Bitand(B3 : X'3F'); // ||
%Subst(Out:4) = Base64(Numb+1); // ||
EndIf; //_____________________E02|
// |
//
// Prochain
//
// |
Input += 3; // |
Pos += 3; // |
OutLen += 4; // |
// |
If OutLen <= OutputSize; /¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯2|
Outdata = Out; // ||
Output += 4; // ||
EndIf; //_____________________E02|
// |
EndDo; //______________________E01
Return Outlen;
/End-Free
P E
//
// Retourne le texte traduit
//
P Do_Iconv B
D Do_Iconv Pi 256a Varying
D Trans LikeDs(iconv_t) Const
D Text 256a Varying Value
D P_Input S *
D P_Output S *
D Output S 1024a Varying
D Inleft S 10u 0
D Outleft S 10u 0
/Free
Inleft = %Len(Text);
Outleft = Inleft;
%Len(Output) = Outleft;
P_Input = %Addr(Text) + 2;
P_Output = %Addr(Output) + 2;
Iconv(Trans : P_Input : Inleft
: P_output : Outleft);
Return Output;
/End-Free
P E
//
// Procédure d'erreurs pour les API de Type Unix
//
P ErrNo B
D ErrNo Pi 10i 0
D SysErrNo Pr * ExtProc('__errno')
D P_ErrNo S *
D RetVal S 10i 0 Based(P_ErrNo)
/Free
P_ErrNo = SysErrNo;
Return RetVal;
/End-Free
P E
Source de la commande SNDEMAIL
CMD PROMPT('Envoi de courriel')
PARM KWD(RECIPADDR) TYPE(L2) MIN(1) MAX(15) +
PROMPT('Destinataire')
PARM KWD(SENDERADDR) TYPE(*PNAME) LEN(255) +
DFT('emetteur@domaine.fr') MIN(0) MAX(1) +
EXPR(*YES) PROMPT('Adresse e-mail +
expéditeur')
PARM KWD(SENDERNAME) TYPE(*CHAR) LEN(256) +
DFT(*NONE) EXPR(*YES) PROMPT('Nom +
expéditeur')
PARM KWD(ATTACHMENT) TYPE(*PNAME) LEN(256) +
DFT((*NONE)) SPCVAL((*NONE)) MAX(30) +
EXPR(*YES) PROMPT('Pièce jointe')
PARM KWD(SUBJECT) TYPE(*CHAR) LEN(256) DFT(*NONE) +
SPCVAL((*NONE)) EXPR(*YES) PROMPT('Objet')
PARM KWD(MESSAGE) TYPE(*CHAR) LEN(512) DFT(*NONE) +
SPCVAL((*NONE)) EXPR(*YES) +
PROMPT('Message')
L2: ELEM TYPE(*PNAME) LEN(256) MIN(1) EXPR(*YES) +
PROMPT('Adresse e-mail')
ELEM TYPE(*NAME) LEN(3) RSTD(*YES) DFT(TO) +
VALUES(TO CC CCI) PROMPT('Type')
ELEM TYPE(*CHAR) LEN(256) DFT(*NONE) +
SPCVAL((*NONE)) EXPR(*YES) PROMPT('Nom')
RPGLE - Multiple Subfile
Posted By: Ankur Shah Contact
*
* To compile:
*
* CRTRPGPGM PGM(XXX/SFL015RG) SRCFILE(XXX/QRPGLESRC)
*
*=======================================================================
Fmultsfl1dfcf e workstn sfile(sfl1:rrn1)
F sfile(sfl2:rrn2)
F infds(info)
Fsfl001lf if e k disk
Dinfo ds
D cfkey 369 369
D sflrrn 378 379B 0
Dexit C const(X'33')
Dcancel C const(X'3C')
Denter C const(X'F1')
C exsr sflbld
c dou (cfkey = exit) or (cfkey = cancel)
C write header
C write footer
C write sf2ctl
C write sf1ctl
C read sf2ctl
C read sf1ctl
C select
C when (cfkey = exit) or (cfkey = cancel)
C eval *inlr = *on
C endsl
C enddo
****************************************************************
C sflbld begsr
***************************************************************
*
* Load-all subfile. Clear both subfiles before loading.
*
C eval *in31 = *on
C eval *in41 = *on
C write sf1ctl
C write sf2ctl
C eval *in31 = *off
C eval *in41 = *off
C z-add 0 rrn1
C z-add 0 rrn2
*
* Read the records from file and load both subfiles.
*
C *loval setll sfl001lf
C read sfl001lf
C dow not %eof
C eval rrn1 = rrn1 + 1
C eval rrn2 = rrn2 + 1
C write sfl1
C write sfl2
C read sfl001lf
C enddo
*
* Since we are reading from the same file,
* just check rrn1 to determine empty subfiles.
*
C if rrn1 > 0
C eval *in32 = *on
C eval *in42 = *on
C eval rrn1 = 1
C eval rrn2 = 1
C endif
*
* SFLEND indicator
*
C eval *in90 = *on
*
C endsr
RPGLE - Create the DDS based on the File Field Description
Posted By: Siva Kumar Contact
FQTMPSRC O A E DISK Rename(QTMPSRC:QTMPSRC1)
FTEMPFFD IF E DISK
D* Format the record format record of the DDS.
DRecfmt DS INZ
DFiltr1 1 80 INZ
DSpec 6 6 INZ('A')
DRcdtyp 17 17 INZ('R')
DRcdfmt 19 28 INZ('RECFMT')
D*
DData DS INZ
DFiltr2 1 80 INZ
DSpecd 6 6 INZ('A')
DField 19 28 INZ
DLength 30 34 INZ
DType 35 35 INZ
DDec 36 37 INZ
D*
C*******************************************************************
C* Write the 1st record with the record type as 'R'
C*******************************************************************
C Movel *Blanks Filtr1
C Move 'A' Spec
C Move 'R' Rcdtyp
C Movel 'RCDFMT' Rcdfmt
C Movel Recfmt Srcdta
C Write(E) QTMPSRC1
C If %Error
C* Eval Errmsg='Error while writing the RCDFMT rcd '
C Seton LR
C Return
C Endif
C*******************************************************************
C Read Qwhdrffd
C Dow Not %Eof(Tempffd)
C Exsr Reset
C Whfldt Ifeq 'A'
C Eval Field = Whflde
C Eval Type = Whfldt
C EVALR Length = %CHAR(Whfldb)
C Else
C Eval Type = Whfldt
C Eval Field = Whflde
C Evalr Length= %CHAR(Whfldd)
C Evalr Dec = %CHAR(Whfldp)
C Endif
C Movel Data Srcdta
C Write(E) Qtmpsrc1
C If %Error
C Seton LR
C Return
C Endif
C Read Qwhdrffd
C Enddo
C Seton LR
C Return
C********************************************************************
C***********************************************************************
C Reset Begsr
C Movel *BLANKS Filtr2
C Movel 'A' Specd
C Endsr
C***********************************************************************
RPGLE - receive and remove messages
Posted By: ravi kumar reddy Contact
Message API
The following code will clear the program message queue/ will remove a
specific message from the program message queue and write the messages
to program message queue.
D DS
D MSGLEN 1 4B 0 INZ
D PGMSTK 5 8B 0 INZ
* ==> The following data variable decleration is used to retrive
* the messages from program message queue. For evaluate the
* type of message.
DRCVM0100_Ds DS
D ByteReturn 9B 0 INZ
D ByteAvail 9B 0 INZ
D MsgSever 9B 0 INZ
D MessageID 7 INZ
D MessageTyp 2 INZ
D MessageKy1 4 INZ
D Resserve_1 7 INZ
D CCSID_Flag 9B 0 INZ
D CCSID_RplD 9B 0 INZ
D CCSID_RplL 9B 0 INZ
D MsgRplData 127 INZ
DMessageLen 9B 0 INZ(171)
DFormatName 8 INZ('RCVM0100')
DStackPtr * INZ(*NULL)
DStackCntr 9B 0 INZ(*ZEROS)
DMessageType 10 INZ
DMessageKey 4 INZ
DWaitTime 9B 0 INZ(*ZEROS)
DMessageActn 10 INZ('*SAME')
DLengthStack 9B 0 INZ(16)
DEntryQual 20 INZ('*NONE *NONE ')
DStackType 10 INZ('*PTR')
DCCSID_Set 9B 0 INZ(*ZEROS)
* ==> Data structure for AS/400 APIs to return the error information
* whenever a API is called.
DApiErrDts DS
D ApiErrLen 1 4B 0 INZ(272)
D ApiErrAvl 5 8B 0 INZ
D ApiErrId 9 15A INZ
D ApiErrDta 17 272A INZ
* ==> Parameter for QMHRMVPH (Remove message API)
C PREMOV PLIST
C PARM PGMMSQ
C PARM PGMSTK
C PARM MSGKEY
C PARM TORMV 10
C PARM ApiErrDts
* ==> Parameter for QMHRCVPM (Receive Program Message).
C QMHRCV_Prm PLIST
C PARM RCVM0100_Ds
C PARM MessageLen
C PARM FormatName
C PARM *NULL StackPtr
C PARM *ZEROS StackCntr
C PARM MessageType
C PARM MessageKey
C PARM WaitTime
C PARM MessageActn
C PARM APIErrDts
C PARM LengthStack
C PARM EntryQual
C PARM StackType
C PARM CCSID_Set
* ==> Parameter for QMHSNDPM (To send the message to program msgq)
C PSENDM PLIST
C PARM MSGID 7
C PARM MSGF 20
C PARM MSGDTA 512
C PARM 512 MSGLEN
C PARM '*INFO' MSGTYP 10
C PARM PGMMSQ 10
C PARM *ZEROS PGMSTK
C PARM MSGKEY 4
C PARM ApiErrDts
* +---------------------------------------------------------------+ *
* ? $MsgHndlr : This subroutine will clear or send messages ? *
* ? to the program message queue. ? *
* ? ? *
* ? Basic Inp : ERRFNCTYP - (C)lear or (E) or Blanks ? *
* ? PREMOV - Variables declared under PREMOV ? *
* ? parameter list. ? *
* ? PSENDM - Variables declared under PSENDM ? *
* ? parameter list. ? *
* +---------------------------------------------------------------+ *
C $MSGHNDLR BEGSR
C EVAL PgmMsq = PgmName
C MOVE *IN89 ErrIND89 1
* ==> Clear the program message queue when ERRFNCTYP = (C)lear.
C SELECT
C WHEN ErrFncTyp = 'C'
C EVAL PGMSTK = *ZEROS
C EVAL MSGKEY = *BLANKS
C EVAL TORMV = '*ALL'
C CALL 'QMHRMVPM' PREMOV 8989
C RESET ErrFncTyp
* ==> Remove unwanted message. This part will retain only those message
* which was written by the application and not by the system.
C WHEN ErrFncTyp = 'E'
C RESET ErrFncTyp
C RESET RCVM0100_Ds
C RESET MessageActn
C EVAL MessageType = '*NEXT'
C EVAL MessageKey = X'00000000'
C CALL 'QMHRCVPM' QMHRCV_Prm
C DOW MessageID <> *BLANKS
C IF MessageTyp <> '04'
C EVAL PGMSTK = *ZEROS
C EVAL MSGKEY = MessageKy1
C EVAL TORMV = '*BYKEY'
C CALL 'QMHRMVPM' PREMOV 8989
C ENDIF
C RESET RCVM0100_Ds
C RESET MessageActn
C EVAL MessageType = '*NEXT'
C EVAL MessageKey = MessageKy1
C CALL 'QMHRCVPM' QMHRCV_Prm
C ENDDO
* ==> Write the message to the program message queue.
C OTHER
C EVAL MSGF = 'QCPFMSGF *LIBL '
C CALL 'QMHSNDPM' PSENDM 8989
C EVAL MSGID = *BLANKS
C EVAL MSGDTA = *BLANKS
C ENDSL
C EVAL *IN89 = ErrIND89
C ENDSR
RPGLE - Fun with Callender
Posted By: Subhrajit Chandra Contact
Corresponding Display file is as follows.....
A DSPSIZ(24 80 *DS3)
A R CALSFL SFL
A D1 2 0O 7 25EDTCDE(Z)
A COLOR(RED)
A D2 2Y 0O 7 30EDTCDE(Z)
A D3 2Y 0O 7 35EDTCDE(Z)
A D4 2Y 0O 7 40EDTCDE(Z)
A D5 2Y 0O 7 45EDTCDE(Z)
A D6 2Y 0O 7 50EDTCDE(Z)
A D7 2Y 0O 7 55EDTCDE(Z)
A R CALCTL SFLCTL(CALSFL)
A SFLSIZ(0006)
A SFLPAG(0006)
A CA03(03 'exit')
A 31 SFLDSP
A SFLDSPCTL
A 30 SFLCLR
A 5 24'SUN MON TUE WED THU FRI SAT'
A COLOR(BLU)
A 3 9'Year:'
A COLOR(BLU)
A 3 25'Month:'
A COLOR(BLU)
A DYR 4Y 0B 3 16EDTCDE(Z)
A RANGE(2000 9999)
A DMON 2Y 0B 3 33EDTCDE(Z)
A RANGE(1 12)
Main RPG program is as follows..............
************* CALLENDER PROGRAM ******************************************************
FCALDSP CF E WORKSTN
F RRN1 KSFILE CALSFL
E AR1 42 2 0
IDS1 DS
I 1 2 YR1
I 3 4 YR2
I 1 40YR
I 1 4 YRX
I 5 6 MON
C SETON 30
C WRITECALCTL
C SETOF 30
C EXFMTCALCTL
C *IN03 DOWEQ*OFF
C Z-ADD1 L 20
C Z-ADD0 RRN1 40
C EXSR MAINSR
C SETON 30
C WRITECALCTL
C SETOF 30
C L DOWLE42
C EXSR MOVSR
C ADD 1 L
C ADD 1 RRN1
C WRITECALSFL
C ENDDO
C RRN1 IFGT 0
C SETON 31
C ENDIF
C EXFMTCALCTL
C ENDDO
C SETON LR
******
C MAINSR BEGSR
C DMON IFEQ 0
C DYR OREQ 0
C Z-ADD2000 YR
C MOVE '01' MON
C ELSE
C Z-ADDDYR YR
C MOVE DMON MON
C ENDIF
C MOVEL'01' EDAT 8 P
C EDAT CAT MON:0 EDAT
C EDAT CAT YRX:0 EDAT
C Z-ADD0 DAYS 100
C CALL 'DATDIFF'
C PARM EDAT
C PARM DAYS
C EXSR CLRSR
C EXSR MONSR
C EXSR DAYSR
C EXSR CALSR
C ENDSR
******
C DAYSR BEGSR
C Z-ADD0 I 20
C DAYS DIV 7 DD 80
C MVR REM 10
C SELEC
C REM WHEQ 0
C Z-ADD7 I
C REM WHEQ 1
C Z-ADD1 I
C REM WHEQ 2
C Z-ADD2 I
C REM WHEQ 3
C Z-ADD3 I
C REM WHEQ 4
C Z-ADD4 I
C REM WHEQ 5
C Z-ADD5 I
C REM WHEQ 6
C Z-ADD6 I
C ENDSL
C ENDSR
****
C CALSR BEGSR
C Z-ADD1 CNT 20
C Z-ADD1 NUM 20
C Z-ADDI N 20
C CNT DOWLE42
C NUM IFGT MLEN
C LEAVE
C ENDIF
C CNT IFGE N
C MOVE NUM AR1,I
C ADD 1 I
C ADD 1 NUM
C ENDIF
C ADD 1 CNT
C ENDDO
C ENDSR
*****
C CLRSR BEGSR
C Z-ADD1 K 20
C K DOWLE42
C Z-ADD0 AR1,K
C ADD 1 K
C ENDDO
C ENDSR
*****
C CHKSR BEGSR
C DYR DIV 400 RES1 30
C MVR REM1 30
C DYR DIV 100 RES2 30
C MVR REM2 30
C DYR DIV 4 RES3 30
C MVR REM3 30
C REM1 IFEQ 0
C ADD 1 MLEN
C ELSE
C REM2 IFEQ 0
C ADD 0 MLEN
C ELSE
C REM3 IFEQ 0
C ADD 1 MLEN
C ENDIF
C ENDIF
C ENDIF
C ENDSR
*****
C MONSR BEGSR
C Z-ADD0 MLEN 20
C SELEC
C DMON WHEQ 1
C Z-ADD31 MLEN
C DMON WHEQ 2
C Z-ADD28 MLEN
C EXSR CHKSR
C DMON WHEQ 3
C Z-ADD31 MLEN
C DMON WHEQ 4
C Z-ADD30 MLEN
C DMON WHEQ 5
C Z-ADD31 MLEN
C DMON WHEQ 6
C Z-ADD30 MLEN
C DMON WHEQ 7
C Z-ADD31 MLEN
C DMON WHEQ 8
C Z-ADD31 MLEN
C DMON WHEQ 9
C Z-ADD30 MLEN
C DMON WHEQ 10
C Z-ADD31 MLEN
C DMON WHEQ 11
C Z-ADD30 MLEN
C DMON WHEQ 12
C Z-ADD31 MLEN
C ENDSL
C ENDSR
*****
C MOVSR BEGSR
C MOVEAAR1,L D1
C ADD 1 L
C MOVEAAR1,L D2
C ADD 1 L
C MOVEAAR1,L D3
C ADD 1 L
C MOVEAAR1,L D4
C ADD 1 L
C MOVEAAR1,L D5
C ADD 1 L
C MOVEAAR1,L D6
C ADD 1 L
C MOVEAAR1,L D7
C ENDSR
RPGLE - what kind of description? what shoule I do?
Posted By: Silas J Zhong Contact
what kind of description? what shoule I do? I hope to download the source for studing not for commercial goal
RPGLE - Callender Program extension
Posted By: Subhrajit Chandra Contact
This RPGLE program calculates the day difference between a fixed date and a gived variable date and return
the no of days. USing the output of this program Callender program will calculate the rest of the things.
********************************************************************************************
DATDIFF PROGRAM (RPGLE)
********************************************************************************************
Dsdate s d Inz(D'2000-01-01')
Dedate s d
DTimeStamp s z
C *entry plist
C parm date 8
C parm days 10 0
C* eval TimeStamp = %timeStamp()
C eval edate = %date(date: *eur0)
C eval days = %diff(edate: sdate: *days)
C* 'day' dsply days
C seton lr RPGLE - MINESWEEPER game
Posted By: subhrajit chandra Contact
This is an AS/400 implementaion of the famous windows game called 'MINESWEEPER'
This program also applies the hadling technique of push button display file field.
There are 3 available levels of the game.
Play the game as per the rule of the original game.
**************************************************************************************
MAIN DISPLAY FILE FOR THE GAME (minswdsp)
**************************************************************************************
A DSPSIZ(24 80 *DS3)
A R MINWND
A CA03(03)
A WINDOW(4 5 15 40)
A RMVWDW
A F1 2Y 0B 4 5PSHBTNFLD((*GUTTER 1))
A PSHBTNCHC(1 'O')
A PSHBTNCHC(2 'O')
A PSHBTNCHC(3 'O')
A PSHBTNCHC(4 'O')
A PSHBTNCHC(5 'O')
A PSHBTNCHC(6 'O')
A PSHBTNCHC(7 'O')
A PSHBTNCHC(8 'O')
A PSHBTNCHC(9 'O')
A PSHBTNCHC(10 'O')
A PSHBTNCHC(11 'O')
A PSHBTNCHC(12 'O')
A PSHBTNCHC(13 'O')
A PSHBTNCHC(14 'O')
A PSHBTNCHC(15 'O')
A PSHBTNCHC(16 'O')
A PSHBTNCHC(17 'O')
A PSHBTNCHC(18 'O')
A PSHBTNCHC(19 'O')
A PSHBTNCHC(20 'O')
A PSHBTNCHC(21 'O')
A PSHBTNCHC(22 'O')
A PSHBTNCHC(23 'O')
A PSHBTNCHC(24 'O')
A PSHBTNCHC(25 'O')
A PSHBTNCHC(26 'O')
A PSHBTNCHC(27 'O')
A PSHBTNCHC(28 'O')
A PSHBTNCHC(29 'O')
A PSHBTNCHC(30 'O')
A PSHBTNCHC(31 'O')
A PSHBTNCHC(32 'O')
A PSHBTNCHC(33 'O')
A PSHBTNCHC(34 'O')
A PSHBTNCHC(35 'O')
A PSHBTNCHC(36 'O')
A PSHBTNCHC(37 'O')
A PSHBTNCHC(38 'O')
A PSHBTNCHC(39 'O')
A PSHBTNCHC(40 'O')
A PSHBTNCHC(41 'O')
A PSHBTNCHC(42 'O')
A PSHBTNCHC(43 'O')
A PSHBTNCHC(44 'O')
A PSHBTNCHC(45 'O')
A PSHBTNCHC(46 'O')
A PSHBTNCHC(47 'O')
A PSHBTNCHC(48 'O')
A PSHBTNCHC(49 'O')
A PSHBTNCHC(50 'O')
A PSHBTNCHC(51 'O')
A PSHBTNCHC(52 'O')
A PSHBTNCHC(53 'O')
A PSHBTNCHC(54 'O')
A PSHBTNCHC(55 'O')
A PSHBTNCHC(56 'O')
A PSHBTNCHC(57 'O')
A PSHBTNCHC(58 'O')
A PSHBTNCHC(59 'O')
A PSHBTNCHC(60 'O')
A 1 15'Minesweepers'
A DSPATR(HI)
A R MINREC
A 1 3' '
A FLD001 1A O 8 50
A 20 COLOR(PNK)
A FLD002 1A O 8 54
A 21 COLOR(PNK)
A FLD003 1A O 8 58
A 22 COLOR(PNK)
A FLD004 1A O 8 62
A 23 COLOR(PNK)
A FLD005 1A O 8 66
A 24 COLOR(PNK)
A FLD006 1A O 8 70
A 25 COLOR(PNK)
A FLD007 1A O 9 50
A 26 COLOR(PNK)
A FLD008 1A O 9 54
A 27 COLOR(PNK)
A FLD009 1A O 9 58
A 28 COLOR(PNK)
A FLD010 1A O 9 62
A 29 COLOR(PNK)
A FLD011 1A O 9 66
A 30 COLOR(PNK)
A FLD012 1A O 9 70
A 31 COLOR(PNK)
A FLD013 1A O 10 50
A 32 COLOR(PNK)
A FLD014 1A O 10 54
A 33 COLOR(PNK)
A FLD015 1A O 10 58
A 34 COLOR(PNK)
A FLD016 1A O 10 62
A 35 COLOR(PNK)
A FLD017 1A O 10 66
A 36 COLOR(PNK)
A FLD018 1A O 10 70
A 37 COLOR(PNK)
A FLD019 1A O 11 50
A 38 COLOR(PNK)
A FLD020 1A O 11 54
A 39 COLOR(PNK)
A FLD021 1A O 11 58
A 40 COLOR(PNK)
A FLD022 1A O 11 62
A 41 COLOR(PNK)
A FLD023 1A O 11 66
A 42 COLOR(PNK)
A FLD024 1A O 11 70
A 43 COLOR(PNK)
A FLD025 1A O 12 50
A 44 COLOR(PNK)
A FLD026 1A O 12 54
A 45 COLOR(PNK)
A FLD027 1A O 12 58
A 46 COLOR(PNK)
A FLD028 1A O 12 62
A 47 COLOR(PNK)
A FLD029 1A O 12 66
A 48 COLOR(PNK)
A FLD030 1A O 12 70
A 49 COLOR(PNK)
A FLD031 1A O 13 50
A 50 COLOR(PNK)
A FLD032 1A O 13 54
A 51 COLOR(PNK)
A FLD033 1A O 13 58
A 52 COLOR(PNK)
A FLD034 1A O 13 62
A 53 COLOR(PNK)
A FLD035 1A O 13 66
A 54 COLOR(PNK)
A FLD036 1A O 13 70
A 55 COLOR(PNK)
A FLD037 1A O 14 50
A 56 COLOR(PNK)
A FLD038 1A O 14 54
A 57 COLOR(PNK)
A FLD039 1A O 14 58
A 58 COLOR(PNK)
A FLD040 1A O 14 62
A 59 COLOR(PNK)
A FLD041 1A O 14 66
A 60 COLOR(PNK)
A FLD042 1A O 14 70
A 61 COLOR(PNK)
A FLD043 1A O 15 50
A 62 COLOR(PNK)
A FLD044 1A O 15 54
A 63 COLOR(PNK)
A FLD045 1A O 15 58
A 64 COLOR(PNK)
A FLD046 1A O 15 62
A 65 COLOR(PNK)
A FLD047 1A O 15 66
A 66 COLOR(PNK)
A FLD048 1A O 15 70
A 67 COLOR(PNK)
A FLD049 1A O 16 50
A 68 COLOR(PNK)
A FLD050 1A O 16 54
A 69 COLOR(PNK)
A FLD051 1A O 16 58
A 70 COLOR(PNK)
A FLD052 1A O 16 62
A 71 COLOR(PNK)
A FLD053 1A O 16 66
A 72 COLOR(PNK)
A FLD054 1A O 16 70
A 73 COLOR(PNK)
A FLD055 1A O 17 50
A 74 COLOR(PNK)
A FLD056 1A O 17 54
A 75 COLOR(PNK)
A FLD057 1A O 17 58
A 76 COLOR(PNK)
A FLD058 1A O 17 62
A 77 COLOR(PNK)
A FLD059 1A O 17 66
A 78 COLOR(PNK)
A FLD060 1A O 17 70
A 79 COLOR(PNK)
A 6 58'Status'
A DSPATR(HI)
A 23 3'F3 = Exit'
A COLOR(BLU)
A 1 32'Subhrajit Chandra'
A COLOR(YLW)
A 21 4'You have taken'
A N99 DSPATR(ND)
A DMIN 2Y 0O 21 19
A N99 DSPATR(ND)
A 21 22'min and'
A N99 DSPATR(ND)
A DSEC 2Y 0O 21 30EDTCDE(Z)
A N99 DSPATR(ND)
A 21 33'seconds to complete the game'
A N99 DSPATR(ND)
A 23 16'There are maximum'
A COLOR(BLU)
A DBOMB 2Y 0O 23 34EDTCDE(Z)
A COLOR(BLU)
A 23 37'hidden bombs'
A COLOR(BLU)
A R RESULT
A WINDOW(10 17 5 25)
A RMVWDW
A RES1 15 O 2 6COLOR(RED)
A RES2 24 O 4 2DSPATR(HI)
*****************************************************************************************
******************************************************************************************
GAME ENTRY DISPLAY FILE (minsdsp)
******************************************************************************************
A DSPSIZ(24 80 *DS3)
A HLPTITLE('MINESWEEPER')
A HLPPNLGRP(GENERAL GAMEPNL)
A ALTHELP(CA01)
A HELP
A R ENTRY
A WINDOW(8 28 10 24)
A CA03(03)
A H HLPPNLGRP(INSTHLP GAMEPNL)
A HLPARA( 4 6 4 10)
A H HLPPNLGRP(ABUSHLP GAMEPNL)
A HLPARA( 5 6 5 10)
A 1 7'MINESWEEPERS'
A DSPATR(BL)
A COLOR(RED)
A F1 2Y 0B 3 6PSHBTNFLD((*NUMCOL 1))
A PSHBTNCHC(1 'START')
A PSHBTNCHC(2 'INSTRUCTION')
A PSHBTNCHC(3 'ABOUT US')
A F2 2Y 0B 9 9PSHBTNFLD
A PSHBTNCHC(1 'EXIT' CA03)
A R LEVREC
A WINDOW(8 28 10 24)
A CA12(12)
A F3 2Y 0B 3 7PSHBTNFLD((*NUMCOL 1))
A PSHBTNCHC(1 'LEVEL 1')
A PSHBTNCHC(2 'LEVEL 2')
A PSHBTNCHC(3 'LEVEL 3')
A F4 2Y 0B 9 9PSHBTNFLD
A PSHBTNCHC(1 'BACK' CA12)
A 1 7'SELECT LEVEL'
A DSPATR(UL)
A DSPATR(HI)
A R DUMMY
ASSUME
A 1 4' '
*****************************************************************************************
******************************************************************************************
MAIN PROGRAM FOR MINESWEEPER (minrpg)
******************************************************************************************
FFMINSWDSPCF E WORKSTN
E AR1 20 2 0
E AR2 60 2 0
I 'WON THE GAME' C WON
I 'GAME OVER' C LOSE
I 'CONGRADULATION!!!' C CON
IDS1 DS
I 1 140TMPSTM
I 1 20HR
I 3 40MIN
I 5 60SEC
C *ENTRY PLIST
C PARM BOM 20
C Z-ADD1 I 20
C Z-ADD1 N 20
C I DOWLEBOM
C CALL 'RANDOM'
C PARM RNBR 30
C MOVE RNBR AR1,I
C ADD 1 I
C ENDDO
C EXSR INMSR
C TIME TMPSTM
C Z-ADDMIN SMIN 20
C Z-ADDSEC SSEC 20
C 60 SUB BOM END 20
C *IN03 DOWEQ*OFF
C EXSR CLUESR
C EXFMTMINWND
C EXSR DONESR
C N80 EXSR CHKSR
C 81 LEAVE
C N IFEQ END
C LEAVE
C ENDIF
C ENDDO
C N03 EXSR RESSR
C SETON LR
******************************************************************************************
C CHKSR BEGSR
C Z-ADD1 J 20
C F1 LOKUPAR1,J 81
C EXSR HITSR
C ENDSR
******************************************************************************************
C HITSR BEGSR
C F1 IFNE 0
C MOVE F1 AR2,N
C ADD 1 N
C ENDIF
C ENDSR
******************************************************************************************
C DONESR BEGSR
C SETOF 80
C F1 IFNE 0
C Z-ADD1 K 20
C F1 LOKUPAR2,K 80
C ENDIF
C ENDSR
******************************************************************************************
C RESSR BEGSR
C EXSR CLUESR
C EXSR FINAL
C *IN81 IFEQ *ON
C MOVEL'OOPS!!!' RES1 P
C MOVELLOSE RES2 P
C EXFMTRESULT
C ELSE
C MOVELCON RES1 P
C MOVELWON RES2 P
C EXFMTRESULT
C ENDIF
C ENDSR
******************************************************************************************
C CLUESR BEGSR
C Z-ADD0 FN 20
C Z-ADD0 FNW 20
C Z-ADD0 FSW 20
C Z-ADD0 FW 20
C Z-ADD0 FS 20
C Z-ADD0 FE 20
C Z-ADD0 FSE 20
C Z-ADD0 FNE 20
C Z-ADD0 CNT 10
C Z-ADD1 L 20
C EXSR CALSR
C EXSR MOVSR
C Z-ADDBOM DBOMB
C WRITEMINREC
C ENDSR
******************************************************************************************
C ALLSR BEGSR
C F1 SUB 6 FN
C Z-ADD1 L
C FN LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 7 FNW
C Z-ADD1 L
C FNW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 5 FSW
C Z-ADD1 L
C FSW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 1 FW
C Z-ADD1 L
C FW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 6 FS
C Z-ADD1 L
C FS LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 1 FE
C Z-ADD1 L
C FE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 7 FSE
C Z-ADD1 L
C FSE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 5 FNE
C Z-ADD1 L
C FNE LOKUPAR1,L 91
C 91 ADD 1 CNT
C ENDSR
******************************************************************************************
C MOVSR BEGSR
C SELEC
C F1 WHEQ 1
C MOVE CNT FLD001
C SETON 20
C F1 WHEQ 2
C MOVE CNT FLD002
C SETON 21
C F1 WHEQ 3
C MOVE CNT FLD003
C SETON 22
C F1 WHEQ 4
C MOVE CNT FLD004
C SETON 23
C F1 WHEQ 5
C MOVE CNT FLD005
C SETON 24
C F1 WHEQ 6
C MOVE CNT FLD006
C SETON 25
C F1 WHEQ 7
C MOVE CNT FLD007
C SETON 26
C F1 WHEQ 8
C MOVE CNT FLD008
C SETON 27
C F1 WHEQ 9
C MOVE CNT FLD009
C SETON 28
C F1 WHEQ 10
C MOVE CNT FLD010
C SETON 29
C F1 WHEQ 11
C MOVE CNT FLD011
C SETON 30
C F1 WHEQ 12
C MOVE CNT FLD012
C SETON 31
C F1 WHEQ 13
C MOVE CNT FLD013
C SETON 32
C F1 WHEQ 14
C MOVE CNT FLD014
C SETON 33
C F1 WHEQ 15
C MOVE CNT FLD015
C SETON 34
C F1 WHEQ 16
C MOVE CNT FLD016
C SETON 35
C F1 WHEQ 17
C MOVE CNT FLD017
C SETON 36
C F1 WHEQ 18
C MOVE CNT FLD018
C SETON 37
C F1 WHEQ 19
C MOVE CNT FLD019
C SETON 38
C F1 WHEQ 20
C MOVE CNT FLD020
C SETON 39
C F1 WHEQ 21
C MOVE CNT FLD021
C SETON 40
C F1 WHEQ 22
C MOVE CNT FLD022
C SETON 41
C F1 WHEQ 23
C MOVE CNT FLD023
C SETON 42
C F1 WHEQ 24
C MOVE CNT FLD024
C SETON 43
C F1 WHEQ 25
C MOVE CNT FLD025
C SETON 44
C F1 WHEQ 26
C MOVE CNT FLD026
C SETON 45
C F1 WHEQ 27
C MOVE CNT FLD027
C SETON 46
C F1 WHEQ 28
C MOVE CNT FLD028
C SETON 47
C F1 WHEQ 29
C MOVE CNT FLD029
C SETON 48
C F1 WHEQ 30
C MOVE CNT FLD030
C SETON 49
C F1 WHEQ 31
C MOVE CNT FLD031
C SETON 50
C F1 WHEQ 32
C MOVE CNT FLD032
C SETON 51
C F1 WHEQ 33
C MOVE CNT FLD033
C SETON 52
C F1 WHEQ 34
C MOVE CNT FLD034
C SETON 53
C F1 WHEQ 35
C MOVE CNT FLD035
C SETON 54
C F1 WHEQ 36
C MOVE CNT FLD036
C SETON 55
C F1 WHEQ 37
C MOVE CNT FLD037
C SETON 56
C F1 WHEQ 38
C MOVE CNT FLD038
C SETON 57
C F1 WHEQ 39
C MOVE CNT FLD039
C SETON 58
C F1 WHEQ 40
C MOVE CNT FLD040
C SETON 59
C F1 WHEQ 41
C MOVE CNT FLD041
C SETON 60
C F1 WHEQ 42
C MOVE CNT FLD042
C SETON 61
C F1 WHEQ 43
C MOVE CNT FLD043
C SETON 62
C F1 WHEQ 44
C MOVE CNT FLD044
C SETON 63
C F1 WHEQ 45
C MOVE CNT FLD045
C SETON 64
C F1 WHEQ 46
C MOVE CNT FLD046
C SETON 65
C F1 WHEQ 47
C MOVE CNT FLD047
C SETON 66
C F1 WHEQ 48
C MOVE CNT FLD048
C SETON 67
C F1 WHEQ 49
C MOVE CNT FLD049
C SETON 68
C F1 WHEQ 50
C MOVE CNT FLD050
C SETON 69
C F1 WHEQ 51
C MOVE CNT FLD051
C SETON 70
C F1 WHEQ 52
C MOVE CNT FLD052
C SETON 71
C F1 WHEQ 53
C MOVE CNT FLD053
C SETON 72
C F1 WHEQ 54
C MOVE CNT FLD054
C SETON 73
C F1 WHEQ 55
C MOVE CNT FLD055
C SETON 74
C F1 WHEQ 56
C MOVE CNT FLD056
C SETON 75
C F1 WHEQ 57
C MOVE CNT FLD057
C SETON 76
C F1 WHEQ 58
C MOVE CNT FLD058
C SETON 77
C F1 WHEQ 59
C MOVE CNT FLD059
C SETON 78
C F1 WHEQ 60
C MOVE CNT FLD060
C SETON 79
C ENDSL
C ENDSR
******************************************************************************************
C INMSR BEGSR
C MOVE 'O' FLD001
C MOVE 'O' FLD002
C MOVE 'O' FLD003
C MOVE 'O' FLD004
C MOVE 'O' FLD005
C MOVE 'O' FLD006
C MOVE 'O' FLD007
C MOVE 'O' FLD008
C MOVE 'O' FLD009
C MOVE 'O' FLD010
C MOVE 'O' FLD011
C MOVE 'O' FLD012
C MOVE 'O' FLD013
C MOVE 'O' FLD014
C MOVE 'O' FLD015
C MOVE 'O' FLD016
C MOVE 'O' FLD017
C MOVE 'O' FLD018
C MOVE 'O' FLD019
C MOVE 'O' FLD020
C MOVE 'O' FLD021
C MOVE 'O' FLD022
C MOVE 'O' FLD023
C MOVE 'O' FLD024
C MOVE 'O' FLD025
C MOVE 'O' FLD026
C MOVE 'O' FLD027
C MOVE 'O' FLD028
C MOVE 'O' FLD029
C MOVE 'O' FLD030
C MOVE 'O' FLD031
C MOVE 'O' FLD032
C MOVE 'O' FLD033
C MOVE 'O' FLD034
C MOVE 'O' FLD035
C MOVE 'O' FLD036
C MOVE 'O' FLD037
C MOVE 'O' FLD038
C MOVE 'O' FLD039
C MOVE 'O' FLD040
C MOVE 'O' FLD041
C MOVE 'O' FLD042
C MOVE 'O' FLD043
C MOVE 'O' FLD044
C MOVE 'O' FLD045
C MOVE 'O' FLD046
C MOVE 'O' FLD047
C MOVE 'O' FLD048
C MOVE 'O' FLD049
C MOVE 'O' FLD050
C MOVE 'O' FLD051
C MOVE 'O' FLD052
C MOVE 'O' FLD053
C MOVE 'O' FLD054
C MOVE 'O' FLD055
C MOVE 'O' FLD056
C MOVE 'O' FLD057
C MOVE 'O' FLD058
C MOVE 'O' FLD059
C MOVE 'O' FLD060
C ENDSR
******************************************************************************************
C UPSR BEGSR
C F1 SUB 6 FN
C Z-ADD1 L
C FN LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 1 FW
C Z-ADD1 L
C FW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 7 FNW
C Z-ADD1 L
C FNW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 1 FE
C Z-ADD1 L
C FE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 5 FNE
C Z-ADD1 L
C FNE LOKUPAR1,L 91
C 91 ADD 1 CNT
C ENDSR
******************************************************************************************
C DOWNSR BEGSR
C F1 ADD 5 FSW
C Z-ADD1 L
C FSW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 1 FW
C Z-ADD1 L
C FW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 6 FS
C Z-ADD1 L
C FS LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 1 FE
C Z-ADD1 L
C FE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 7 FSE
C Z-ADD1 L
C FSE LOKUPAR1,L 91
C 91 ADD 1 CNT
C ENDSR
******************************************************************************************
C RGHTSR BEGSR
C F1 SUB 6 FN
C Z-ADD1 L
C FN LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 6 FS
C Z-ADD1 L
C FS LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 1 FE
C Z-ADD1 L
C FE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 7 FSE
C Z-ADD1 L
C FSE LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 5 FNE
C Z-ADD1 L
C FNE LOKUPAR1,L 91
C 91 ADD 1 CNT
C ENDSR
******************************************************************************************
C LEFTSR BEGSR
C Z-ADD1 L
C F1 SUB 6 FN
C FN LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 7 FNW
C Z-ADD1 L
C FNW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 5 FSW
C Z-ADD1 L
C FSW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 SUB 1 FW
C Z-ADD1 L
C FW LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 ADD 6 FS
C Z-ADD1 L
C FS LOKUPAR1,L 91
C 91 ADD 1 CNT
C ENDSR
******************************************************************************************
C CALSR BEGSR
C F1 DIV 6 QTN 20
C MVR F2 10
C SELEC
C F1 WHGT 1
C F1 ANDLT6
C EXSR DOWNSR
C F1 WHGT 55
C F1 ANDLT60
C EXSR UPSR
C F2 WHEQ 1
C F1 ANDNE1
C F1 ANDNE55
C EXSR RGHTSR
C F2 WHEQ 0
C F1 ANDNE6
C F1 ANDNE60
C EXSR LEFTSR
C F1 WHEQ 1
C Z-ADD1 L
C 02 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 07 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 08 LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 WHEQ 6
C Z-ADD1 L
C 05 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 11 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 12 LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 WHEQ 55
C Z-ADD1 L
C 49 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 50 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 56 LOKUPAR1,L 91
C 91 ADD 1 CNT
C F1 WHEQ 60
C Z-ADD1 L
C 53 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 54 LOKUPAR1,L 91
C 91 ADD 1 CNT
C Z-ADD1 L
C 59 LOKUPAR1,L 91
C 91 ADD 1 CNT
C OTHER
C EXSR ALLSR
C ENDSL
C ENDSR
******************************************************************************************
C FINAL BEGSR
C Z-ADD1 I
C MOVE '*' BOMB 1
C I DOWLEBOM
C SELEC
C AR1,I WHEQ 1
C MOVE BOMB FLD001
C SETON 20
C AR1,I WHEQ 2
C MOVE BOMB FLD002
C SETON 21
C AR1,I WHEQ 3
C MOVE BOMB FLD003
C SETON 22
C AR1,I WHEQ 4
C MOVE BOMB FLD004
C SETON 23
C AR1,I WHEQ 5
C MOVE BOMB FLD005
C SETON 24
C AR1,I WHEQ 6
C MOVE BOMB FLD006
C SETON 25
C AR1,I WHEQ 7
C MOVE BOMB FLD007
C SETON 26
C AR1,I WHEQ 8
C MOVE BOMB FLD008
C SETON 27
C AR1,I WHEQ 9
C MOVE BOMB FLD009
C SETON 28
C AR1,I WHEQ 10
C MOVE BOMB FLD010
C SETON 29
C AR1,I WHEQ 11
C MOVE BOMB FLD011
C SETON 30
C AR1,I WHEQ 12
C MOVE BOMB FLD012
C SETON 31
C AR1,I WHEQ 13
C MOVE BOMB FLD013
C SETON 32
C AR1,I WHEQ 14
C MOVE BOMB FLD014
C SETON 33
C AR1,I WHEQ 15
C MOVE BOMB FLD015
C SETON 34
C AR1,I WHEQ 16
C MOVE BOMB FLD016
C SETON 35
C AR1,I WHEQ 17
C MOVE BOMB FLD017
C SETON 36
C AR1,I WHEQ 18
C MOVE BOMB FLD018
C SETON 37
C AR1,I WHEQ 19
C MOVE BOMB FLD019
C SETON 38
C AR1,I WHEQ 20
C MOVE BOMB FLD020
C SETON 39
C AR1,I WHEQ 21
C MOVE BOMB FLD021
C SETON 40
C AR1,I WHEQ 22
C MOVE BOMB FLD022
C SETON 41
C AR1,I WHEQ 23
C MOVE BOMB FLD023
C SETON 42
C AR1,I WHEQ 24
C MOVE BOMB FLD024
C SETON 43
C AR1,I WHEQ 25
C MOVE BOMB FLD025
C SETON 44
C AR1,I WHEQ 26
C MOVE BOMB FLD026
C SETON 45
C AR1,I WHEQ 27
C MOVE BOMB FLD027
C SETON 46
C AR1,I WHEQ 28
C MOVE BOMB FLD028
C SETON 47
C AR1,I WHEQ 29
C MOVE BOMB FLD029
C SETON 48
C AR1,I WHEQ 30
C MOVE BOMB FLD030
C SETON 49
C AR1,I WHEQ 31
C MOVE BOMB FLD031
C SETON 50
C AR1,I WHEQ 32
C MOVE BOMB FLD032
C SETON 51
C AR1,I WHEQ 33
C MOVE BOMB FLD033
C SETON 52
C AR1,I WHEQ 34
C MOVE BOMB FLD034
C SETON 53
C AR1,I WHEQ 35
C MOVE BOMB FLD035
C SETON 54
C AR1,I WHEQ 36
C MOVE BOMB FLD036
C SETON 55
C AR1,I WHEQ 37
C MOVE BOMB FLD037
C SETON 56
C AR1,I WHEQ 38
C MOVE BOMB FLD038
C SETON 57
C AR1,I WHEQ 39
C MOVE BOMB FLD039
C SETON 58
C AR1,I WHEQ 40
C MOVE BOMB FLD040
C SETON 59
C AR1,I WHEQ 41
C MOVE BOMB FLD041
C SETON 60
C AR1,I WHEQ 42
C MOVE BOMB FLD042
C SETON 61
C AR1,I WHEQ 43
C MOVE BOMB FLD043
C SETON 62
C AR1,I WHEQ 44
C MOVE BOMB FLD044
C SETON 63
C AR1,I WHEQ 45
C MOVE BOMB FLD045
C SETON 64
C AR1,I WHEQ 46
C MOVE BOMB FLD046
C SETON 65
C AR1,I WHEQ 47
C MOVE BOMB FLD047
C SETON 66
C AR1,I WHEQ 48
C MOVE BOMB FLD048
C SETON 67
C AR1,I WHEQ 49
C MOVE BOMB FLD049
C SETON 68
C AR1,I WHEQ 50
C MOVE BOMB FLD050
C SETON 69
C AR1,I WHEQ 51
C MOVE BOMB FLD051
C SETON 70
C AR1,I WHEQ 52
C MOVE BOMB FLD052
C SETON 71
C AR1,I WHEQ 53
C MOVE BOMB FLD053
C SETON 72
C AR1,I WHEQ 54
C MOVE BOMB FLD054
C SETON 73
C AR1,I WHEQ 55
C MOVE BOMB FLD055
C SETON 74
C AR1,I WHEQ 56
C MOVE BOMB FLD056
C SETON 75
C AR1,I WHEQ 57
C MOVE BOMB FLD057
C SETON 76
C AR1,I WHEQ 58
C MOVE BOMB FLD058
C SETON 77
C AR1,I WHEQ 59
C MOVE BOMB FLD059
C SETON 78
C AR1,I WHEQ 60
C MOVE BOMB FLD060
C SETON 79
C ENDSL
C ADD 1 I
C ENDDO
C TIME TMPSTM
C SETON 99
C SMIN MULT 60 TPSEC 40
C ADD SSEC TPSEC
C MIN MULT 60 TCSEC 40
C ADD SEC TCSEC
C TCSEC SUB TPSEC TPSEC
C TPSEC DIV 60 DMIN
C MVR DSEC
C WRITEMINREC
C ENDSR
******************************************************************************************
******************************************************************************************
STARTING PROGRAM (gamepgm)
******************************************************************************************
FMINSDSP CF E WORKSTN
C *IN03 DOWEQ*OFF
C EXFMTENTRY
C SELEC
C F1 WHEQ 1
C EXSR LEVEL
C F1 WHEQ 2
C SETON 01
C ITER
C F1 WHEQ 3
C F2 WHEQ 1
C LEAVE
C ENDSL
C ENDDO
C SETON LR
******************************************************************************************
C LEVEL BEGSR
C *IN12 DOWEQ*OFF
C EXFMTLEVREC
C SELEC
C F3 WHEQ 1
C CALL 'MINRPG'
C PARM 10 BOMB 20
C LEAVE
C F3 WHEQ 2
C CALL 'MINRPG'
C PARM 15 BOMB 20
C LEAVE
C F3 WHEQ 3
C CALL 'MINRPG'
C PARM 20 BOMB 20
C LEAVE
C F4 WHEQ 1
C LEAVE
C ENDSL
C ENDDO
C SETOF 12
C ENDSR
******************************************************************************************
******************************************************************************************
RANDOM NUMBER GENERATION PROGRAM (random)
******************************************************************************************
DCOSeed s 5i 0 inz(0)
DCORndNbr s 8f
**-- Random Number Conversion: ---------------------------------- **
DRndNbr S 10I 0
DMaxNbr S 10I 0 Inz(61)
DMinNbr S 10I 0 Inz(1)
**
**----------------------------------------------------------------**
**
C *entry plist
C parm RNBR 3 0
C DoU RndNbr >= MinNbr
**
C CALLB 'CEERAN0'
C Parm COSeed
C Parm CORndNbr
C Parm *OMIT
C Eval RndNbr = %DecH(CORndNbr:5:4) * MaxNbr
C z-add RndNbr RNBR
C enddo
C seton lr
RPGLE - Work With SFL Example - JA0503
Posted By: John Albert Contact
h dftname(JA0503)
*---------------------------------------------------------------*
* *
* Name: JA0503 - W/W SFL MODEL *
* *
* Abstract: This program model can be used for developing *
* sfl processing programs *
* *
* *
* General Logic: *
* initial processing (*inzsr) *
* *
* *
*---------------------------------------------------------------*
* Modifications *
* ------------- *
* date developer project description *
* -------- ---------- -------- -------------------------------- *
* 04/22/98 j albert initial version *
* *
* *
* *
*---------------------------------------------------------------*
fJA0503FM CF E Workstn
f infds(AUINFDS)
f sfile(JA0503S1:sflrrn)
* Table File
fJAMDTBP IF E K Disk
* ---------------
* tables/arrays
* ---------------
d Optns S 12A DIM(3) PERRCD(1) CTDATA
*
* -----------------
* data sturctures
* -----------------
*
* program status data structure
d PgmStat SDS
d qpPgm 1 10
*
*
* file information data structure - display file
d AUINFDS ds
*-------
d QFRcdFmt *RECORD
d QFAid 369 369
d QFCsrl 370 371b 0
d QFSflRRN 376 377I 0
*------------------
* named indicators
*------------------
d ptrindicators s * inz(%addr(*in))
d indicators DS based(ptrindicators)
d SflRI_PC 30 30n
d DspAtrPR 31 31n
*
d SflDsp 90 90n
d SflDspCtl 91 91n
d SflClr 92 92n
d SflEnd 93 93n
d SflNxtChg 94 94n
d MsgSflEnd 95 95n
*
*-----------------
* named constants
*-----------------
* function key aid return values
d CF03 c const(x'33')
d CF05 c CONST(X'35')
d Enter c const(x'F1')
d PageDown c const(x'F5')
d SflPage c 12
d SflSize c 13
d Title c ' Application Title '
d Function c 'JA0503 - SFL Table Maint Model'
* xxxxxxxxxxooooooooooxxxxxxxxxx
*-----------------
* Message Subfile
*-----------------
d msgId s 7
d msgLoc s 20 inz('JAMSGF *LIBL ')
d msgData s 80
d msgDataLen s 10i 0 Inz(%Size(MsgData))
d msgType s 10 inz('*DIAG')
d msgQueue s 276A inz('*')
d msgCallStack s 10i 0 inz(0)
d msgKey s 4 inz(' ')
d msgErr s 10i 0 inz(0)
*
d msgrmv s 10A inz('*ALL')
*
*--------------------
* Stand Alone Fields
*--------------------
d RcdCnt s 5p 0
d SFLrrn s 5p 0
d LstSFLrrn s 5p 0
d err_Sflrrn s 5p 0
d ISODate S D datfmt(*ISO)
*
* Logical Variables
d Active s n
d SetFile s n
d SetPageRRN s n
d Err_SflOpt s n
*
* initial processing performed by *inzsr subroutine
*--------------
* Main Section
*--------------
c ExSr ClearSFL
c ExSr LoadSFL
*
c DOW Active
*
* Clear/Load/Display the SFL
c ExSr DspSFL
*
* Process SFL if Enter Key pressed, otherwise process cmd key
c If QFAid = Enter
c ExSr ProcSFL
c Else
c ExSr ProcCMD
c EndIf
*
c EndDo
* Exit Program
c eval *inlr = *on
*
*-----------------------------------------------------
* Display Active Panel
*-----------------------------------------------------
c DspSFL BegSr
* ~~~~~~ ~~~~~
* display SFL
c eval SflClr = *off
c eval SflDsp = *on
c eval SflDspCtl = *on
c Write JA0503K1
*
* write any error messages
c write msgctl
*
* Position to SFL page with error record
c If Err_SflOpt
c eval C1SFLRcd = err_Sflrrn
c EndIf
*
c ExFmt JA0503C1
*
c eval msgKey = *blanks
c ExSr ClearMsg
*
* Keep SFL on same page
c If C1CsrRRN <> *zero
c eval C1SFLRcd = C1CsrRRN
c EndIf
c EndSr
*-----------------------------------------------------
* Process Subfile
*-----------------------------------------------------
c ProcSfl BegSr
* ~~~~~~~ ~~~~~
c Eval Err_SflOpt = *off
*
* Check if user requested position to field
c If SCPosn <> *zero
c Eval SetFile = *on
c ExSr ClearSfl
c Exsr LoadSFL
*
* Process SFL records
c Else SCPosn = *zero
c READC(E) JA0503S1
c DOW not %EOF(JA0503FM) and
c not Err_SflOpt and
c Active
c
c ExSr ProcSflRcd
c UpDate JA0503S1
*
c If not Err_SflOpt
c eval C1SFLRcd = SFLrrn
c READC(E) JA0503S1
c EndIf
*
c EndDo
c EndIf SCPosn <> *zero
*
c EndSr
*-----------------------------------------------------
* Process Function Keys
*-----------------------------------------------------
c ProcCmd BegSr
* ~~~~~~~ ~~~~~
c Select
*
* CF03=Exit
c When QFAid = CF03
c eval Active = *off
*
* CF05=Refresh
c When QFAid = CF05
c clear scposn
c eval SetFile = *on
c ExSr ClearSfl
c ExSr LoadSFL
*
* PageDown
c When QFAid = PageDown
c ExSr LoadSfl
c EndSL
*
c EndSr
*-----------------------------------------------------
* Process Subfile Record
*-----------------------------------------------------
c ProcSflRcd BegSr
* ~~~~~~~~~~ ~~~~~
c Eval SflNxtChg = *off
c Eval SflRI_PC = *off
*
c Select
c When S1Slct = 0
c clear S1Slct
*
* Process Option 5 - Display
c When S1Slct = 5
c eval DspAtrPR = *on
c ExFmt JA0503R1
c eval DspAtrPR = *on
c clear S1Slct
*
* Handle Command Keys from record - only concerned with F3
c Select
c When QFAid = CF03
c Eval Active = *off
c EndSl
*
* User entered invalid option
c Other SCPosn = *zero
c eval Err_SflOpt = *on
c eval err_Sflrrn = SFLrrn
c Eval SflNxtChg = *on
c Eval SflRI_PC = *on
*
c movel(p) 'JWA0004' MsgId
c eval msgData = %CHAR(S1Slct)
c eval msgDataLen = %len(msgData)
c ExSr SendMsg
*
c EndSl
*
c EndSr
*-----------------------------------------------------
* Load SFL - perform initial load to an empty sfl
*-----------------------------------------------------
c LoadSFL BegSr
* ~~~~~~~ ~~~~~
*
* Check if load or append
c If not SetFile
*
c eval SFLrrn = LstSFLrrn
c Else
*
c eval SFLrrn = 0
*
* Check of position-to requested
c If SCPosn <> *zero
c SCPosn SetLL JAMDTBP
c Else
c *Start SetLL JAMDTBP
c EndIf
c EndIf
*
c Clear SCPosn
c eval SetPageRRN = *on
c eval SflRI_PC = *off
c eval SetFile = *off
c eval RcdCnt = 0
*
c Read JAMDTBR
c DOW not %eof(JAMDTBP) and
c RcdCnt < SFLPage
*
c clear S1Slct
c eval S1Code = TBCODE
c movel TBDESC S1DESC
*
c clear S1EffDte
c clear S1ExpDte
c If TBEffDte <> 0
c *ISO Move TBEffDte ISOdate
c *USA Move ISODate S1EffDte
c EndIf
c If TBExpDte <> 0
c *ISO Move TBExpDte ISOdate
c *USA Move ISODate S1ExpDte
c EndIf
*
c move TBSTATUS S1STAT
c move TBCLASS S1CLAS
*
c eval SFLrrn = SFLrrn + 1
c eval RcdCnt = RcdCnt + 1
*
c If SetPageRRN
c eval SetPageRRN = *off
c eval C1SFLRcd = SFLrrn
c EndIf
*
c Write JA0503S1
c Read JAMDTBR
c EndDo
*
c If not %eof(JAMDTBP)
c ReadP JAMDTBR
c EndIf
*
*
c If RcdCnt > *zero
c eval LstSFLrrn = SFLrrn
c Else
c eval C1SFLRcd = LstSFLrrn
c EndIf
*
c eval SflEnd = %eof(JAMDTBP)
*
c EndSr
*-----------------------------------------------------
* Clear SFL
*-----------------------------------------------------
c ClearSFL BegSr
* ~~~~~~~~ ~~~~~
c Eval SflClr = *on
c Eval SflDsp = *off
c Eval SflDspCtl = *off
c Write JA0503C1
c Eval SflClr = *off
c EndSr
*-----------------------------------------------------
* SendMsg - Send a message to the message subfile
*-----------------------------------------------------
c SendMsg Begsr
* ------- -----
c call 'QMHSNDPM'
c parm msgId
c parm msgLoc
c parm msgData
c parm msgDataLen
c parm msgType
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgErr
*
c endsr
*-----------------------------------------------------
* ClearMsg - Clear the messages from the screen
*-----------------------------------------------------
c ClearMsg Begsr
* -------- -----
c call 'QMHRMVPM'
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgRmv
c parm msgErr
*
c endsr
*
*-----------------------------------------------------
* perform initial processing
*-----------------------------------------------------
c *InzSr BegSr
* ~~~~~~ ~~~~~
c eval Active = *on
c eval SetFile = *on
c eval SCOptns = Optns(1)
c eval SCTitl = Title
c eval SCFunc = Function
c EndSr
*
**CTDATA Optns
5=Display
A*
A*----------------------------------------------------------*
A* Name: JA0503FM - W/W SFL MODEL (DSPF) *
A* *
A* Abstract: *
A* *
A* Modifications *
A* ------------- *
A* Date Developer Project Description *
A* -------- ---------- ---------- ------------------------- *
A* *
A*----------------------------------------------------------*
A*%%EC
A DSPSIZ(24 80 *DS3)
A HLPTITLE('FILE LEVEL TITLE')
A HLPPNLGRP(EXTENDED JA0503HP)
A ALTHELP(CA01)
A HELP
A CF03
A CF05
A*----------------------------------------------------------*
A R JA0503S1 SFL
A*
A 94 SFLNXTCHG
A S1CODE 2S 0O 9 7
A S1DESC 30A O 9 11
A S1EFFDTE 8Y 0O 9 43EDTWRD(' / / ')
A S1EXPDTE 8Y 0O 9 55EDTWRD(' / / ')
A S1STAT 1A O 9 68
A S1CLAS 2A O 9 74
A S1SLCT 2Y 0B 9 3EDTCDE(Z)
A 30 DSPATR(RI)
A 30 DSPATR(PC)
A*----------------------------------------------------------*
A R JA0503C1 SFLCTL(JA0503S1)
A*
A SFLSIZ(0013)
A SFLPAG(0012)
A N93 PAGEDOWN
A CSRLOC(LINNBR POSNBR)
A OVERLAY
A SFLCSRRRN(&SCCSRRRN)
A 91 SFLDSP
A 90 SFLDSPCTL
A 92 SFLCLR
A 93 SFLEND
A H HLPPNLGRP(EXTENDEDC1 JA0503HP)
A HLPARA(*NONE)
A*
A SCSFLRCD 4S 0H SFLRCDNBR(CURSOR)
A LINNBR 3S 0H
A POSNBR 3S 0H
A SCCSRRRN 5S 0H
A*
A 1 2SYSNAME
A 1 11USER
A SCTITL 30A O 1 32
A 1 73DATE
A EDTCDE(Y)
A 2 2'JA0503C1'
A SCFUNC 30A O 2 32COLOR(WHT)
A 2 73TIME
A 4 2'Type options, press Enter.'
A COLOR(BLU)
A SCOPTNS 65A O 5 2
A 7 1'Posn:'
A SCPOSN 2Y 0B 7 7TEXT('Position to Code')
A EDTCDE(Z)
A 8 2'Opt'
A DSPATR(UL)
A COLOR(WHT)
A 8 6'Code'
A DSPATR(UL)
A COLOR(WHT)
A 8 11'Description'
A DSPATR(UL)
A COLOR(WHT)
A 8 43' Eff Date'
A DSPATR(UL)
A COLOR(WHT)
A 8 55' Exp Date'
A DSPATR(UL)
A COLOR(WHT)
A 8 67'Stat'
A DSPATR(HI)
A DSPATR(UL)
A 8 73'Class'
A DSPATR(HI)
A DSPATR(UL)
A*----------------------------------------------------------*
A R JA0503K1
A*
A H HLPPNLGRP(CF03 JA0501HP)
A HLPARA(*CNST 003)
A 22 2'F3=Exit'
A HLPID(003)
A COLOR(BLU)
A 22 11'F5=Refresh'
A HLPID(005)
A COLOR(BLU)
A 22 67'PageUp/PageDn'
A COLOR(BLU)
A*
A*----------------------------------------------------------*
A R JA0503R1
A*
A OVERLAY
A 08 CF08
A CF12
A CSRLOC(LINNBR POSNBR)
A H HLPPNLGRP(EXTENDEDR1 JA0503HP)
A HLPARA(*NONE)
A LINNBR 3S 0H
A POSNBR 3S 0H
A 1 2SYSNAME
A 1 11USER
A SCTITL 30A O 1 32
A 1 73DATE
A EDTCDE(Y)
A 2 2'JA0503R1'
A SCFUNC 30A O 2 32COLOR(WHT)
A 2 73TIME
A 4 2'Enter or change data, Press Enter.'
A COLOR(BLU)
A DSPATR(UL)
A 7 6'Code ..............:'
A DSPATR(HI)
A 9 6'Description .......:'
A DSPATR(HI)
A 22 2'F3=Exit'
A COLOR(BLU)
A 22 22'F12=Cancel'
A COLOR(BLU)
A S1DESC 30A B 9 28
A 31 DSPATR(PR)
A S1CODE 2S 0O 7 28
A 11 6'Effective Date ....:'
A DSPATR(HI)
A S1EFFDTE 8Y 0B 11 28EDTCDE(Y)
A 31 DSPATR(PR)
A 13 6'Expiration Date ...:'
A DSPATR(HI)
A S1EXPDTE 8Y 0B 13 28EDTCDE(Y)
A 31 DSPATR(PR)
A 15 6'Status ............:'
A DSPATR(HI)
A 17 6'Class .............:'
A DSPATR(HI)
A S1STATUS 1A B 15 28
A 31 DSPATR(PR)
A S1CLASS 2A B 17 28
A 31 DSPATR(PR)
A 08 22 11'F8=Update'
A COLOR(BLU)
A HLPID(003)
A*
A*----------------------------------------------------------*
A* MESSAGE SUBFILE RECORD
A*----------------------------------------------------------*
A R MSGSFL SFL
A*%%TS SD 20051110 152123 JOHNA REL-V5R3M0 5722-WDS
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A QPPGM SFLPGMQ
A*----------------------------------------------------------*
A* MESSAGE SUBFILE CONTROL RECORD
A*----------------------------------------------------------*
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N95 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A QPPGM SFLPGMQ
.*----------------------------------------------------------*
.* Name: JA0503HP - SFL Model 1 (PNLGRP) *
.* *
.* Abstract: *
.* *
.* Modifications *
.* ------------- *
.* Date Developer Project Description *
.* -------- ---------- ---------- ------------------------- *
.* *
.* *
.*----------------------------------------------------------*
:PNLGRP.
:HELP name=EXTENDED.
:P.
Help text that pertains to the entire file.
:EHELP.
:HELP name=EXTENDEDC1.Record Format JA0503C1
:xh3.Record Format JA0503C1
:P.
Information for record format JA0503C1.
:EHELP.
:HELP name=EXTENDEDR1.Record Format JA0503S1
:xh3.Record Format JA0503S1
:P.
Information for record format JA0503S1.
:EHELP.
:HELP name=scfl01.Field SCFL01
:xh3.Field 001
:P.
field 001 help text.
:EHELP.
:HELP name=options.Subfile Options
:xh3.Selection Options
:P.
Help text describing available options.
:EHELP.
:HELP name=cf03.Cmd Function Key 03
:xh3.F3=Exit
:P.
Command key 3 is used to exit the program.
:EHELP.
:HELP name=cf05.Cmd Function Key 05
:xh3.F5=Refresh
:P.
Command key 5 is used to refresh the screen.
:EHELP.
:HELP name=cf12.Cmd Function Key 12
:xh3.F12=Cancel
:P.
Command key 12 is used to cancel the current screen.
:EHELP.
:EPNLGRP.
A*---------------------------------------------------------------*
A* *
A* FILE NAME: JAMDTBP - SFL Maint Model table file (PF) *
A* *
A* Abstract: This file used as example for SFL Table Maint *
A* model *
A* *
A* Notes: *
A* *
A*---------------------------------------------------------------*
A* Modifications *
A* ------------- *
A* date developer project description *
A* -------- ---------- ---------- ------------------------------ *
A* 04/28/06 j albert initial version *
A* *
A* *
A*---------------------------------------------------------------*
A*
A R JAMDTBR TEXT('SFL Table Maint Model')
A*
A TBCODE 2S 0 TEXT('Table Code')
A TBDESC 50A TEXT('Table Description')
A TBEFFDTE 8S 0 TEXT('Table Effective Date')
A TBEXPDTE 8S 0 TEXT('Table Expriation Date')
A TBSTATUS 1A TEXT('Table Status')
A TBCLASS 2A TEXT('Table Class')
A*
A K TBCODE
A*
RPGLE - Write Table data into DataArea
Posted By: K.K.Paul Contact
FDEPT IF E DISK
D FileSpace E DS 100 EXTNAME(DEPT:DPTREC:*ALL)
D ResultSpace S 10A DTAARA('RSLTSPC')
D VDNAME S 10A
D DFALSE S 10A
C READ DPTREC LR
C DOW *INLR=*OFF
C SELECT
C WHEN DEPTNO='10'
C EVAL VDNAME=DNAME
C OTHER
C EVAL DFALSE='XXX'
C ENDSL
C READ DPTREC LR
C ENDDO
C *LOCK IN ResultSpace
C EVAL ResultSpace=VDNAME
C OUT ResultSpace
C SETON LR
RPGLE - Attention Key Group Jobs Made Easy - JA0507
Posted By: JWA Contact
Object List
-----------------------------------------------------------------
JA0507C CLLE JA0507 - Group Jobs process
JA0507CL CLLE JA0507 - Group Jobs initial pgm (example)
JA0507C1 CLLE JA0507 - Group Jobs attention
JA0507C2 CLLE JA0507 - Group Jobs cmd check
JA0507FM DSPF JA0507 - Group Jobs select dspf
JA0507FM1 DSPF JA0507 - Group Jobs maintain dspf
JA0507HP PNLGRP JA0507 - Group Jobs select help panel
JA0507HP1 PNLGRP JA0507 - Group Jobs maintain help panel
JA0507L LF JA0507 - Group Jobs lf
JA0507P PF JA0507 - Group Jobs pf
JA0507R RPGLE JA0507 - Group Jobs select
JA0507R1 RPGLE JA0507 - Group Jobs maintain
JA0507R2 RPGLE JA0507 - Retrieve Initial Job
JAMSGF *MSGF Message File
Note: Create a message file "JAMSGF" with message
ID "JWA0005" - "Selected Group Job is not defined."
/*----------------------------------------------------------------*/
/* */
/* cl program: JA0507C - Process */
/* */
/* abstract: Process group job commands */
/* */
/* */
/* modifications */
/* ------------- */
/* date developer project description */
/* -------- ---------- ---------- ------------------------------- */
/* 01/05/06 jwa initial version */
/* 01/05/07 jwa enhanced logic for initial job */
/* fixed several small bugs */
/* */
/*----------------------------------------------------------------*/
Pgm
DCL VAR(&GRPCMD) TYPE(*CHAR) LEN(72)
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(EXITPGM))
SetAtnPgm Pgm(JA0507C1) Set(*ON)
RTVDTAARA DTAARA(*GDA (1 72)) RTNVAR(&GRPCMD)
CALL PGM(QCMDEXC) PARM(&GRPCMD 72)
MONMSG MSGID(CPF0000) EXEC(ENDGRPJOB GRPJOB(*) +
RSMGRPJOB(*PRV) LOG(*NOLIST))
ExitPgm: EndPgm
/*----------------------------------------------------------------*/
/* */
/* cl program: JA0507CL - initial program */
/* */
/* abstract: Sample initial program */
/* */
/* */
/* modifications */
/* ------------- */
/* date developer project description */
/* -------- ---------- ---------- ------------------------------- */
/* 01/05/06 jwa initial version */
/* 01/05/07 jwa enhanced logic for initial job */
/* fixed several small bugs */
/* */
/* */
/*----------------------------------------------------------------*/
Pgm
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&OPTN) TYPE(*CHAR) LEN(2) VALUE('01')
DCL VAR(&GRPNAME) TYPE(*CHAR) LEN(10) VALUE('MAIN')
DCL VAR(&GRPDESC) TYPE(*CHAR) LEN(30) VALUE('Main')
DCL VAR(&GRPCMD) TYPE(*CHAR) LEN(72) VALUE('go +
menu(program)')
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(EXIT))
/* get definition for first group job, if not defined */
/* then create it using default values */
RTVJOBA USER(&USER)
CALL PGM(JA0507R2) PARM(&USER &OPTN &GRPNAME +
&GRPDESC &GRPCMD)
CHGGRPA GRPJOB(&GrpName)
Loop: SetAtnPgm Pgm(JA0507C1) Set(*On)
CALL PGM(QCMDEXC) PARM(&GRPCMD 72)
/*********** GOTO ***** CMDLBL(LOOP) ******/
Exit: CHGGRPA GRPJOB(*NONE)
EndPgm
/*----------------------------------------------------------------*/
/* */
/* JA0507C1 - Interactive Group Job - attention */
/* */
/* Abstract: This program processes the attn key */
/* */
/*----------------------------------------------------------------*/
/* modifications */
/* ------------- */
/* date developer project description */
/* -------- ---------- ---------- ------------------------------- */
/* 01/05/06 jwa initial version */
/* 01/05/07 jwa enhanced logic for initial job */
/* fixed several small bugs */
/* */
/*----------------------------------------------------------------*/
PGM
DCL VAR(&GrpName) TYPE(*CHAR) LEN(10)
DCL VAR(&GrpCmd) TYPE(*CHAR) LEN(72)
DCL VAR(&GrpJob) TYPE(*CHAR) LEN(10)
DCL VAR(&GrpList) TYPE(*CHAR) LEN(1056)
DCL VAR(&GrpCnt) TYPE(*DEC) LEN(3 0)
MONMSG MSGID(CPF0000)
/* Get Group Job Attributes */
RTVGRPA GRPJOB(&GrpJob) GRPJOBL(&GrpList) +
GRPJOBCNT(&GrpCnt)
/*********** SETATNPGM PGM("your attn pgm"/"Your Lib") *****/
CALL PGM(JA0507R) PARM(&GRPJOB &GRPNAME &GRPCMD +
&GRPCNT &GRPLIST)
IF ((&GRPNAME *NE ' ') *AND +
(&GRPNAME *NE &GRPJOB)) +
THEN(DO)
ChgDtaara Dtaara(*GDA) VALUE(&GrpCmd)
TFRGRPJOB GRPJOB(&GrpName) INLGRPPGM(JA0507C)
ENDDO
ENDPGM
/*----------------------------------------------------------------*/
/* */
/* JA0507C2 - Interactive Group Job - command check */
/* */
/* Abstract: This uses API qcmdchk to verify command strings */
/* */
/*----------------------------------------------------------------*/
/* modifications */
/* ------------- */
/* date developer project description */
/* -------- ---------- ---------- ------------------------------- */
/* 01/05/06 jwa initial version */
/* 01/05/07 jwa enhanced logic for initial job */
/* fixed several small bugs */
/* */
/*----------------------------------------------------------------*/
PGM PARM(&CMD &LEN &RESULT)
DCL VAR(&CMD) TYPE(*CHAR) LEN(72)
DCL VAR(&LEN) TYPE(*DEC) LEN(15 5)
DCL VAR(&RESULT) TYPE(*CHAR) LEN(4)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(300)
MONMSG MSGID(CPF0000)
CHGVAR VAR(&RESULT) VALUE(' ')
/* Check Command String */
CALL PGM(QCMDCHK) PARM(&CMD &LEN)
MONMSG MSGID(CPF0000) EXEC(DO)
CHGVAR VAR(&RESULT) VALUE('*ERR')
RCVMSG PGMQ(*SAME (*)) MSGQ(*PGMQ) MSGTYPE(*DIAG) +
MSGDTA(&MSGDTA) MSGID(&MSGID)
SNDPGMMSG MSGID(&MSGID) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
TOPGMQ(*PRV)
ENDDO
ENDPGM
A*----------------------------------------------------------------*
A* *
A* FILE NAME: JA0507FM - PROCESS GROUP JOB SELECTION *
A* *
A* Abstract: *
A* *
A* *
A*----------------------------------------------------------------*
A* Modifications *
A* ------------- *
A* date developer project description *
A* -------- ---------- ---------- ------------------------------- *
A* 01/05/06 JWA initial version *
A* 01/05/07 JWA ENHANCED LOGIC FOR INITIAL JOB *
A* FIXED SEVERAL SMALL BUGS *
A* *
A*----------------------------------------------------------------*
A*%%EC
A DSPSIZ(24 80 *DS3)
A HLPTITLE('FILE LEVEL TITLE')
A HLPPNLGRP(EXTENDED JA0507HP)
A ALTHELP(CA01)
A HELP
A CF03
A CF12
A CF05
A CF06
A*---------------------------------------------------------------
A R JA0507R1
A*%%TS SD 20070215 154538 JALBERT REL-V5R2M0 5722-WDS
A RTNCSRLOC(&RCD &FLD &POS)
A CSRLOC(LINNBR POSNBR)
A OVERLAY
A H HLPPNLGRP(EXTENDEDR1 JA0507HP)
A HLPARA(*NONE)
A FLD 10A H
A RCD 10A H
A POS 4S 0H
A LINNBR 3S 0H
A POSNBR 3S 0H
A 1 2SYSNAME
A 1 11USER
A SCTITL 30A O 1 26
A SCDATE 8Y 0O 1 71EDTWRD(' / / ')
A 2 2'JA0507R1'
A SCFUNC 30A O 2 26DSPATR(HI)
A SCTIME 6Y 0O 2 73EDTWRD(' : : ')
A 5 4'Select a Group Job, press enter.'
A COLOR(BLU)
A*
A SCOPTN01 2Y 0O 7 6EDTCDE(Z)
A SCOPTN02 2Y 0O 8 6EDTCDE(Z)
A SCOPTN03 2Y 0O 9 6EDTCDE(Z)
A SCOPTN04 2Y 0O 10 6EDTCDE(Z)
A SCOPTN05 2Y 0O 12 6EDTCDE(Z)
A SCOPTN06 2Y 0O 13 6EDTCDE(Z)
A SCOPTN07 2Y 0O 14 6EDTCDE(Z)
A SCOPTN08 2Y 0O 15 6EDTCDE(Z)
A SCOPTN09 2Y 0O 7 44EDTCDE(Z)
A SCOPTN10 2Y 0O 8 44EDTCDE(Z)
A SCOPTN11 2Y 0O 9 44EDTCDE(Z)
A SCOPTN12 2Y 0O 10 44EDTCDE(Z)
A SCOPTN13 2Y 0O 12 44EDTCDE(Z)
A SCOPTN14 2Y 0O 13 44EDTCDE(Z)
A SCOPTN15 2Y 0O 14 44EDTCDE(Z)
A SCOPTN16 2Y 0O 15 44EDTCDE(Z)
A*
A SCDESC01 30A O 7 10
A 21 DSPATR(HI)
A SCDESC02 30A O 8 10
A 22 DSPATR(HI)
A SCDESC03 30A O 9 10
A 23 DSPATR(HI)
A SCDESC04 30A O 10 10
A 24 DSPATR(HI)
A SCDESC05 30A O 12 10
A 25 DSPATR(HI)
A SCDESC06 30A O 13 10
A 26 DSPATR(HI)
A SCDESC07 30A O 14 10
A 27 DSPATR(HI)
A SCDESC08 30A O 15 10
A 28 DSPATR(HI)
A SCDESC09 30A O 7 47
A 29 DSPATR(HI)
A SCDESC10 30A O 8 47
A 30 DSPATR(HI)
A SCDESC11 30A O 9 47
A 31 DSPATR(HI)
A SCDESC12 30A O 10 47
A 32 DSPATR(HI)
A SCDESC13 30A O 12 47
A 33 DSPATR(HI)
A SCDESC14 30A O 13 47
A 34 DSPATR(HI)
A SCDESC15 30A O 14 47
A 35 DSPATR(HI)
A SCDESC16 30A O 15 47
A 36 DSPATR(HI)
A*
A SCACTV01 1A O 7 4
A SCACTV02 1A O 8 4
A SCACTV03 1A O 9 4
A SCACTV04 1A O 10 4
A SCACTV05 1A O 12 4
A SCACTV06 1A O 13 4
A SCACTV07 1A O 14 4
A SCACTV08 1A O 15 4
A SCACTV09 1A O 7 42
A SCACTV10 1A O 8 42
A SCACTV11 1A O 9 42
A SCACTV12 1A O 10 42
A SCACTV13 1A O 12 42
A SCACTV14 1A O 13 42
A SCACTV15 1A O 14 42
A SCACTV16 1A O 15 42
A*
A 17 4'Select:'
A COLOR(BLU)
A SCSLCT 2Y 0B 17 12EDTCDE(4)
A CHECK(ER)
A 17 67'(*=active)'
A COLOR(BLU)
A 19 4'Command:'
A COLOR(BLU)
A SCCMD1 64A B 19 13CHECK(LC)
A 21 4'F3/F12=Exit'
A COLOR(BLU)
A 21 17'F5=Refresh'
A COLOR(BLU)
A 21 29'F6=Update Options'
A COLOR(BLU)
*---------------------------------------------------------------
* Message Subfile
*---------------------------------------------------------------
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A QPPGM SFLPGMQ
*---------------------------------------------------------------
* Message Subfile Control
*---------------------------------------------------------------
A R MSGCTL SFLCTL(MSGSFL)
A SFLSIZ(2)
A SFLPAG(1)
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N99 SFLEND
A QPPGM SFLPGMQ
*
A*----------------------------------------------------------------*
A* Name: JA0507FM1 - MAINTAIN GROUP JOB OPTIONS *
A* *
A* Abstract: *
A* *
A* Modifications *
A* ------------- *
A* date developer project description *
A* -------- ---------- ---------- ------------------------------- *
A* 01/05/06 JWA INITIAL VERSION *
A* 01/05/07 JWA ENHANCED LOGIC FOR INITIAL JOB *
A* FIXED SEVERAL SMALL BUGS *
A* *
A*----------------------------------------------------------------*
A*%%EC
A DSPSIZ(24 80 *DS3)
A HLPTITLE('FILE LEVEL TITLE')
A HLPPNLGRP(EXTENDED JA0507HP1)
A ALTHELP(CA01)
A HELP
A CF03
A CF05
A CF08
A CF12
A*----------------------------------------------------------*
A R JA0507S11 SFL
A*%%TS SD 20070215 154356 JALBERT REL-V5R2M0 5722-WDS
A 94 SFLNXTCHG
A S1OPTN 2S 0O 7 3
A S1GRPNAME 10A B 7 8
A S1DESC 30A B 7 20CHECK(LC)
A S1GRPCMD 72A B 8 8CHECK(LC)
A 9 4' '
A*----------------------------------------------------------*
A R JA0507C11 SFLCTL(JA0507S11)
A N93 PAGEDOWN
A CSRLOC(LINNBR POSNBR)
A OVERLAY
A SFLCSRRRN(&SCCSRRRN)
A 91 SFLDSP
A 90 SFLDSPCTL
A 92 SFLCLR
A 93 SFLEND
A SFLSIZ(0016)
A SFLPAG(0004)
A H HLPPNLGRP(EXTENDEDC1 JA0507HP1)
A HLPARA(*NONE)
A*
A SCSFLRCD 4S 0H SFLRCDNBR(CURSOR)
A LINNBR 3S 0H
A POSNBR 3S 0H
A SCCSRRRN 5S 0H
A*
A 1 2SYSNAME
A 1 11USER
A SCTITL 30A O 1 32
A 1 73DATE
A EDTCDE(Y)
A 2 2'JA0507C11'
A SCFUNC 30A O 2 32COLOR(WHT)
A 2 73TIME
A 4 2'Enter/change data, press enter to -
A verify. Press F8 to update.'
A COLOR(BLU)
A 6 2'Optn'
A DSPATR(UL)
A COLOR(WHT)
A 6 8'Job Name '
A DSPATR(HI)
A DSPATR(UL)
A 6 20'Description'
A DSPATR(UL)
A COLOR(WHT)
A*----------------------------------------------------------*
A R JA0507K11
A H HLPPNLGRP(CF03 JA0507HP)
A HLPARA(*CNST 003)
A 20 2'F3/F12=Exit'
A HLPID(003)
A COLOR(BLU)
A 20 15'F5=Refresh'
A HLPID(005)
A COLOR(BLU)
A 20 27'F8=Update'
A HLPID(008)
A COLOR(BLU)
A 20 38'PageUp/PageDn'
A HLPID(025)
A COLOR(BLU)
A*
A*----------------------------------------------------------*
A* MESSAGE SUBFILE RECORD
A*----------------------------------------------------------*
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A QPPGM SFLPGMQ
A*----------------------------------------------------------*
A* MESSAGE SUBFILE CONTROL RECORD
A*----------------------------------------------------------*
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N95 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A QPPGM SFLPGMQ
*
.*----------------------------------------------------------------*
.* *
.* Panel Name: JA0507HP - Help Panel Group Job Selection *
.* *
.* Abstract: *
.* *
.*----------------------------------------------------------------*
.* Modifications *
.* ------------- *
.* date developer project description *
.* -------- ---------- ---------- ------------------------------- *
.* 01/05/06 jwa initial version *
.* 01/05/07 jwa enhanced logic for initial job *
.* fixed several small bugs *
.* *
.*----------------------------------------------------------------*
:PNLGRP.
:HELP name=EXTENDED.
:P.
Help text that pertains to the entire file.
:EHELP.
:HELP name=EXTENDEDR1.Record Format JA0507R1
:xh3.Record Format JA0507R1
:P.
Information for record format JA0507R1
:EHELP.
:EPNLGRP.
.*----------------------------------------------------------------*
.* Name: JA0507HP1 - Enter/Update Group Jobs Help Panel *
.* *
.* Abstract: *
.* *
.* Modifications *
.* ------------- *
.* date developer project description *
.* -------- ---------- ---------- ------------------------------- *
.* 01/05/06 jwa initial version *
.* 01/05/07 jwa enhanced logic for initial job *
.* fixed several small bugs *
.* *
.*----------------------------------------------------------------*
:PNLGRP.
:HELP name=EXTENDED.
:P.
Help text that pertains to the entire file.
:EHELP.
:HELP name=EXTENDEDC1.Record Format JA0507C11
:xh3.Record Format JA0507C11
:P.
Information for record format JA0507C11.
:EHELP.
:EPNLGRP.
A*----------------------------------------------------------------*
A* *
A* FILE NAME: JA0507L - INTERACTIVE GROUP JOB - LF *
A* *
A* Abstract: This file contains informations necessary for *
A* one instance of a group job. The options can *
A* range from 1 to 24 for each user. *
A* *
A*----------------------------------------------------------------*
A* Modifications *
A* ------------- *
A* date developer project description *
A* -------- ---------- ---------- ------------------------------- *
A* 01/05/06 JWA INITIAL VERSION *
A* 01/05/07 JWA ENHANCED LOGIC FOR INITIAL JOB *
A* FIXED SEVERAL SMALL BUGS *
A* *
A*----------------------------------------------------------------*
A UNIQUE
A R JA0507L1 PFILE(JA0507P)
A J1USER
A J1OPTN
A J1GRPNAME
A J1DESC
A J1GRPCMD
*
A K J1USER
A K J1GRPNAME
*
A*----------------------------------------------------------------*
A* *
A* FILE NAME: JA0507P - INTERACTIVE GROUP JOB - PF *
A* *
A* Abstract: This file contains informations necessary for *
A* one instance of a group job. The options can *
A* range from 1 to 24 for each user. *
A* *
A*----------------------------------------------------------------*
A* Modifications *
A* ------------- *
A* date developer project description *
A* -------- ---------- ---------- ------------------------------- *
A* 01/05/06 JWA INITIAL VERSION *
A* 01/05/07 JWA ENHANCED LOGIC FOR INITIAL JOB *
A* FIXED SEVERAL SMALL BUGS *
A* *
A*----------------------------------------------------------------*
A UNIQUE
A R JA0507P1
A J1USER 10A TEXT('Attn Key User')
A COLHDG('User')
A J1OPTN 2S 0 TEXT('Attn Key Option')
A COLHDG('Option')
A J1GRPNAME 10A TEXT('Group Job Name')
A COLHDG('Grp Job')
A J1DESC 30A TEXT('Option Description')
A COLHDG('Description')
A J1GRPCMD 72A TEXT('Group Job Command String')
A COLHDG('Command String')
*
A K J1USER
A K J1OPTN
*
h
*----------------------------------------------------------------*
* *
* Name: JA0507R - Interactive Group Job - select *
* *
* Abstract: Display and Maintain group jobs for selection *
* *
*----------------------------------------------------------------*
* Modifications *
* ------------- *
* date developer project description *
* -------- ---------- ---------- ------------------------------- *
* 01/05/06 jwa initial version *
* 01/05/07 jwa enhanced logic for initial job *
* fixed several small bugs *
* *
*----------------------------------------------------------------*
fJA0507FM CF E Workstn
f infds(aufds)
fJA0507P IF E K Disk
*
* Prototypes
* -----------
d pQCMDEXC PR ExtPgm('QCMDEXC')
d cmd 300A Options(*VarSize) const
d cmdlen 15P 5 const
*
d ChkCmd PR extpgm('JA0507C2')
d cmd 300A Options(*VarSize) const
d cmdlen 15P 5 const
d result 4A
*
* -----------------
* data sturctures
* -----------------
*
* program status data structure
d SPDS SDS
d qpPgm 1 10
d qpUser 254 263
*
* file information data structure - display file
d AUFDS DS
d QFAid 369 369
*
* time stamp
d DS
d ts 1 14 0
d tstime 1 6 0
d tsdate 7 14 0
*
* Group Job Options
d Optn s 2S 0 Dim(16)
d ptrOptn s * inz(%addr(Optn))
d OptnDS DS based(ptrOptn)
d SCOptn01
d SCOptn02
d SCOptn03
d SCOptn04
d SCOptn05
d SCOptn06
d SCOptn07
d SCOptn08
d SCOptn09
d SCOptn10
d SCOptn11
d SCOptn12
d SCOptn13
d SCOptn14
d SCOptn15
d SCOptn16
*
* Group Job Descriptions
d Desc s 30A Dim(16)
d ptrDesc s * inz(%addr(Desc))
d DescDS DS based(ptrDesc)
d SCDESC01
d SCDESC02
d SCDESC03
d SCDESC04
d SCDESC05
d SCDESC06
d SCDESC07
d SCDESC08
d SCDESC09
d SCDESC10
d SCDESC11
d SCDESC12
d SCDESC13
d SCDESC14
d SCDESC15
d SCDESC16
*
* Group Job Active/Inactive
d Actv s 1A Dim(16)
d ptrActv s * inz(%addr(Actv))
d ActvDS DS based(ptrActv)
d SCActv01
d SCActv02
d SCActv03
d SCActv04
d SCActv05
d SCActv06
d SCActv07
d SCActv08
d SCActv09
d SCActv10
d SCActv11
d SCActv12
d SCActv13
d SCActv14
d SCActv15
d SCActv16
*
* Group Job Names & Command Strings
d GrpName s 10A Dim(16)
d GrpCmd s 72A Dim(16)
*
*-----------------------
* Group Jobs Now Active
*-----------------------
d GrpList s 10A Dim(16)
d GrpL s 66A Dim(16)
d ptrGrpL s * inz(%addr(GrpL))
d P2GRPList s 1056A based(ptrGrpL)
*
*------------------
* named indicators
*------------------
d ptrindicators s * inz(%addr(*in))
d indicators DS based(ptrindicators)
d someInd 66 66N
*
*-----------------
* named constants
*-----------------
* function key aid return values
d cf03 c const(x'33')
d cf05 c const(x'35')
d cf06 c const(x'36')
d cf12 c const(x'3C')
d enter c const(x'F1')
d Title c ' Group Jobs Application '
d Function c ' JA0507R - Select Group Job '
*
*-----------------
* Message Subfile
*-----------------
d msgId s 7
d msgLoc s 20 inz('JAMSGF *LIBL ')
d msgData s 80
d msgDataLen s 10i 0 Inz(%Size(MsgData))
d msgType s 10 inz('*DIAG')
d msgQueue s 276A inz('*')
d msgCallStack s 10i 0 inz(0)
d msgKey s 4 inz(' ')
d msgErr s 10i 0 inz(0)
d msgrmv s 10A inz('*ALL')
*--------------------
* Stand Alone Fields
*--------------------
d Active s n
d Optn_Valid s n
d CmdRslt s 4A
d i s 3S 0
d x s 3S 0
*
d P1GRPJOB s 10A
d P1GRPNAME s like(J1GRPNAME )
d P1GRPCMD s like(J1GRPCMD )
d P1GRPCnt s 3P 0
d P1GRPList s 1056A
*
* initial processing performed by *inzsr subroutine
*
*-------------
* Entry Point
*-------------
c *entry Plist
c Parm P1GRPJOB
c Parm P1GRPNAME
c Parm P1GRPCMD
c Parm P1GRPCnt
c Parm P1GRPList
*
* Load Grp Job Options
c ExSr BldActPnl
*
* Set an indicator to highlight the current group job
c Select
c When P1Grpjob = '*NONE' or
c P1Grpjob = *blanks
c Eval *in21 = *on
c eval Actv(1) = '*'
*
c Other
C Z-ADD 1 X
C P1Grpjob LOOKUP GrpName(x) 60
c If %equal
c eval *in(x + 20) = *on
c EndIf
c EndSl
*
*--------------
* Main Section
*--------------
c DOW Active
*
c time TS
c Move tstime sctime
c Move tsdate scdate
*
* Display Active Panel
c ExSr DspActPnl
* Process Active Panel
c ExSr PrcActPnl
c EndDo
* Exit Program
c eval *inlr = *on
*-----------------------------------------------------
* Display Active Panel
*-----------------------------------------------------
c DspActPnl BegSr
* --------- -----
* write any error messages
c write msgctl
c clear SCSlct
* display active panel
c ExFmt JA0507R1
* Clear message file
c eval msgKey = *blanks
c exsr ClearMsg
c EndSr
*-----------------------------------------------------
* Process Function Keys
*-----------------------------------------------------
c PrcActPnl BegSr
* --------- -----
c SELECT
* F3/F12 = Exit
*--------------
c WHEN QFAid = CF03 or
c QFAid = CF12
c eval Active = *off
* F5=Refresh
*-----------
c WHEN QFAid = CF05
c ExSr BldActPnl
* F6=Update Options
*------------------
c WHEN QFAid = CF06
c call 'JA0507R1'
c ExSr BldActPnl
* Enter Key
*----------
c WHEN QFAid = Enter
c ExSr ValdR1
*
c If Optn_Valid
c clear SCCmd1
c eval P1GRPNAME = GrpName(SCSlct)
c eval P1GRPCMD = GrpCmd(SCSlct)
c eval Active = *off
c EndIf
*
/free
If SCCmd1 <> *blanks;
CallP(e) ChkCmd(%Trim(SCCmd1): %Len(SCCmd1):
CmdRslt );
If CmdRslt <> '*ERR';
CallP(e) pQCMDEXC( %Trim(SCCmd1): %Len(SCCmd1) );
Clear SCCmd1;
EndIf;
EndIf;
/end-free
*
c ENDSL
c EndSr
*
*-----------------------------------------------------
* Build Active Panel
*-----------------------------------------------------
c BldActPnl BegSr
* --------- -----
*
c clear Optn
c clear Desc
c clear Actv
c clear GrpName
c clear GrpCmd
*
* Load Grp Job Options
c qpuser SetLL JA0507P1
c qpuser ReadE JA0507P1
*
c DOW not %EOF(JA0507P)
c If J1Optn > *zero and
c J1Optn < 17
c eval Optn(J1Optn) = J1Optn
c eval Desc(J1Optn) = J1Desc
c eval GrpName(J1Optn) = J1GrpName
c eval GrpCmd(J1Optn) = J1GrpCmd
*
* Is Group Job now Active?
c J1GrpName Lookup GrpList 60
c If %equal
c eval Actv(J1Optn) = '*'
c EndIf
*
c EndIf
*
c qpuser ReadE JA0507P1
c EndDo
*
* If user has no records in group job file then
* populate group job 1 with default values
c If GrpName(1) = *blanks
c eval Optn(1) = 1
c eval Desc(1) = 'Main '
c eval GrpName(1) = 'MAIN '
c eval GrpCmd(1) = 'GO MENU(MAIN)'
c EndIf
*
c EndSr
*
*-----------------------------------------------------
* Validate R1
*-----------------------------------------------------
c ValdR1 BegSr
* ------ -----
c eval Optn_Valid = *off
c If SCSlct > 0 and
c SCSlct < 17
c If Optn(SCSlct) <> 0
c eval Optn_Valid = *on
c EndIf
c EndIf
*
* Group job selected not defined
c If not Optn_Valid and
c SCSlct > *zero
c movel(p) 'JWA0005' MsgId
c movel SCSlct msgData
c eval msgDataLen = %len(msgData)
c ExSr SendMsg
c Endif
*
c EndSr
*-----------------------------------------------------
* SendMsg - Send a message to the message subfile
*-----------------------------------------------------
c SendMsg Begsr
* ------- -----
c call 'QMHSNDPM'
c parm msgId
c parm msgLoc
c parm msgData
c parm msgDataLen
c parm msgType
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgErr
*
c endsr
*-----------------------------------------------------
* ClearMsg - Clear the messages from the screen
*-----------------------------------------------------
c ClearMsg Begsr
* -------- -----
c call 'QMHRMVPM'
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgRmv
c parm msgErr
c endsr
*-----------------------------------------------------
* perform initial processing
*-----------------------------------------------------
c *InzSr BegSr
* ------ -----
*
* Get Active Group Jobs
c Eval P2GRPList = P1GRPList
c Clear GrpList
c Do P1GRPCnt i
c movel GrpL(i) GrpList(i)
c EndDo
*
c eval SCTitl = Title
c eval SCFunc = Function
c eval Active = *on
c EndSr
*
*
h
*----------------------------------------------------------------*
* *
* Name: JA0507R1 - Maintain Group Job Options (1-16) *
* *
* Abstract: *
* *
* General Logic: *
* initial processing (*inzsr) *
* *
* *
*----------------------------------------------------------------*
* Modifications *
* ------------- *
* date developer project description *
* -------- ---------- ---------- ------------------------------- *
* 01/05/06 jwa initial version *
* 01/05/07 jwa enhanced logic for initial job *
* fixed several small bugs *
* *
*----------------------------------------------------------------*
fJA0507FM1 CF E Workstn
f infds(AUINFDS)
f sfile(JA0507S11:sflrrn)
* Group Jobs Options File
fJA0507P UF A E K Disk
* ---------------
* tables/arrays
* ---------------
*
* -----------------
* data sturctures
* -----------------
*
* program status data structure
d PgmStat SDS
d qpPgm 1 10
d qpUser 254 263
*
*
* file information data structure - display file
d AUINFDS ds
*-------
d QFRcdFmt 261 270
d QFAid 369 369
d QFCsrl 370 371b 0
d QFSflRRN 376 377I 0
*------------------
* named indicators
*------------------
d ptrindicators s * inz(%addr(*in))
d indicators DS based(ptrindicators)
*
d SflDsp 90 90n
d SflDspCtl 91 91n
d SflClr 92 92n
d SflEnd 93 93n
d SflNxtChg 94 94n
d MsgSflEnd 95 95n
*
*-----------------
* named constants
*-----------------
* function key aid return values
d CF03 c const(x'33')
d CF05 c CONST(X'35')
d CF08 c CONST(X'38')
d CF12 c const(x'3C')
d Enter c const(x'F1')
d SflPage c 4
d SflSize c 16
d Title c ' Group Jobs Application '
d Function c 'JA0507R1 - Maintain Group Jobs'
d up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
d lo C 'abcdefghijklmnopqrstuvwxyz'
*
*-----------------
* Message Subfile
*-----------------
d msgId s 7
d msgLoc s 20 inz('JAMSGF *LIBL ')
d msgData s 80
d msgDataLen s 10i 0 Inz(%Size(MsgData))
d msgType s 10 inz('*DIAG')
d msgQueue s 276A inz('*')
d msgCallStack s 10i 0 inz(0)
d msgKey s 4 inz(' ')
d msgErr s 10i 0 inz(0)
*
d msgrmv s 10A inz('*ALL')
*
*--------------------
* Stand Alone Fields
*--------------------
d Optn s like(j1optn)
d RcdCnt s 5p 0
d SFLrrn s 5p 0
d LstSFLrrn s 5p 0
d err_Sflrrn s 5p 0
*
* Logical Variables
d Active s n
d ErrFnd s n
d ErrorsFnd s n
d SetPageRRN s n
*
*-----------
* Key Lists
*-----------
c JAKey1 Klist
c Kfld QpUser
c Kfld Optn
*
* initial processing performed by *inzsr subroutine
*--------------
* Main Section
*--------------
c ExSr ClearSFL
c ExSr LoadSFL
*
c DOW Active
*
* Clear/Load/Display the SFL
c ExSr DspSFL
*
c ExSr ProcCMD
*
c EndDo
* Exit Program
c eval *inlr = *on
*
*-----------------------------------------------------
* Display Active Panel
*-----------------------------------------------------
c DspSFL BegSr
* ~~~~~~ ~~~~~
* display SFL
c eval SflClr = *off
c eval SflDsp = *on
c eval SflDspCtl = *on
c Write JA0507K11
*
* write any error messages
c write msgctl
*
c ExFmt JA0507C11
*
c eval msgKey = *blanks
c ExSr ClearMsg
*
* Keep SFL on same page
c If SCCsrRRN <> *zero
c eval SCSFLRcd = SCCsrRRN
c EndIf
c EndSr
*-----------------------------------------------------
* Process Function Keys
*-----------------------------------------------------
c ProcCmd BegSr
* ~~~~~~~ ~~~~~
c Select
*
* CF03/CF12=Exit
c When QFAid = CF03 or
c QFAid = CF12
c eval Active = *off
*
* CF05=Refresh
c When QFAid = CF05
c ExSr ClearSfl
c ExSr LoadSFL
*
* CF08=Update
c When QFAid = CF08
c ExSr ProcSfl
c If not ErrorsFnd
c eval Active = *off
c EndIf
*
c EndSL
*
c EndSr
*-----------------------------------------------------
* Process Subfile
*-----------------------------------------------------
c ProcSfl BegSr
* ~~~~~~~ ~~~~~
c eval ErrorsFnd = *off
*
c READC(E) JA0507S11
c DOW not %EOF(JA0507FM1) and
c Active
*
c Eval ErrFnd = *off
*
c eval Optn = S1Optn
c JAKey1 Chain JA0507P1
c Eval J1User = QpUser
c Eval J1Optn = S1Optn
c Eval J1Desc = S1Desc
c Eval J1GrpName = %XLATE(lo:up: S1GrpName)
c Eval J1GrpCmd = S1GrpCmd
*
c If %found
c If S1GrpName <> *blanks
c If S1Desc <> *blanks and
c S1GrpCmd <> *blanks
c Update(e) JA0507P1
*
c If %error
c eval ErrFnd = *on
c EndIf %errpr
c EndIf S1Desc <> *blanks
c Else S1GrpName = *blanks
*
* do not allow job 1 to be removed
c If J1Optn <> 1
c Delete(e) JA0507P1
c EndIf J1Optn <> 1
*
c EndIf S1GrpName <> *blanks
*
c Else not %found
*
c If S1GrpName <> *blanks and
c S1Desc <> *blanks and
c S1GrpCmd <> *blanks
c Write(e) JA0507P1
*
c If %error
c eval ErrFnd = *on
c EndIf
*
c EndIf S1GrpName <> *blanks
c EndIf %found
*
c If ErrFnd
c Eval ErrorsFnd = *on
c Eval SflNxtChg = *on
c Update JA0507S11
c Eval SflNxtChg = *off
c EndIf ErrFnd
*
c eval SCSFLRcd = SFLrrn
c READC(E) JA0507S11
*
c EndDo not %EOF(JA0507FM1)
*
c EndSr
*-----------------------------------------------------
* Load SFL - perform initial load to an empty sfl
*-----------------------------------------------------
c LoadSFL BegSr
* ~~~~~~~ ~~~~~
c eval SFLrrn = 0
c QpUser SetLL JA0507P1
*
c eval SetPageRRN = *on
c eval RcdCnt = 0
*
c Do 16 Optn
c JAKey1 Chain JA0507P1
*
c If %found
c eval S1Desc = J1Desc
c eval S1GrpName = J1GrpName
c eval S1GrpCmd = J1GrpCmd
c Else
c clear S1Desc
c clear S1GrpName
c clear S1GrpCmd
*
* If user has no records in group job file then
* populate group job 1 with default values
c If Optn = 1
c eval S1Desc = 'Main '
c eval S1GrpName = 'MAIN '
c eval S1GrpCmd = 'go menu(main)'
*
* Write default record 1 for this user
c JAKey1 Chain JA0507P1
c Eval J1User = QpUser
c Eval J1Optn = 1
c Eval J1Desc = S1Desc
c Eval J1GrpName = %XLATE(lo:up: S1GrpName)
c Eval J1GrpCmd = S1GrpCmd
*
c If not %found
c Write(e) JA0507P1
c EndIf
c EndIf
*
c EndIf
*
c eval s1Optn = Optn
c eval SFLrrn = SFLrrn + 1
*
c If SetPageRRN
c eval SetPageRRN = *off
c eval SCSFLRcd = SFLrrn
c EndIf
*
c Write JA0507S11
c EndDo
*
c eval SflEnd = *on
*
c EndSr
*-----------------------------------------------------
* Clear SFL
*-----------------------------------------------------
c ClearSFL BegSr
* ~~~~~~~~ ~~~~~
c Eval SflClr = *on
c Eval SflDsp = *off
c Eval SflDspCtl = *off
c Write JA0507C11
c Eval SflClr = *off
c EndSr
*-----------------------------------------------------
* SendMsg - Send a message to the message subfile
*-----------------------------------------------------
c SendMsg Begsr
* ------- -----
c call 'QMHSNDPM'
c parm msgId
c parm msgLoc
c parm msgData
c parm msgDataLen
c parm msgType
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgErr
*
c endsr
*-----------------------------------------------------
* ClearMsg - Clear the messages from the screen
*-----------------------------------------------------
c ClearMsg Begsr
* -------- -----
c call 'QMHRMVPM'
c parm msgQueue
c parm msgCallStack
c parm msgKey
c parm msgRmv
c parm msgErr
*
c endsr
*
*-----------------------------------------------------
* perform initial processing
*-----------------------------------------------------
c *InzSr BegSr
* ~~~~~~ ~~~~~
c eval Active = *on
c eval SCTitl = Title
c eval SCFunc = Function
c EndSr
h
*----------------------------------------------------------------*
* *
* Name: JA0507R2 - Retrieve Group Job Info *
* *
* Abstract: Get Group Job Info and if possible create *
* a group job record in JA0507P *
* *
*----------------------------------------------------------------*
* Modifications *
* ------------- *
* date developer project description *
* -------- ---------- ---------- ------------------------------- *
* 01/05/06 jwa initial version *
* 01/05/07 jwa enhanced logic for initial job *
* fixed several small bugs *
* *
*----------------------------------------------------------------*
fJA0507P UF A E K Disk
*--------------------
* Stand Alone Fields
*--------------------
d P1User s like(J1User )
d P1Optn s 2A
d xxOptn s like(J1Optn )
d P1GrpName s like(J1GrpName )
d P1Desc s like(J1Desc )
d P1GrpCmd s like(J1GrpCmd )
*-----------
* Key Lists
*-----------
c J1Key Klist
c Kfld P1User
c Kfld xxOptn
*
* initial processing performed by *inzsr subroutine
*
*-------------
* Entry Point
*-------------
c *entry Plist
c Parm P1User input
c Parm P1Optn input
c Parm P1GrpName input/output
c Parm P1Desc input/output
c Parm P1GrpCmd input/output
*
*--------------
* Main Section
*--------------
*
c J1Key Chain JA0507P1
c If %found
c move J1GrpName P1GrpName
c move J1Desc P1Desc
c move J1GrpCmd P1GrpCmd
*
* If grp job rec for user not found then add it
c Else
c If P1User <> *blanks and
c P1GrpName <> *blanks and
c P1Desc <> *blanks and
c P1GrpCmd <> *blanks
*
c move P1User J1USER
c z-add xxOptn J1OPTN
c move P1GrpName J1GRPNAME
c move P1Desc J1DESC
c move P1GrpCmd J1GRPCMD
*
c Write JA0507P1
*
c EndIf User <> blank
c EndIf %found
*
* Exit Program
c eval *inlr = *on
*
*-----------------------------------------------------
* perform initial processing
*-----------------------------------------------------
c *InzSr BegSr
* ------ -----
c If P1Optn > '00' and
c P1Optn < '17'
c move P1Optn xxOptn
c Else
c clear P1GrpName
c clear P1Desc
c clear P1GrpCmd
c eval *inlr = *on
c Return
c EndIf
*
c EndSr
*
RPGLE - RPGLE program for Single Page(Size Eq Page)
Posted By: MEGANATHAN P Contact
SFLDSP – 30
SFLDSPCTL - 31
SFLCLR - 32
SFLEND - 34
PAGEDOWN - 25
PAGEUP - 26
EXIT - 03
SFL01 – Subfile record format
CTL01 – Subfile Control record format
FTR01 – Footer record format
** FILE DECLARATIONS
**--------------------------------------------------------------------
FDSPFILE CF E WORKSTN SFILE(SFL01:RRN)
FDBFILE IF E K DISK
**---------------------------------------------------------------
** MAIN LOGIC STARTS
**---------------------------------------------------------------
C EXSR MAIN
**
C SETON LR
**---------------------------------------------------------------
** MAIN SUBROUTINE
**---------------------------------------------------------------
C MAIN BEGSR
**
C EXSR SFLCLR
**
C *LOVAL SETLL DBFILE
**
C EXSR SFLFIL
C
C *IN01 DOWEQ *OFF
C
C EXSR SFLDSP
C
C *IN01 IFEQ *ON
C LEAVE
C ENDIF
C
C *IN25 IFEQ *ON
C EXSR PGDN
C ITER
C ENDIF
C
C *IN26 IFEQ *ON
C MOVEL *OFF *IN34
C EXSR PGUP
C ITER
C ENDIF
**
C ENDDO
C
C ENDSR
**--------------------------------------------------------------------*
** PAGEUP SUBROUTINE
**--------------------------------------------------------------------*
C PGUP BEGSR
**
C EXSR SFLCLR
C Z-ADD 6 RRN
C FIRST SETLL DBFILE
C DO 5
C READP DBFILE 80
C 80 LEAVE
**
C *IN80 IFEQ *OFF
C SUB 1 RRN
C WRITE SFL01
C ENDIF
**
C RRN IFEQ 1
C MOVE KEYFIELD FIRST
C ENDIF
**
C RRN IFEQ 5
C MOVE KEYFIELD LAST
C ENDIF
**
C ENDDO
**
C *IN80 IFEQ *ON
C *LOVAL SETLL DBFILE
C EXSR SFLFIL
C ENDIF
**
C ENDSR
**---------------------------------------------------------------
** PAGE DOWN SUBROUTINE
**---------------------------------------------------------------
C PGDN BEGSR
**
C LAST SETGT DBFILE 81
**
C *IN81 IFEQ *ON
C EXSR SFLCLR
C EXSR SFLFIL
C ENDIF
**
C *IN81 IFEQ *OFF
C MOVE *ON *IN34
C ENDIF
**
C ENDSR
**---------------------------------------------------------------
** SUBFILE LOAD SUBROUTINE
**---------------------------------------------------------------
C SFLFIL BEGSR
**
C Z-ADD 0 RRN
C DO 5
C READ DBFILE 80
C *IN80 IFEQ *OFF
**
C ADD 1 RRN
C RRN IFGT 0
C WRITE SFL01
C ENDIF
C ELSE
C MOVE KEYFIELD LAST
C MOVEL *ON *IN34
C LEAVE
C ENDIF
**
C RRN IFEQ 1
C MOVE KEYFIELD FIRST
C ENDIF
**
C RRN IFEQ 5
C MOVE KEYFIELD LAST
C ENDIF
**
C ENDDO
**
C ENDSR
**---------------------------------------------------------------
** SUBFILE CLEAR SUBROUTINE
**---------------------------------------------------------------
C SFLCLR BEGSR
**
C Z-ADD 0 RRN 4 0
C MOVE *ON *IN32
C WRITE CTL01
C MOVE *OFF *IN32
**
C ENDSR
**--------------------------------------------------------------------*
** SUBFILE DISPLAY SUBROUTINE
**--------------------------------------------------------------------*
C SFLDSP BEGSR
**
C IF RRN > 0
C MOVE *ON *IN30
C MOVE *ON *IN31
C ELSE
C MOVE *OFF *IN30
C MOVE *ON *IN31
C ENDIF
**
C WRITE FTR01
C EXFMT CTL01
**
C MOVE *OFF *IN30
C MOVE *OFF *IN31
**
C ENDSR
RPGLE - RPG/RPGILE Examples
Posted By: sanath Contact
RPGLE - Date Calculator
Posted By: dcutaia Contact
H indent(' ') option(*srcstmt : *nodebugio)
fDateCalcD cf e workstn indds(Indicators)
D DayName PR 9
D D VALUE
D Indicators DS
D Exit 3 3N
D F09Key 9 9N
D F10Key 10 10N
D ErrDate1 98 98N
D ErrDate2 99 99N
D DS
D DateIn D DATFMT(*MDY)
D InDate OVERLAY(DateIn)
D DateIn2 D DATFMT(*MDY)
D InDate2 OVERLAY(DateIn2)
D DateMDY D DATFMT(*MDY)
D DMDY OVERLAY(DateMDY)
D DateDMY D DATFMT(*DMY)
D DDMY OVERLAY(DateDMY)
D DateYMD D DATFMT(*YMD)
D DYMD OVERLAY(DateYMD)
D DateJUL D DATFMT(*JUL)
D DJUL OVERLAY(DateJUL)
D DateISO D DATFMT(*ISO)
D DISO OVERLAY(DateISO)
D DateUSA D DATFMT(*USA)
D DUSA OVERLAY(DateUSA)
D DateEUR D DATFMT(*EUR)
D DEUR OVERLAY(DateEUR)
D DateJIS D DATFMT(*JIS)
D DJIS OVERLAY(DateJIS)
DMode 3
D DurMonths C 1
D DurDays C 2
D DurYears C 3
**************************************************************************************
* Mainline
**************************************************************************************
/free
InDurType = DurDays;
Mode = 'ADD';
DateIn = %DATE();
DOU Exit;
SELECT;
WHEN Mode = 'ADD';
EXFMT DateCalc01;
WHEN Mode = 'SUB';
EXFMT DateCalc02;
ENDSL;
SELECT ;
WHEN Exit;
LEAVE;
WHEN F09Key;
Mode = 'ADD';
WHEN F10Key;
Mode = 'SUB';
WHEN Mode = 'ADD';
EXSR AddDate;
WHEN Mode = 'SUB';
EXSR SubDate;
ENDSL;
ENDDO;
*INLR = *ON;
RETURN;
//************************************************************************************
// Add Date Routine - ADDDUR Mode
//************************************************************************************
BEGSR AddDate;
TEST(E) DateIn;
ErrDate1 = %ERROR;
IF NOT ErrDate1;
SELECT;
WHEN InDurType = DurMonths;
DateISO = DateIn + %MONTHS(InDuration);
WHEN InDurType = DurYears;
DateISO = DateIn + %YEARS(InDuration);
OTHER;
DateISO = DateIn + %DAYS(InDuration);
ENDSL;
DateMDY=DateISO;
DateDMY=DateISO;
DateYMD=DateISO;
DateJUL=DateISO;
DateUSA=DateISO;
DateEUR=DateISO;
DateJIS=DateISO;
ExtrYear = %SUBDT(DateISO:*Y);
ExtrMonth = %SUBDT(DateISO:*M);
ExtrDay = %SUBDT(DateISO:*D);
DayOfWeek = DayName(DateISO);
ENDIF;
ENDSR;
//**********************************************************************************
// Subtract Date Routine - SUBDUR Mode
//**********************************************************************************
BEGSR SubDate;
TEST(E) DateIn;
ErrDate1 = %ERROR;
TEST(E) DateIn2;
ErrDate2 = %ERROR;
IF NOT ErrDate1 AND NOT ErrDate2;
DiffYears = %DIFF(DateIn:DateIn2:*YEARS);
DiffMonths = %DIFF(DateIn:DateIn2:*MONTHS);
DiffDays = %DIFF(DateIn:DateIn2:*DAYS);
ENDIF;
ENDSR;
/end-free
P DayName B
D PI 9
D ParmDate D VALUE
D WorkField S 5 0
D Name S 9 BASED(NamePtr)
D NamePtr S * INZ(%ADDR(Names))
D Names S 63 INZ('Sunday Monday Tuesday Wedn+
D esdayThursday Friday Saturday ')
/free
WorkField = %DIFF(ParmDate:D'1899-12-31':*DAYS);
WorkField = %REM(WorkField:7);
NamePtr = NamePtr + (Workfield * 9);
RETURN Name;
/end-free
P DayName E
RPGLE - PF
Posted By: Mohit Contact
*************** Beginning of data **********************************************************
0007.00 * LIST 060919
0009.00 R INPLSTR 060928
0013.00 INPLIB 10A COLHDG('Input Library') 060928
0014.00 TEXT('Input Library') 060928
0015.00 ALIAS(INPUT_LIBRARY) 060928
0016.00 INPFIL 10A COLHDG('Input File') 060928
0017.00 TEXT('Input FIle') 060928
0017.01 ALIAS(INPUT_FILE) 060928
****************** End of data ************************************************************* RPGLE - Inquiry/Update/Add through a Single Page Subfile
Posted By: Kalpesh Patadia Contact
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
100 **********************************************************************
200 * Program Name . . . . : PGMCTLINQ *
201 * Description. . . . . : Program for Inquiry/Update/Add on PGMCTL *
300 *--------------------------------------------------------------------*
302 * Copyright ? . . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX *
303 *--------------------------------------------------------------------*
304 * Files Used . . . . . : PGMCTL - Program Control File *
305 * : *
306 * Display Files. . . . : PGMCTLD1 - Inquiry/Update/Add Screen *
307 * Printer Files. . . . : *NONE *
308 * Programs Called. . . : *NONE *
309 *--------------------------------------------------------------------*
400 * Created by . . . . . : KALPESH PATADIA *
500 * Company. . . . . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX *
600 * Date . . . . . . . . : Xxxxxxxxx 99, 9999 *
601 * Purpose. . . . . . . : To Inquiry/Update/Add on PGMCTL using single*
602 * : page subfile (SFLPAG = SFLSIZ) *
603 *--------------------------------------------------------------------*
700 **********************************************************************
702 HOPTION(*NODEBUGIO)
800 **********************************************************************
900 F* Files Used
1000 FPGMCTL UF A E K DISK
1100 FPGMCTLD1 CF E WORKSTN SFILE(INQSCR:@RRN)
1200 F**********************************************************************
1201 D* Store Page Information
1202 D@PAGINFO DS OCCURS(999)
1203 D @PGMID 1 10 INZ(*BLANKS)
1204 D @PAGENO 11 14 0 INZ(*ZEROS)
1205 D*--------------------------------------------------------------------*
1300 D* Retrieve System Values
1400 D@SYSVAL SDS
1500 D @PGMNM 1 10
1600 D @WRKID 244 253
1700 D @USRID 254 263
1800 D*--------------------------------------------------------------------*
1801 D* Program Variables
1802 D@RRN S 4 0 INZ(*ZEROS)
1804 D@STRLEN S 2 0 INZ(*ZEROS)
1805 D@STPOSN S 2 0 INZ(*ZEROS)
1806 D@PAGE# S 4 0 INZ(*ZEROS)
1807 D@ERFLG S N INZ(*OFF)
1808 D@CMDLN S 15 5 INZ(*ZEROS)
1809 D@COMND S 50A INZ(*BLANKS)
1810 D@STRNG1 C CONST('SEPHORA LIMITED')
1811 D@STRNG2 C CONST('Inquiry Screen')
1812 D@STRNG3 C CONST('Maintenance Screen')
1900 D**********************************************************************
2000 C* MAIN LINE *
2001 C**********************************************************************
2100 C EXSR SUBINIT
2200 C EXSR SUBPROC
2300 C EXSR SUBTERM
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
2401 C*--------------------------------------------------------------------*
2402 C* MAIN PROCESS ROUTINE *
2500 C*--------------------------------------------------------------------*
2600 C SUBPROC BEGSR
2700 C*
2701 C DOW *IN03 = *OFF
2703 C EXSR SUBDSP1
2704 C ENDDO
2800 C*
2900 C ENDPROC ENDSR
2901 C*--------------------------------------------------------------------*
2902 C* Display Screen One *
2903 C*--------------------------------------------------------------------*
2904 C SUBDSP1 BEGSR
2905 C*
2906 C EXSR SUBCLSF
2907 C EXSR SUBLOAD
2908 C EXSR SUBDSP2
2913 C*
2914 C ENDDSP1 ENDSR
2915 C*--------------------------------------------------------------------*
2916 C* Clear the Sub File *
2917 C*--------------------------------------------------------------------*
2918 C SUBCLSF BEGSR
2919 C*
2921 C EVAL *IN34 = *ON
2922 C WRITE INQCTL
2923 C EVAL *IN34 = *OFF
2924 C Z-ADD *ZEROS @RRN
2925 C*
2926 C ENDCLSF ENDSR
2927 C*--------------------------------------------------------------------*
2928 C* Load the Sub File *
2929 C*--------------------------------------------------------------------*
2930 C SUBLOAD BEGSR
2931 C*
2934 C SELECT
2939 C*
2940 C WHEN #OPTN = 1
2942 C EXSR SUBRTVP
2943 C @PGMID SETLL PGMCTL
2944 C READ PGMCTL
2946 C*
2947 C WHEN *IN60 = *ON
2948 C READ PGMCTL
2949 C ADD 1 @PAGE#
2950 C EXSR SUBSTRP
2951 C EVAL *IN60 = *OFF
2952 C*
2953 C WHEN *IN62 = *ON
2954 C SUB 1 @PAGE#
2955 C EXSR SUBRTVP
2956 C @PGMID SETLL PGMCTL
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
2957 C READ PGMCTL
2958 C EVAL *IN62 = *OFF
2959 C*
2960 C WHEN #PGMID = *BLANKS
2961 C *LOVAL SETLL PGMCTL
2962 C READ PGMCTL
2963 C Z-ADD 1 @PAGE#
2964 C EXSR SUBSTRP
2965 C*
2966 C OTHER
2967 C #PGMID SETLL PGMCTL
2968 C READ PGMCTL
2969 C Z-ADD 1 @PAGE#
2970 C EXSR SUBSTRP
2971 C ENDSL
2972 C*
2973 C CLEAR #OPTN
2974 C EVAL *IN47 = *OFF
2975 C DO 36
2976 C*
2977 C IF %EOF(PGMCTL)
2978 C EVAL *IN47 = *ON
2979 C LEAVE
2980 C ENDIF
2981 C*
2982 C ADD 1 @RRN
2983 C WRITE INQSCR
2984 C READ PGMCTL
2985 C ENDDO
2986 C*
2987 C ENDLOAD ENDSR
2988 C*--------------------------------------------------------------------*
2989 C* Display the Initial Screen *
2990 C*--------------------------------------------------------------------*
2991 C SUBDSP2 BEGSR
2992 C*
2993 C DOU @ERFLG = *OFF
2994 C SELECT
2995 C WHEN @RRN > *ZEROS
2996 C MOVEA '111' *IN(30)
2997 C OTHER
2998 C EVAL *IN32 = *ON
2999 C WRITE NORECD
3000 C ENDSL
3001 C*
3002 C WRITE INQFOT
3003 C EXFMT INQCTL
3004 C MOVEA '000' *IN(30)
3005 C*
3006 C IF *IN05 = *ON
3007 C EXSR SUBREFS
3008 C LEAVESR
3009 C ENDIF
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
3010 C*
3011 C IF *IN06 = *ON
3012 C EXSR SUBADDR
3013 C LEAVESR
3014 C ENDIF
3015 C*
3016 C IF @RRN >= 1
3017 C EXSR SUBVALD
3018 C ENDIF
3019 C ENDDO
3020 C*
3021 C SELECT
3022 C*
3023 C WHEN #OPTN = 1
3024 C EXSR SUBSELT
3025 C*
3026 C WHEN #OPTN = 2
3027 C EXSR SUBCHNG
3028 C*
3029 C WHEN #OPTN = 4
3030 C EXSR SUBDELT
3031 C*
3032 C ENDSL
3033 C*
3034 C ENDDSP2 ENDSR
3035 C*--------------------------------------------------------------------*
3036 C* Initialise The Screen *
3037 C*--------------------------------------------------------------------*
3038 C SUBINZS BEGSR
3039 C*
3040 C EVAL #PGMNM = @PGMNM
3041 C EVAL #USRID = @USRID
3042 C EVAL #SEP01 = *ALL'-'
3043 C EVAL #SEP02 = *ALL'-'
3044 C EVAL #SEP03 = *ALL'-'
3045 C EVAL #SEP04 = *ALL'-'
3046 C EVAL #CONFL = 'Y'
3047 C*
3048 C EVAL @STRLEN = %LEN(@STRNG1)
3049 C EVAL @STPOSN = ((40-@STRLEN)/2)+1
3050 C EVAL %SUBST(#TITLE:@STPOSN:@STRLEN) = @STRNG1
3051 C*
3052 C EVAL @STRLEN = %LEN(@STRNG2)
3053 C EVAL @STPOSN = ((40-@STRLEN)/2)+1
3054 C EVAL %SUBST(#SUBTL:@STPOSN:@STRLEN) = @STRNG2
3055 C*
3056 C EVAL @STRLEN = %LEN(@STRNG3)
3057 C EVAL @STPOSN = ((40-@STRLEN)/2)+1
3058 C EVAL %SUBST(#SBTL2:@STPOSN:@STRLEN) = @STRNG3
3059 C*
3060 C ENDINZS ENDSR
3061 C*--------------------------------------------------------------------*
3062 C* Store Page Information *
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
3063 C*--------------------------------------------------------------------*
3064 C SUBSTRP BEGSR
3065 C*
3066 C IF @PAGE# = 1
3067 C CLEAR @PAGINFO
3068 C ENDIF
3069 C @PAGE# OCCUR @PAGINFO
3070 C EVAL @PGMID = PGCPGM
3071 C Z-ADD @PAGE# @PAGENO
3072 C*
3073 C ENDSTRP ENDSR
3074 C*--------------------------------------------------------------------*
3075 C* Retrieve Page Information *
3076 C*--------------------------------------------------------------------*
3077 C SUBRTVP BEGSR
3078 C*
3079 C IF @PAGE# < 1
3080 C Z-ADD 1 @PAGE#
3081 C ENDIF
3082 C*
3083 C @PAGE# OCCUR @PAGINFO
3084 C Z-ADD @PAGENO @PAGE#
3085 C*
3086 C ENDRTVP ENDSR
3087 C*--------------------------------------------------------------------*
3088 C* Routine to ADD Records *
3089 C*--------------------------------------------------------------------*
3090 C SUBADDR BEGSR
3091 C*
3092 C EVAL *IN68 = *ON
3093 C EXSR SUBREF2
3094 C DOW *IN12 = *OFF
3095 C EXFMT DETSCR
3096 C*
3097 C IF *IN05 = *ON
3098 C EXSR SUBREF2
3099 C ITER
3100 C ENDIF
3101 C*
3102 C IF *IN09 = *ON
3103 C EVAL PGCPGM = #DATAID
3104 C Z-ADD #DIVNUM PGCCO
3105 C EVAL PGCLD1 = #DTACON
3106 C EVAL PGCDSC = #DTADSC
3107 C WRITE PGCFMT
3108 C EXSR SUBREF2
3109 C ENDIF
3110 C*
3111 C ENDDO
3112 C EVAL *IN68 = *OFF
3113 C*
3114 C ENDADDR ENDSR
3115 C*--------------------------------------------------------------------*
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
3116 C* Validation Routine *
3117 C*--------------------------------------------------------------------*
3118 C SUBVALD BEGSR
3119 C*
3120 C EVAL @ERFLG = *OFF
3121 C*
3122 C READC INQSCR 90
3123 C DOW *IN90 = *OFF
3124 C SELECT
3125 C WHEN #OPTN = 1 OR #OPTN = 2 OR #OPTN = 4 OR
3126 C #OPTN = 0
3127 C EVAL *IN55 = *OFF
3128 C EVAL @ERFLG = *OFF
3129 C*
3130 C OTHER
3131 C EVAL *IN55 = *ON
3132 C EVAL @ERFLG = *ON
3133 C*
3134 C ENDSL
3135 C*
3136 C IF #OPTN = 1
3137 C LEAVESR
3138 C ENDIF
3139 C*
3140 C EVAL *IN45 = *ON
3141 C UPDATE INQSCR
3142 C EVAL *IN45 = *OFF
3143 C*
3144 C READC INQSCR 90
3145 C ENDDO
3146 C*
3147 C ENDVALD ENDSR
3148 C*--------------------------------------------------------------------*
3149 C* Process the Selected Record *
3150 C*--------------------------------------------------------------------*
3151 C SUBSELT BEGSR
3152 C*
3153 C K01_PGCFMT CHAIN PGMCTL
3154 C*
3156 C EVAL #DATAID = PGCPGM
3157 C Z-ADD PGCCO #DIVNUM
3158 C EVAL #DTACON = PGCLD1
3159 C EVAL #DTADSC = PGCDSC
3160 C*
3161 C EVAL *IN67 = *ON
3162 C DOW *IN12 = *OFF
3163 C EXFMT DETSCR
3164 C ENDDO
3165 C EVAL *IN67 = *OFF
3166 C*
3167 C ENDSELT ENDSR
3168 C*--------------------------------------------------------------------*
3169 C* Update the Selected Record *
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
3170 C*--------------------------------------------------------------------*
3171 C SUBCHNG BEGSR
3172 C*
3173 C K01_PGCFMT CHAIN PGMCTL
3174 C EVAL #DATAID = PGCPGM
3175 C Z-ADD PGCCO #DIVNUM
3176 C EVAL #DTACON = PGCLD1
3177 C EVAL #DTADSC = PGCDSC
3178 C*
3179 C EVAL *IN66 = *ON
3180 C DOW *IN12 = *OFF
3181 C EXFMT DETSCR
3182 C*
3183 C IF *IN05 = *ON
3184 C EXSR SUBREF2
3185 C EVAL #DATAID = PGCPGM
3186 C Z-ADD PGCCO #DIVNUM
3187 C EVAL #DTACON = PGCLD1
3188 C EVAL #DTADSC = PGCDSC
3189 C ITER
3190 C ENDIF
3191 C*
3192 C IF *IN09 = *ON
3193 C EVAL PGCPGM = #DATAID
3194 C Z-ADD #DIVNUM PGCCO
3195 C EVAL PGCLD1 = #DTACON
3196 C EVAL PGCDSC = #DTADSC
3197 C UPDATE PGCFMT
3198 C LEAVE
3199 C ENDIF
3200 C*
3201 C ENDDO
3202 C EVAL *IN66 = *OFF
3203 C*
3204 C ENDCHNG ENDSR
3205 C*--------------------------------------------------------------------*
3206 C* Delete the Selected Record *
3207 C*--------------------------------------------------------------------*
3208 C SUBDELT BEGSR
3209 C*
3210 C K01_PGCFMT CHAIN PGMCTL
3211 C EXFMT DLTRCD
3212 C*
3213 C IF #CONFL = 'Y'
3214 C DELETE PGCFMT
3215 C ENDIF
3216 C*
3217 C ENDDELT ENDSR
3218 C*--------------------------------------------------------------------*
3219 C* Refresh the First Screen *
3220 C*--------------------------------------------------------------------*
3221 C SUBREFS BEGSR
3222 C*
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/17/06 03:33:47
SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC
MEMBER . . . . . . . . . PGMCTLINQ
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
3223 C MOVEA '000' *IN(66)
3224 C CLEAR INQCTL
3225 C CLEAR INQSCR
3226 C EXSR SUBINZS
3227 C*
3228 C ENDREFS ENDSR
3229 C*--------------------------------------------------------------------*
3230 C* Refresh the Second Screen *
3231 C*--------------------------------------------------------------------*
3232 C SUBREF2 BEGSR
3233 C*
3234 C CLEAR DETSCR
3235 C EXSR SUBINZS
3236 C SELECT
3237 C WHEN #OPTN = 1
3238 C MOVEA '000' *IN(66)
3239 C WHEN #OPTN = 2
3240 C EVAL *IN66 = *ON
3241 C WHEN *IN06 = *ON
3242 C EVAL *IN68 = *ON
3243 C ENDSL
3244 C*
3245 C ENDREF2 ENDSR
3246 C*--------------------------------------------------------------------*
3247 C* INITIAL ROUTINE *
3248 C*--------------------------------------------------------------------*
3300 C SUBINIT BEGSR
3400 C*
3401 C EXSR SUBINZS
3403 C* Key Field to Access PGMCTL
3404 C K01_PGCFMT KLIST
3405 C KFLD PGCPGM
3406 C KFLD PGCCO
3500 C*
3600 C ENDINIT ENDSR
3700 C*--------------------------------------------------------------------*
3800 C* TERMINATION ROUTINE *
3900 C*--------------------------------------------------------------------*
4000 C SUBTERM BEGSR
4100 C*
4101 C EVAL *INLR = *ON
4200 C*
4300 C ENDTERM ENDSR
4400 C**********************************************************************
* * * * E N D O F S O U R C E * * * *
RPGLE - Display a Digital Clock
Posted By: Kalpesh Patadia Contact
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/30/06 20:57:13
SOURCE FILE . . . . . . . DEVNSK/QCLSRC
MEMBER . . . . . . . . . CLOCKC1
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0
0200 /****************************************************************/
0300 /* Program Name . . . . : CLOCKC1 */
0400 /* Program Description. : This program displays a digital clock */
0600 /* : */
0700 /* Files Used . . . . . : *NONE */
0800 /* Files Overridden . . : *NONE */
0801 /* Files Declared . . . : CLOCKD1 - Screen for the Clock */
0900 /****************************************************************/
1000 /*Copyright (C) . . . . : XxxxxxX Xxxxxxxxxxxx, Xxxxxxxxx */
1100 /****************************************************************/
1200 /* Created by . . . . . : KALPESH PATADIA */
1300 /* Company. . . . . . . : XxxxxxX Xxxxxxxxxxxx, Xxxxxxxxx */
1400 /* Date . . . . . . . . : October 27, 2006 */
1500 /* Project ID . . . . . : XXXX9999 Marked . . : X9999 */
1600 /* Reason . . . . . . . : To display a digital clock with auto */
1700 /* : refresh. */
1800 /*--------------------------------------------------------------*/
1900 /****************************************************************/
2000 PGM
2100 /*--------------------------------------------------------------*/
2200 /* Declare Variables and Files */
2300 /*--------------------------------------------------------------*/
2301 DCLF FILE(CLOCKD1) RCDFMT(*ALL)
2302 /*--------------------------------------------------------------*/
2500 DCL VAR(&HOUR) TYPE(*CHAR) LEN(2) /* Hour +
2600 Component of the Time */
2700 DCL VAR(&MINUTE) TYPE(*CHAR) LEN(2) /* Minute +
2800 Component of the Time */
2900 DCL VAR(&SECOND) TYPE(*CHAR) LEN(2) /* Second +
3000 Component of the Time */
3100 DCL VAR(&CURDAT) TYPE(*CHAR) LEN(6) /* Current +
3200 Date */
3300 DCL VAR(&CURDAY) TYPE(*CHAR) LEN(4) /* Current +
3400 Day */
3403 /*--------------------------------------------------------------*/
3600 DCL VAR(&HRLFT) TYPE(*CHAR) LEN(1) /* Left Digit +
3700 of the Hour */
3800 DCL VAR(&HRRGT) TYPE(*CHAR) LEN(1) /* Right +
3900 Digit of the Hour */
4000 DCL VAR(&MINLFT) TYPE(*CHAR) LEN(1) /* Left +
4100 Digit of the Minute */
4200 DCL VAR(&MINRGT) TYPE(*CHAR) LEN(1) /* Right +
4300 Digit of the Minute */
4400 DCL VAR(&SECLFT) TYPE(*CHAR) LEN(1) /* Left +
4500 Digit of the Second */
4600 DCL VAR(&SECRGT) TYPE(*CHAR) LEN(1) /* Right +
4700 Digit of the Second */
4701 /*--------------------------------------------------------------*/
4900 /* MAIN LINE */
5000 /*--------------------------------------------------------------*/
"5100 RUN: /* Retrieve Current Date, Time and Day */"
5200 RTVSYSVAL SYSVAL(QHOUR) RTNVAR(&HOUR)
5300 RTVSYSVAL SYSVAL(QMINUTE) RTNVAR(&MINUTE)
5400 RTVSYSVAL SYSVAL(QSECOND) RTNVAR(&SECOND)
5500 RTVSYSVAL SYSVAL(QDATE) RTNVAR(&CURDAT)
5600 RTVSYSVAL SYSVAL(QDAYOFWEEK) RTNVAR(&CURDAY)
5700 /*--------------------------------------------------------------*/
5800 /* Display Current Date And Day */
5900 /*--------------------------------------------------------------*/
6000 CVTDAT DATE(&CURDAT) TOVAR(&#CURDT) TOFMT(*DMYY) +
6100 TOSEP(/)
6200
6300 IF COND(&CURDAY = *SUN) THEN(CHGVAR +
6400 VAR(&#WKDAY) VALUE('Sunday'))
6500 IF COND(&CURDAY = *MON) THEN(CHGVAR +
6600 VAR(&#WKDAY) VALUE('Monday'))
6700 IF COND(&CURDAY = *TUE) THEN(CHGVAR +
6800 VAR(&#WKDAY) VALUE('Tuesday'))
6900 IF COND(&CURDAY = *WED) THEN(CHGVAR +
7000 VAR(&#WKDAY) VALUE('Wednesday'))
7100 IF COND(&CURDAY = *THU) THEN(CHGVAR +
7200 VAR(&#WKDAY) VALUE('Thursday'))
7300 IF COND(&CURDAY = *FRI) THEN(CHGVAR +
7400 VAR(&#WKDAY) VALUE('Friday'))
7500 IF COND(&CURDAY = *SAT) THEN(CHGVAR +
7600 VAR(&#WKDAY) VALUE('Saturday'))
7700 /*--------------------------------------------------------------*/
7800 /* Display Current Time */
7900 /*--------------------------------------------------------------*/
8000 CHGVAR VAR(&HRLFT) VALUE(%SST(&HOUR 1 1))
8100 CHGVAR VAR(&HRRGT) VALUE(%SST(&HOUR 2 1))
8200
8300 CHGVAR VAR(&MINLFT) VALUE(%SST(&MINUTE 1 1))
8400 CHGVAR VAR(&MINRGT) VALUE(%SST(&MINUTE 2 1))
8500
8600 CHGVAR VAR(&SECLFT) VALUE(%SST(&SECOND 1 1))
8700 CHGVAR VAR(&SECRGT) VALUE(%SST(&SECOND 2 1))
8800 /*--------------------------------------------------------------*/
8900 /* Display Left Digit of the Hour */
9000 /*--------------------------------------------------------------*/
9100 IF COND(&HRLFT *EQ '1') THEN(CHGVAR VAR(&IN11) +
9200 VALUE('1'))
9201
9300 IF COND(&HRLFT *EQ '2') THEN(CHGVAR VAR(&IN12) +
9400 VALUE('1'))
9500 /*--------------------------------------------------------------*/
9600 /* Display Right Digit of the Hour */
9700 /*--------------------------------------------------------------*/
9800 IF COND(&HRRGT *EQ '0') THEN(CHGVAR VAR(&IN20) +
9900 VALUE('1'))
10000
10100 IF COND(&HRRGT *EQ '1') THEN(CHGVAR VAR(&IN21) +
10200 VALUE('1'))
10300
10400 IF COND(&HRRGT *EQ '2') THEN(CHGVAR VAR(&IN22) +
10500 VALUE('1'))
10600
10700 IF COND(&HRRGT *EQ '3') THEN(CHGVAR VAR(&IN23) +
10800 VALUE('1'))
10900
11000 IF COND(&HRRGT *EQ '4') THEN(CHGVAR VAR(&IN24) +
11100 VALUE('1'))
11200
11300 IF COND(&HRRGT *EQ '5') THEN(CHGVAR VAR(&IN25) +
11400 VALUE('1'))
11500
11600 IF COND(&HRRGT *EQ '6') THEN(CHGVAR VAR(&IN26) +
11700 VALUE('1'))
11800
11900 IF COND(&HRRGT *EQ '7') THEN(CHGVAR VAR(&IN27) +
12000 VALUE('1'))
12100
12200 IF COND(&HRRGT *EQ '8') THEN(CHGVAR VAR(&IN28) +
12300 VALUE('1'))
12400
12500 IF COND(&HRRGT *EQ '9') THEN(CHGVAR VAR(&IN29) +
12600 VALUE('1'))
12701 /*--------------------------------------------------------------*/
12702 /* Display Left Digit of the Minute */
12703 /*--------------------------------------------------------------*/
12800 IF COND(&MINLFT *EQ '0') THEN(CHGVAR VAR(&IN30) +
12900 VALUE('1'))
13000
13100 IF COND(&MINLFT *EQ '1') THEN(CHGVAR VAR(&IN31) +
13200 VALUE('1'))
13300
13400 IF COND(&MINLFT *EQ '2') THEN(CHGVAR VAR(&IN32) +
13500 VALUE('1'))
13600
13700 IF COND(&MINLFT *EQ '3') THEN(CHGVAR VAR(&IN33) +
13800 VALUE('1'))
13900
14000 IF COND(&MINLFT *EQ '4') THEN(CHGVAR VAR(&IN34) +
14100 VALUE('1'))
14200
14300 IF COND(&MINLFT *EQ '5') THEN(CHGVAR VAR(&IN35) +
14400 VALUE('1'))
14500
14600 IF COND(&MINLFT *EQ '6') THEN(CHGVAR VAR(&IN36) +
14700 VALUE('1'))
14800
14900 IF COND(&MINLFT *EQ '7') THEN(CHGVAR VAR(&IN37) +
15000 VALUE('1'))
15100
15200 IF COND(&MINLFT *EQ '8') THEN(CHGVAR VAR(&IN38) +
15300 VALUE('1'))
15400
15500 IF COND(&MINLFT *EQ '9') THEN(CHGVAR VAR(&IN39) +
15600 VALUE('1'))
15701 /*--------------------------------------------------------------*/
15702 /* Display Right Digit of the Minute */
15703 /*--------------------------------------------------------------*/
15800 IF COND(&MINRGT *EQ '0') THEN(CHGVAR VAR(&IN40) +
15900 VALUE('1'))
16000
16100 IF COND(&MINRGT *EQ '1') THEN(CHGVAR VAR(&IN41) +
16200 VALUE('1'))
16300
16400 IF COND(&MINRGT *EQ '2') THEN(CHGVAR VAR(&IN42) +
16500 VALUE('1'))
16600
16700 IF COND(&MINRGT *EQ '3') THEN(CHGVAR VAR(&IN43) +
16800 VALUE('1'))
16900
17000 IF COND(&MINRGT *EQ '4') THEN(CHGVAR VAR(&IN44) +
17100 VALUE('1'))
17200
17300 IF COND(&MINRGT *EQ '5') THEN(CHGVAR VAR(&IN45) +
17400 VALUE('1'))
17500
17600 IF COND(&MINRGT *EQ '6') THEN(CHGVAR VAR(&IN46) +
17700 VALUE('1'))
17800
17900 IF COND(&MINRGT *EQ '7') THEN(CHGVAR VAR(&IN47) +
18000 VALUE('1'))
18100
18200 IF COND(&MINRGT *EQ '8') THEN(CHGVAR VAR(&IN48) +
18300 VALUE('1'))
18400
18500 IF COND(&MINRGT *EQ '9') THEN(CHGVAR VAR(&IN49) +
18600 VALUE('1'))
18700 /*--------------------------------------------------------------*/
18800 /* Display Left Digit of the Second */
18900 /*--------------------------------------------------------------*/
18901 IF COND(&SECLFT *EQ '0') THEN(CHGVAR VAR(&IN50) +
18902 VALUE('1'))
18903
18904 IF COND(&SECLFT *EQ '1') THEN(CHGVAR VAR(&IN51) +
18905 VALUE('1'))
18906
18907 IF COND(&SECLFT *EQ '2') THEN(CHGVAR VAR(&IN52) +
18908 VALUE('1'))
18909
18910 IF COND(&SECLFT *EQ '3') THEN(CHGVAR VAR(&IN53) +
18911 VALUE('1'))
18912
18913 IF COND(&SECLFT *EQ '4') THEN(CHGVAR VAR(&IN54) +
18914 VALUE('1'))
18915
18916 IF COND(&SECLFT *EQ '5') THEN(CHGVAR VAR(&IN55) +
18917 VALUE('1'))
18918
18919 IF COND(&SECLFT *EQ '6') THEN(CHGVAR VAR(&IN56) +
18920 VALUE('1'))
18921
18922 IF COND(&SECLFT *EQ '7') THEN(CHGVAR VAR(&IN57) +
18923 VALUE('1'))
18924
18925 IF COND(&SECLFT *EQ '8') THEN(CHGVAR VAR(&IN58) +
18926 VALUE('1'))
18927
18928 IF COND(&SECLFT *EQ '9') THEN(CHGVAR VAR(&IN59) +
18929 VALUE('1'))
19000 /*--------------------------------------------------------------*/
19100 /* Display Right Digit of the Second */
19200 /*--------------------------------------------------------------*/
19300 IF COND(&SECRGT *EQ '0') THEN(CHGVAR VAR(&IN60) +
19400 VALUE('1'))
19500
19600 IF COND(&SECRGT *EQ '1') THEN(CHGVAR VAR(&IN61) +
19700 VALUE('1'))
19800
19900 IF COND(&SECRGT *EQ '2') THEN(CHGVAR VAR(&IN62) +
20000 VALUE('1'))
20100
20200 IF COND(&SECRGT *EQ '3') THEN(CHGVAR VAR(&IN63) +
20300 VALUE('1'))
20400
20500 IF COND(&SECRGT *EQ '4') THEN(CHGVAR VAR(&IN64) +
20600 VALUE('1'))
20700
20800 IF COND(&SECRGT *EQ '5') THEN(CHGVAR VAR(&IN65) +
20900 VALUE('1'))
21000
21100 IF COND(&SECRGT *EQ '6') THEN(CHGVAR VAR(&IN66) +
21200 VALUE('1'))
21300
21400 IF COND(&SECRGT *EQ '7') THEN(CHGVAR VAR(&IN67) +
21500 VALUE('1'))
21600
21700 IF COND(&SECRGT *EQ '8') THEN(CHGVAR VAR(&IN68) +
21800 VALUE('1'))
21900
22000 IF COND(&SECRGT *EQ '9') THEN(CHGVAR VAR(&IN69) +
22100 VALUE('1'))
22200 /*--------------------------------------------------------------*/
22300 /* Display The Clock */
22400 /*--------------------------------------------------------------*/
22500 SNDRCVF RCDFMT(CLOCKD10) WAIT(*NO)
22600 MONMSG MSGID(CPF0887) EXEC(DO)
22700 RCVMSG MSGTYPE(*EXCP)
22800 RCVF
22900 IF COND(&IN03 *EQ '1') THEN(GOTO CMDLBL(END))
23000 ENDDO
23100 DLYJOB DLY(1)
23101 /*--------------------------------------------------------------*/
23102 /* Initialise the display indicators */
23103 /*--------------------------------------------------------------*/
23200 CHGVAR VAR(&IN11) VALUE('0')
23300 CHGVAR VAR(&IN12) VALUE('0')
23301
23400 CHGVAR VAR(&IN20) VALUE('0')
23500 CHGVAR VAR(&IN21) VALUE('0')
23600 CHGVAR VAR(&IN22) VALUE('0')
23700 CHGVAR VAR(&IN23) VALUE('0')
23800 CHGVAR VAR(&IN24) VALUE('0')
23900 CHGVAR VAR(&IN25) VALUE('0')
24000 CHGVAR VAR(&IN26) VALUE('0')
24100 CHGVAR VAR(&IN27) VALUE('0')
24200 CHGVAR VAR(&IN28) VALUE('0')
24300 CHGVAR VAR(&IN29) VALUE('0')
24301
24400 CHGVAR VAR(&IN30) VALUE('0')
24500 CHGVAR VAR(&IN31) VALUE('0')
24600 CHGVAR VAR(&IN32) VALUE('0')
24700 CHGVAR VAR(&IN33) VALUE('0')
24800 CHGVAR VAR(&IN34) VALUE('0')
24900 CHGVAR VAR(&IN35) VALUE('0')
25000 CHGVAR VAR(&IN36) VALUE('0')
25100 CHGVAR VAR(&IN37) VALUE('0')
25200 CHGVAR VAR(&IN38) VALUE('0')
25300 CHGVAR VAR(&IN39) VALUE('0')
25400
25500 CHGVAR VAR(&IN40) VALUE('0')
25600 CHGVAR VAR(&IN41) VALUE('0')
25700 CHGVAR VAR(&IN42) VALUE('0')
25800 CHGVAR VAR(&IN43) VALUE('0')
25900 CHGVAR VAR(&IN44) VALUE('0')
26000 CHGVAR VAR(&IN45) VALUE('0')
26100 CHGVAR VAR(&IN46) VALUE('0')
26200 CHGVAR VAR(&IN47) VALUE('0')
26300 CHGVAR VAR(&IN48) VALUE('0')
26400 CHGVAR VAR(&IN49) VALUE('0')
26500
26700 CHGVAR VAR(&IN50) VALUE('0')
26800 CHGVAR VAR(&IN51) VALUE('0')
26900 CHGVAR VAR(&IN52) VALUE('0')
27000 CHGVAR VAR(&IN53) VALUE('0')
27100 CHGVAR VAR(&IN54) VALUE('0')
27200 CHGVAR VAR(&IN55) VALUE('0')
27300 CHGVAR VAR(&IN56) VALUE('0')
27400 CHGVAR VAR(&IN57) VALUE('0')
27500 CHGVAR VAR(&IN58) VALUE('0')
27600 CHGVAR VAR(&IN59) VALUE('0')
27700
27800 CHGVAR VAR(&IN60) VALUE('0')
27900 CHGVAR VAR(&IN61) VALUE('0')
28000 CHGVAR VAR(&IN62) VALUE('0')
28100 CHGVAR VAR(&IN63) VALUE('0')
28200 CHGVAR VAR(&IN64) VALUE('0')
28300 CHGVAR VAR(&IN65) VALUE('0')
28400 CHGVAR VAR(&IN66) VALUE('0')
28500 CHGVAR VAR(&IN67) VALUE('0')
28600 CHGVAR VAR(&IN68) VALUE('0')
28700 CHGVAR VAR(&IN69) VALUE('0')
28800
28900 GOTO CMDLBL(RUN)
29000
29100 END: ENDPGM
* * * * E N D O F S O U R C E * * * *
RPGLE - Display a Pop-up Calendar
Posted By: Kalpesh Patadia Contact
5722WDS V5R2M0 020719 SEU SOURCE LISTING 10/30/06 20:57:08 SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC MEMBER . . . . . . . . . CALENDAR SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 0100 ********************************************************************** 0200 * Program Name . . . . : CALENDAR * 0300 * Description. . . . . : Program to show a pop-up Calendar * 0400 *--------------------------------------------------------------------* 0500 * Copyright (c). . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX * 0600 *--------------------------------------------------------------------* 0700 * Files Used . . . . . : *NONE * 0800 * : * 0900 * Display Files. . . . : CALEND1 - Screen for pop-up calendar * 1000 * Printer Files. . . . : *NONE * 1100 * Programs Called. . . : *NONE * 1200 *--------------------------------------------------------------------* 1300 * Created by . . . . . : KALPESH PATADIA * 1400 * Company. . . . . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX * 1500 * Date . . . . . . . . : October 27, 2006 * 1600 * Purpose. . . . . . . : To Show a Pop-up Calendar with previous * 1700 * : and future dates as well. (Display Only) * 1800 *--------------------------------------------------------------------* 1900 ********************************************************************** 2000 HOPTION(*NODEBUGIO) 2100 ********************************************************************** 2200 F* Files Used 2300 FCALEND1 CF E WORKSTN 2301 ********************************************************************** 2302 D* Store Month Names 2303 DM@NAM S 9 DIM(12) CTDATA PERRCD(1) 2400 *--------------------------------------------------------------------* 2401 D* Store No of Days in a Month 2402 DD@AYS S 2 0 DIM(12) CTDATA PERRCD(12) 2403 *--------------------------------------------------------------------* 2404 D* Store the Dates for each day 2405 DD@ATE S 2 0 DIM(42) 2406 *--------------------------------------------------------------------* 2407 D* Store the Current Date 2408 D@CURDAT S D INZ(*SYS) DATFMT(*ISO) 2409 D@CURYER S 4 0 INZ(*ZEROS) 2410 D@CURMTH S 2 0 INZ(*ZEROS) 2411 D@CURDAY S 2 0 INZ(*ZEROS) 2412 *--------------------------------------------------------------------* 2413 D* Display Attributes of each day 2414 D@DSPATR DS 2415 D @DAY01 1 INZ(@NORML) 2416 D @DAY02 1 INZ(@NORML) 2417 D @DAY03 1 INZ(@NORML) 2418 D @DAY04 1 INZ(@NORML) 2419 D @DAY05 1 INZ(@NORML) 2420 D @DAY06 1 INZ(@NORML) 2421 D @DAY07 1 INZ(@NORML) 2422 D @DAY08 1 INZ(@NORML) 2423 D @DAY09 1 INZ(@NORML) 2424 D @DAY10 1 INZ(@NORML) 2425 D @DAY11 1 INZ(@NORML) 2426 D @DAY12 1 INZ(@NORML) 2427 D @DAY13 1 INZ(@NORML) 2428 D @DAY14 1 INZ(@NORML) 2429 D @DAY15 1 INZ(@NORML) 2430 D @DAY16 1 INZ(@NORML) 2431 D @DAY17 1 INZ(@NORML) 2432 D @DAY18 1 INZ(@NORML) 2433 D @DAY19 1 INZ(@NORML) 2434 D @DAY20 1 INZ(@NORML) 2435 D @DAY21 1 INZ(@NORML) 2436 D @DAY22 1 INZ(@NORML) 2437 D @DAY23 1 INZ(@NORML) 2438 D @DAY24 1 INZ(@NORML) 2439 D @DAY25 1 INZ(@NORML) 2440 D @DAY26 1 INZ(@NORML) 2441 D @DAY27 1 INZ(@NORML) 2442 D @DAY28 1 INZ(@NORML) 2443 D @DAY29 1 INZ(@NORML) 2444 D @DAY30 1 INZ(@NORML) 2445 D @DAY31 1 INZ(@NORML) 2446 D @DAY32 1 INZ(@NORML) 2447 D @DAY33 1 INZ(@NORML) 2448 D @DAY34 1 INZ(@NORML) 2449 D @DAY35 1 INZ(@NORML) 2450 D @DAY36 1 INZ(@NORML) 2451 D @DAY37 1 INZ(@NORML) 2452 D @DAY38 1 INZ(@NORML) 2453 D @DAY39 1 INZ(@NORML) 2454 D @DAY40 1 INZ(@NORML) 2455 D @DAY41 1 INZ(@NORML) 2456 D @DAY42 1 INZ(@NORML) 2457 D @DYATR 1 DIM(42) OVERLAY(@DSPATR) 2458 *--------------------------------------------------------------------* 2459 D* Display Attributes in the Screen 2460 D @NORML C CONST(x'20') 2461 D @RVIMG C CONST(x'21') 2462 *--------------------------------------------------------------------* 2500 D* Program Variables 2501 D@STRTDT DS 2503 D@STRYER 1 4 0 INZ(*ZEROS) 2504 D@STRMTH 5 6 0 INZ(*ZEROS) 2505 D@STRDAY 7 8 0 INZ(*ZEROS) 2506 D@STRDT1 1 8 0 INZ(*ZEROS) 2507 *--------------------------------------------------------------------* 2508 D* Program Variables 2509 D@STRDAT S D DATFMT(*ISO) 2510 D@BEGDAT S D DATFMT(*ISO) INZ(D'1905-12-31') 2511 D@DATE S 2 0 INZ(*ZEROS) 2512 D@TMPVR1 S 2 0 INZ(*ZEROS) 2513 D@TMPVR2 S 4 0 INZ(*ZEROS) 2514 D@TMPVR3 S 6 0 INZ(*ZEROS) 2600 ********************************************************************** 2700 C* MAIN LINE 2800 ********************************************************************** 2900 C EXSR SUBINIT 3000 C EXSR SUBPROC 3100 C EXSR SUBTERM 3200 ********************************************************************** 3201 C* Main Process Routine 3300 *--------------------------------------------------------------------* 3301 C SUBPROC BEGSR 3302 C* 3303 C DOW *IN03 = *OFF 3304 C* 3305 C EVAL #MTHNAM = M@NAM(@STRMTH) 3306 C EVAL #YERNUM = @STRYER 3307 C* Retrieve the 1st day of the Week 3308 C @STRDAT SUBDUR @BEGDAT @TMPVR3:*D 3309 C EVAL @TMPVR2 = %REM(@TMPVR3:7) 3310 C EVAL @TMPVR2 = @TMPVR2 + 1 3311 C* Store the Dates in the calendar 3312 C 01 DO D@AYS(@STRMTH)@DATE 3313 C EVAL D@ATE(@TMPVR2) = @DATE 3314 C EVAL @TMPVR2 = @TMPVR2 + 1 3315 C ENDDO 3316 C* Fill Dates for Display 3317 C EVAL #DAY01 = D@ATE(01) 3318 C EVAL #DAY02 = D@ATE(02) 3319 C EVAL #DAY03 = D@ATE(03) 3320 C EVAL #DAY04 = D@ATE(04) 3321 C EVAL #DAY05 = D@ATE(05) 3322 C EVAL #DAY06 = D@ATE(06) 3323 C EVAL #DAY07 = D@ATE(07) 3324 C EVAL #DAY08 = D@ATE(08) 3325 C EVAL #DAY09 = D@ATE(09) 3326 C EVAL #DAY10 = D@ATE(10) 3327 C EVAL #DAY11 = D@ATE(11) 3328 C EVAL #DAY12 = D@ATE(12) 3329 C EVAL #DAY13 = D@ATE(13) 3330 C EVAL #DAY14 = D@ATE(14) 3331 C EVAL #DAY15 = D@ATE(15) 3332 C EVAL #DAY16 = D@ATE(16) 3333 C EVAL #DAY17 = D@ATE(17) 3334 C EVAL #DAY18 = D@ATE(18) 3335 C EVAL #DAY19 = D@ATE(19) 3336 C EVAL #DAY20 = D@ATE(20) 3337 C EVAL #DAY21 = D@ATE(21) 3338 C EVAL #DAY22 = D@ATE(22) 3339 C EVAL #DAY23 = D@ATE(23) 3340 C EVAL #DAY24 = D@ATE(24) 3341 C EVAL #DAY25 = D@ATE(25) 3342 C EVAL #DAY26 = D@ATE(26) 3343 C EVAL #DAY27 = D@ATE(27) 3344 C EVAL #DAY28 = D@ATE(28) 3345 C EVAL #DAY29 = D@ATE(29) 3346 C EVAL #DAY30 = D@ATE(30) 3347 C EVAL #DAY31 = D@ATE(31) 3348 C EVAL #DAY32 = D@ATE(32) 3349 C EVAL #DAY33 = D@ATE(33) 3350 C EVAL #DAY34 = D@ATE(34) 3351 C EVAL #DAY35 = D@ATE(35) 3352 C EVAL #DAY36 = D@ATE(36) 3353 C EVAL #DAY37 = D@ATE(37) 3354 C EVAL #DAY38 = D@ATE(38) 3355 C EVAL #DAY39 = D@ATE(39) 3356 C EVAL #DAY40 = D@ATE(40) 3357 C EVAL #DAY41 = D@ATE(41) 3358 C EVAL #DAY42 = D@ATE(42) 3359 C* Display the Calendar 3360 C* (Mark the current date) 3361 C EVAL @TMPVR1 = %LOOKUP(@CURDAY:D@ATE) 3362 C IF @TMPVR1 > *ZEROS 3363 C EVAL @DYATR(@TMPVR1) = @RVIMG 3364 C ELSE 3365 C EVAL @DYATR(@TMPVR2 - 1) = @RVIMG 3366 C ENDIF 3367 C EXFMT CALENDAR 3368 C* 3369 C SELECT 3370 C WHEN *IN03 = *ON 3371 C LEAVE 3372 C* On Page Up - Previous Month 3373 C WHEN *IN84 = *ON 3374 C CLEAR D@ATE 3375 C CLEAR @DYATR 3376 C EVAL @STRMTH = @STRMTH - 1 3377 C IF @STRMTH <= 0 3378 C EVAL @STRMTH = 12 3379 C EVAL @STRYER = @STRYER - 1 3380 C ENDIF 3381 C EVAL @STRDAY = 01 3385 C MOVEL @STRDT1 @STRDAT 3386 C EXSR SUBLPYR 3387 C EVAL *IN84 = *OFF 3388 C* On Page Down - Next Month 3389 C WHEN *IN85 = *ON 3391 C CLEAR D@ATE 3392 C CLEAR @DYATR 3393 C EVAL @STRMTH = @STRMTH + 1 3394 C IF @STRMTH > 12 3395 C EVAL @STRMTH = 1 3396 C EVAL @STRYER = @STRYER + 1 3397 C ENDIF 3398 C EVAL @STRDAY = 01 3400 C MOVEL @STRDT1 @STRDAT 3401 C EXSR SUBLPYR 3402 C EVAL *IN85 = *OFF 3403 C ENDSL 3404 C* 3405 C ENDDO 3406 C* 3407 C ENDPROC ENDSR 3408 *--------------------------------------------------------------------* 3409 C* Check for Leap Year 3410 *--------------------------------------------------------------------* 3411 C SUBLPYR BEGSR 3412 C* 3413 C N84 3414 CANN85 MOVEL *YEAR @STRYER 3415 C EVAL @TMPVR2 = %REM(@STRYER:4) 3416 C IF @TMPVR2 = *ZEROS 3417 C EVAL D@AYS(2) = 29 3418 C ENDIF 3419 C* 3420 C ENDLPYR ENDSR 3421 *--------------------------------------------------------------------* 3422 C* Initial Routine 3423 *--------------------------------------------------------------------* 3424 C SUBINIT BEGSR 3425 C* 3426 C MOVEL *MONTH @CURMTH 3427 C Z-ADD @CURMTH @STRMTH 3428 C EXSR SUBLPYR 3429 C* Retrieve the 1st day of the Month 3430 C MOVEL *DAY @CURDAY 3431 C Z-ADD @CURDAY @STRDAY 3432 C IF @CURDAY > 1 3433 C @CURDAT SUBDUR @CURDAY:*D @STRDAT 3434 C ELSE 3435 C MOVEL @CURDAT @STRDAT 3436 C ENDIF 3437 C* 3438 C ENDINIT ENDSR 3439 *--------------------------------------------------------------------* 3500 C* Termination Routine 3600 *--------------------------------------------------------------------* 3700 C SUBTERM BEGSR 3800 C* 3801 C EVAL *INLR = *ON 3900 C* 4000 C ENDTERM ENDSR 4100 ********************************************************************** 4200 ** CTDATA M@NAM 4300 January 4400 February 4500 March 4600 April 4700 May 4800 June 4900 July 5000 August 5100 September 5200 October 5300 November 5400 December 5500 ** CTDATA D@AYS 5600 312831303130313130313031 * * * * E N D O F S O U R C E * * * *
RPGLE - Convert Numbers to Words
Posted By: Kalpesh Patadia Contact
5722WDS V5R2M0 020719 SEU SOURCE LISTING 11/05/06 21:28:01 SOURCE FILE . . . . . . . DEVNSK/QRPGLESRC MEMBER . . . . . . . . . CONVNUM SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 0100 ********************************************************************** 0200 * Program Name . . . . : CONVNUM * 0300 * Description. . . . . : Program to convert a Numeric Figure into * 0301 * : Words * 0400 *--------------------------------------------------------------------* 0500 * Copyright (c). . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX * 0600 *--------------------------------------------------------------------* 0700 * Files Used . . . . . : *NONE * 0800 * : * 0900 * Display Files. . . . : CONVNOD1 - Entry screen for conversion * 1000 * Printer Files. . . . : *NONE * 1100 * Programs Called. . . : *NONE * 1200 *--------------------------------------------------------------------* 1300 * Created by . . . . . : KALPESH PATADIA * 1400 * Company. . . . . . . : XxxxxxX Xxxxxxxxxxx, Xxxxxxxxx. XXXXX * 1500 * Date . . . . . . . . : Xxxxxxxxx 99, 9999 * 1600 * Purpose. . . . . . . : To Convert a Numeric value into Words * 1700 * : (e.g. 27 = Twenty Seven) * 1800 *--------------------------------------------------------------------* 1900 ********************************************************************** 2000 HOPTION(*NODEBUGIO) 2100 ********************************************************************** 2200 F* Files Used 2300 FCONVNOD1 CF E WORKSTN 2400 ********************************************************************** 2500 D* Store Position of the Digits 2600 DP@OSN S 15 DIM(16) CTDATA PERRCD(1) 2700 *--------------------------------------------------------------------* 2800 D* Store Group One 2900 DG@RP1 S 9 DIM(20) CTDATA PERRCD(1) 2901 *--------------------------------------------------------------------* 3100 D* Store Group Two 3200 DG@RP2 S 7 DIM(09) CTDATA PERRCD(9) 3201 *--------------------------------------------------------------------* 3400 D* Store the Category 3500 DC@ATG S 3 DIM(03) CTDATA PERRCD(3) 3501 *--------------------------------------------------------------------* 3502 D* Store the Field Names 3503 DF@NAM S 6 DIM(16) CTDATA PERRCD(1) 3504 *--------------------------------------------------------------------* 3505 D* Store System Values 3506 D@SYSVAL SDS 3507 D @PGMNM 1 10 3508 D @WRKID 244 253 3509 D @USRID 254 263 3510 *--------------------------------------------------------------------* 3511 D* Store the Value Entered 3512 D@DIGITS DS 3513 D @INTGR 1 14 0 INZ(*ZEROS) 3514 D @TRILN 2 0 INZ(*ZEROS) OVERLAY(@INTGR:1) 3515 D @TRTEN 1 0 INZ(*ZEROS) OVERLAY(@INTGR:1) 3516 D @TRONE 1 0 INZ(*ZEROS) OVERLAY(@INTGR:2) 3517 D @BILLN 3 0 INZ(*ZEROS) OVERLAY(@INTGR:3) 3518 D @BLTHR 1 0 INZ(*ZEROS) OVERLAY(@INTGR:3) 3519 D @BLTWO 2 0 INZ(*ZEROS) OVERLAY(@INTGR:4) 3520 D @BLTEN 1 0 INZ(*ZEROS) OVERLAY(@INTGR:4) 3521 D @BLONE 1 0 INZ(*ZEROS) OVERLAY(@INTGR:5) 3522 D @CRORE 2 0 INZ(*ZEROS) OVERLAY(@INTGR:6) 3523 D @CRTEN 1 0 INZ(*ZEROS) OVERLAY(@INTGR:6) 3524 D @CRONE 1 0 INZ(*ZEROS) OVERLAY(@INTGR:7) 3525 D @MILLN 1 0 INZ(*ZEROS) OVERLAY(@INTGR:8) 3526 D @LACS 1 0 INZ(*ZEROS) OVERLAY(@INTGR:9) 3527 D @THSND 2 0 INZ(*ZEROS) OVERLAY(@INTGR:10) 3528 D @THTEN 1 0 INZ(*ZEROS) OVERLAY(@INTGR:10) 3529 D @THONE 1 0 INZ(*ZEROS) OVERLAY(@INTGR:11) 3530 D @HUNDR 1 0 INZ(*ZEROS) OVERLAY(@INTGR:12) 3531 D @LSTTO 2 0 INZ(*ZEROS) OVERLAY(@INTGR:13) 3532 D @TENS 1 0 INZ(*ZEROS) OVERLAY(@INTGR:13) 3533 D @ONES 1 0 INZ(*ZEROS) OVERLAY(@INTGR:14) 3534 D @DECML 15 16 2 INZ(*ZEROS) 3535 D @DCTWO 2 0 INZ(*ZEROS) OVERLAY(@DECML:1) 3536 D @DCTEN 1 0 INZ(*ZEROS) OVERLAY(@DECML:1) 3537 D @DCONE 1 0 INZ(*ZEROS) OVERLAY(@DECML:2) 3538 *--------------------------------------------------------------------* 3539 D* Program Variables 3540 D @WORDS S 256A INZ(*BLANKS) 3541 D @WORD1 S 27A INZ(*BLANKS) 3542 D @LNGTH S 2 0 INZ(*ZEROS) 3543 D @POSTN S 16A INZ(*BLANKS) 3544 D @POST1 S 16A INZ(*BLANKS) 3545 D @GROUP S 7A INZ(*BLANKS) 3546 D @NXTFL S 2 0 INZ(*ZEROS) 3547 D @FLDNM S 6A INZ(*BLANKS) 3548 D @TMPVR S 3 0 INZ(*ZEROS) 3600 ********************************************************************** 3601 * MAIN LINE * 3602 ********************************************************************** 3603 C EXSR SUBINIT 3604 C EXSR SUBPROC 3605 C EXSR SUBTERM 3606 ********************************************************************** 3607 * Main Process Routine * 3608 *--------------------------------------------------------------------* 3609 C SUBPROC BEGSR 3610 C* 3611 C DOW *IN03 = *OFF 3612 C* 3616 C EXFMT ENTSCR1 3617 C SELECT 3618 C WHEN *IN03 = *ON 3619 C LEAVE 3620 C* 3621 C WHEN *IN05 = *ON 3622 C EXSR SUBREFS 3623 C* 3624 C OTHER 3625 C EXSR SUBCONV 3626 C ENDSL 3627 C* 3628 C EVAL #CONVL1 = %SUBST(@WORDS:1:45) 3629 C EVAL #CONVL2 = %SUBST(@WORDS:46:45) 3630 C EVAL #CONVL3 = %SUBST(@WORDS:91:45) 3631 C EVAL #CONVL4 = %SUBST(@WORDS:136:45) 3636 C* 3637 C ENDDO 3638 C* 3639 C ENDPROC ENDSR 3640 *--------------------------------------------------------------------* 3641 * Screen Refresh Routine * 3642 *--------------------------------------------------------------------* 3643 C SUBREFS BEGSR 3644 C* 3645 C CLEAR ENTSCR1 3646 C CLEAR @WORDS 3647 C CLEAR @WORD1 3648 C MOVEA '000' *IN(03) 3649 C EXSR SUBINIT 3650 C* 3651 C ENDREFS ENDSR 3652 *--------------------------------------------------------------------* 3653 * Main Conversion Routine * 3654 *--------------------------------------------------------------------* 3655 C SUBCONV BEGSR 3656 C* 3657 C IF #NUMVL1 = *ZEROS 3658 C EXSR SUBREFS 3659 C LEAVESR 3660 C ENDIF 3661 C* 3662 C CLEAR @WORDS 3663 C CLEAR @WORD1 3666 C* 3667 C Z-ADD #NUMVL1 @INTGR 3668 C Z-ADD #NUMVL1 @DECML 3669 C* Retrieve Details of Digits 3670 C EVAL @LNGTH = %LEN(@DIGITS) 3671 C Z-ADD @LNGTH @NXTFL 3672 C* Convert to Words 3673 C DOW @NXTFL > *ZEROS 3674 C EVAL @POSTN = P@OSN(@NXTFL) 3675 C EVAL @POST1 = %SUBST(P@OSN(@NXTFL):5:11) 3676 C EVAL @FLDNM = F@NAM(@NXTFL) 3677 C EVAL @TMPVR = %INT(%SUBST(@POSTN:1:3)) 3678 C* 3679 C SELECT 3680 C WHEN @FLDNM = '@TRILN' 3681 C IF @TRILN > *ZERO AND @TRILN < 21 3682 C EVAL @WORD1 = G@RP1(@TRILN) 3683 C @WORD1 CAT @POST1:1 @WORDS 3684 C ENDIF 3685 C IF @TRILN >= 21 3686 C EVAL @WORD1 = G@RP2(@TRTEN) 3687 C EVAL @WORDS = @WORD1 3688 C EVAL @WORD1 = G@RP1(@TRONE) 3689 C CAT @WORD1:1 @WORDS 3690 C CAT @POST1:1 @WORDS 3691 C ENDIF 3692 C* 3693 C WHEN @FLDNM = '@BILLN' AND @BILLN > *ZEROS 3694 C IF @BILLN > 99 3695 C EVAL @WORD1 = G@RP1(@BLTHR) 3696 C CAT @WORD1:1 @WORDS 3697 C CAT 'HUNDRED':1 @WORDS 3698 C ENDIF 3699 C* 3700 C IF @BLTWO > *ZERO AND @BLTWO < 21 3701 C EVAL @WORD1 = G@RP1(@BLTWO) 3702 C CAT @WORD1:1 @WORDS 3703 C ENDIF 3704 C IF @BLTWO >= 21 3705 C EVAL @WORD1 = G@RP2(@BLTEN) 3706 C CAT @WORD1:1 @WORDS 3707 C EVAL @WORD1 = G@RP1(@BLONE) 3708 C CAT @WORD1:1 @WORDS 3709 C ENDIF 3710 C CAT @POST1:1 @WORDS 3711 C* 3712 C WHEN @FLDNM = '@CRORE' AND @CRORE > *ZEROS 3713 C IF @CRORE < 21 3714 C EVAL @WORD1 = G@RP1(@CRORE) 3715 C CAT @WORD1:1 @WORDS 3716 C ENDIF 3717 C IF @CRORE >= 21 3718 C EVAL @WORD1 = G@RP2(@CRTEN) 3719 C CAT @WORD1:1 @WORDS 3720 C EVAL @WORD1 = G@RP1(@CRONE) 3721 C CAT @WORD1:1 @WORDS 3722 C ENDIF 3723 C CAT @POST1:1 @WORDS 3724 C* 3725 C WHEN @FLDNM = '@MILLN' 3726 C IF @MILLN > *ZERO 3727 C EVAL @WORD1 = G@RP1(@MILLN) 3728 C CAT @WORD1:1 @WORDS 3729 C CAT @POST1:1 @WORDS 3730 C ENDIF 3731 C* 3732 C WHEN @FLDNM = '@LACS' 3733 C IF @LACS > *ZERO 3734 C EVAL @WORD1 = G@RP1(@LACS ) 3735 C CAT @WORD1:1 @WORDS 3736 C CAT @POST1:1 @WORDS 3737 C ENDIF 3738 C* 3739 C WHEN @FLDNM = '@THSND' AND @THSND > *ZEROS 3740 C IF @THSND < 21 3741 C EVAL @WORD1 = G@RP1(@THSND) 3742 C CAT @WORD1:1 @WORDS 3743 C ENDIF 3744 C IF @THSND >= 21 3745 C EVAL @WORD1 = G@RP2(@THTEN) 3746 C CAT @WORD1:1 @WORDS 3747 C EVAL @WORD1 = G@RP1(@THONE) 3748 C CAT @WORD1:1 @WORDS 3749 C ENDIF 3750 C CAT @POST1:1 @WORDS 3751 C* 3752 C WHEN @FLDNM = '@HUNDR' 3753 C IF @HUNDR > *ZEROS 3754 C EVAL @WORD1 = G@RP1(@HUNDR) 3755 C CAT @WORD1:1 @WORDS 3756 C CAT @POST1:1 @WORDS 3757 C ENDIF 3758 C* 3759 C WHEN @FLDNM = '@LSTTO' AND @LSTTO > *ZEROS 3760 C IF @LSTTO < 21 3761 C EVAL @WORD1 = G@RP1(@LSTTO) 3762 C CAT @WORD1:1 @WORDS 3763 C ENDIF 3764 C IF @LSTTO >= 21 3765 C EVAL @WORD1 = G@RP2(@TENS ) 3767 C CAT @WORD1:1 @WORDS 3768 C EVAL @WORD1 = G@RP1(@ONES ) 3769 C CAT @WORD1:1 @WORDS 3770 C ENDIF 3771 C* 3772 C WHEN @FLDNM = '@DECML' AND @DCTWO > *ZEROS 3773 C CAT @POST1:1 @WORDS 3774 C IF @DCTWO < 21 3775 C EVAL @WORD1 = G@RP1(@DCTWO) 3776 C CAT @WORD1:1 @WORDS 3777 C ENDIF 3778 C IF @DCTWO >= 21 3779 C EVAL @WORD1 = G@RP2(@DCTEN) 3780 C CAT @WORD1:1 @WORDS 3781 C EVAL @WORD1 = G@RP1(@DCONE) 3782 C CAT @WORD1:1 @WORDS 3783 C ENDIF 3784 C* 3789 C ENDSL 3790 C* 3791 C SELECT 3792 C WHEN @TMPVR = 100 3793 C EVAL @TMPVR = 3 3794 C* 3795 C WHEN @TMPVR = 10 3796 C EVAL @TMPVR = 2 3797 C* 3798 C OTHER 3799 C EVAL @TMPVR = 1 3800 C ENDSL 3801 C* 3802 C EVAL @NXTFL = @NXTFL - @TMPVR 3803 C ENDDO 3804 C* 3805 C ENDCONV ENDSR 3806 *--------------------------------------------------------------------* 3807 * INITIAL ROUTINE * 3808 *--------------------------------------------------------------------* 3809 C SUBINIT BEGSR 3810 C* 3811 C EVAL #USERID = @USRID 3812 C EVAL #PGMNAM = @PGMNM 3813 C EVAL #SEP01 = *ALL'-' 3814 C EVAL #SEP02 = *ALL'-' 3815 C* 3816 C ENDINIT ENDSR 3817 *--------------------------------------------------------------------* 3818 * TERMINATION ROUTINE * 3819 *--------------------------------------------------------------------* 3820 C SUBTERM BEGSR 3821 C* 3822 C EVAL *INLR = *ON 3823 C* 3824 C ENDTERM ENDSR 3825 ********************************************************************** 3826 ** P@OSN CTDATA 3827 001 AND DECIMAL 3828 010 AND DECIMAL 3829 001 ONE 5001 010 TEN 5002 001 HUNDRED 5003 001 THOUSAND 5004 010 THOUSAND 5005 001 LAC 5006 001 MILLION 5007 001 CRORE 5008 010 CRORE 5009 001 BILLION 5010 010 BILLION 5011 100 BILLION 5012 001 TRILLION 5013 010 TRILLION 5201 ** G@RP1 CTDATA 5300 ONE 5400 TWO 5500 THREE 5600 FOUR 5700 FIVE 5800 SIX 5900 SEVEN 6000 EIGHT 6100 NINE 6200 TEN 6300 ELEVEN 6400 TWELVE 6500 THIRTEEN 6600 FOURTEEN 6700 FIFTEEN 6800 SIXTEEN 6900 SEVENTEEN 7000 EIGHTEEN 7100 NINETEEN 7200 TWENTY 7300 ** G@RP2 CTDATA 7400 TWENTY THIRTY FOURTY FIFTY SIXTY SEVENTYEIGHTY NINETY 7500 ** C@ATG CTDATA 7600 001010100 7601 ** F@NAM CTDATA 7602 @DECML 7603 @DECML 7700 @LSTTO 7800 @LSTTO 7900 @HUNDR 8000 @THSND 8100 @THSND 8200 @LACS 8300 @MILLN 8400 @CRORE 8500 @CRORE 8600 @BILLN 8700 @BILLN 8800 @BILLN 8900 @TRILN 9000 @TRILN * * * * E N D O F S O U R C E * * * *
This is Jamie from Code400.com
ReplyDeleteWhy are you listing my site content here on your page?
thanks
Jamie
You stole SEULNCMDS from Jeff Olen (https://www.mcpressonline.com/programming/rpg/techtip-userdefined-seu-line-commands)
ReplyDelete