Monday 17 October 2011

RPGLE/RPG EXAMPLES


    RPGLE  - Example chaining to logical file to write/update data
Posted By: JimmyOctane   Contact

C*===============================================
     C* Chaining to a logical file, if record found
     C* then update quantities else write record.
     C*===============================================
     C     TheKey02      Klist
     C                   Kfld                    PGPGRP
     C                   Kfld                    PGPCA1
     C                   Kfld                    PGPCA2
     C                   Kfld                    PGPRDCS2
     C*
     C* Chain to file with keylist if found add to existing values
     C* else Z-ADD (Zero out and add)
     C*
     C     TheKey02      Chain     AVAILABLEW
     C*
     C* This snippet of code is getting total quantity on hand/pick
     C*
     C                   If        %Found(AVAILABLEW)
     C                   Eval      ONHAND = ONHAND + LPLOQT
     C                   Eval      ONPICK = ONPICK + LPPIQT
     C                             + MOMQTY
     C                   Update    AVAILR
     C                   Else
     C                   Movel(p)  PGPRDCS2      PRODUCT
     C                   Movel(p)  PGPGRP        PGROUP
     C                   Movel(p)  PGPCA1        CAT1
     C                   Movel(p)  PGPCA2        CAT2
     C                   Movel(p)  PGDESC        DESC
     C                   Z-add     LPLOQT        ONHAND
     C                   Z-add     LPPIQT        ONPICK
     C                   Write     AVAILR
     C                   Endif
     C*===============================================

    RPGLE  - Example loading subfile one page at a time
Posted By: JimmyOctane   Contact

C*===============================================
     C*  $LoadSFL - Load the Main Menu.
     C*  load all errors so can total
     C*===============================================
     CSR   $LoadSFL      Begsr
     C*
     C                   If        SavRrn > *Zeros
     C                   Z-add     SavRrn        RRN1
     C                   Z-add     SavRrn        SCRRN
     C                   Endif
     C*
     C* Subfile page is set to 12. show 12 records to user at a time
     C* This load function sequences the data by customer #  or Name
     C* Depending on what the value of ReadBy is.
     C*  
     C                   Do        12
     C                   Select
     C                   When      ReadBy = 'C'
     C                   Read      C40NAM1                                89
     C                   When      ReadBy = 'N'
     C                   Read      C40NAM2                                89
     C                   Endsl
     C*
     C                   If        Not*In89
     C                   Movel(p)  C4NUM         S1CUSTOMER
     C                   Movel(p)  C4NAME        S1CNAME
     C                   Add       1.            RRN1
     C                   Add       1.            SCRRN
     C                   Write     SUB01
     C                   Endif
     C*
     C                   Enddo
     C*
     C                   Z-add     SCRRN         SavRrn
     C*
     C*  If no records in subfile then do not disply the subfile.
     C*
     C                   If        SavRrn = *Zeros  And   *In89
     C                   Eval      *In50 = *Off
     C                   Endif
     C
     C*
     C                   Endsr
     C*===============================================

    RPGLE  - Example position file to product read equal to total sales dollars
Posted By: JimmyOctane   Contact

C*===============================================     
     C* This code reads the file C40ISD by product
     C* and Totals Dollars and Qty Sold.
     C*===============================================
     C                   Clear                   Sales
     C                   Clear                   Count
     C*
     C     PRDC          Setll      C40ISD
     C     PRDC          Reade      C40ISD 
     C                   Dow        Not%Eof(C40ISD)
     C*
     C* The "+" preforms the same function as ADD. 
     C*
     C                   Eval       Sales = (Sales + C4DOL$)
     C                   Eval       Count = (Count + C4QTY)
     C*
     C     PRDC          Reade     C40ISD
     C                   Enddo
     C*===============================================


    RPGLE  - Program writes to source physical file then uses CPYTOSTMF
Posted By: Reynoo Moore   Contact

F*
     FZZPOOUTD  CF   E             WORKSTN
     F*
     FSOURCE    O    E             DISK    Rename(SOURCE:FMT1) Prefix(X)
     F                                     UsrOpn
     FSRBPOH    IF   E           K DISK
     FSRBPOL    IF   E           K DISK
     FSRBPRG    IF   E           K DISK
     FXABMAIL   IF   E           K DISK
     F*
     D*=======================================================
     D*   Commands for QCMDEXC
     D*=======================================================
     D*
     D* CLRPFM FILE(QGPL/SOURCE) MBR(XXXX)
     D*
     D CLRPFM          DS
     D Text1                   1     25    Inz('CLRPFM FILE(QGPL/SOURCE) ')
     D Text2                  26     31    Inz('  MBR(')
     D Member1                32     42
     D*
     D* CRTSRCPF FILE(QGPL/SOURCE) RCDLEN(112) MBR(XXXX)
     D*
     D CRTSRCPF        DS
     D Text2A                  1     27    Inz('CRTSRCPF FILE(QGPL/SOURCE)')
     D Text2B                 28     44    Inz(' RCDLEN(112) MBR(')
     D Member2                45     55
     D*
     D* ADDPFM FILE(QGPL/SOURCE) MBR(JAMIEF)
     D*
     D ADDPFM          DS
     D Text2C                  1     29    Inz('ADDPFM FILE(QGPL/SOURCE) MBR(')
     D Member3                30     41
     D*
     D* OVRDBF FILE(MODELS) TOFILE(QGPL/SOURCE) MBR(XXXX)
     D*
     D OVRDBF          DS
     D Text3                   1     27    Inz('OVRDBF FILE(SOURCE) TOFILE')
     D Text4                  27     44    Inz('(QGPL/SOURCE) MBR(')
     D Member4                45     55
     D*
     D* CPYTOSTMF FROMMBR('/QSYS.LIB/QGPL.LIB/SOURCE.FILE/OUTP.MBR')
     D*           TOSTMF('/RJAPO/%%%%%%%%%%/#########.###')
     D*          STMFOPT(*REPLACE)
     D*
     D CPYTOSTMF       DS
     D Text5                   1     25    Inz('CPYTOSTMF FROMMBR(''/QSYS')
     D Text6                  25     44    Inz('.LIB/QGPL.LIB/SOURCE')
     D Text7                  45     50    Inz('.FILE/')
     D Member5                51     70
     D Text8                  71     79    Inz(' TOSTMF(''')
     D TheRest                80    256
     D*
     D* del 'RJAPO/&USER/#######.###'
     D*
     D DEL             DS
     D Text13                  1     11    Inz('Del ''RJAPO/')
     D TheRest2               12    256
     D*
     D*
     D MD              DS
     D Text14                  1     11    Inz('md ''RJAPO/')
     D Directory              11     40
     D*
     D ADDLIBLE        DS
     D Text15                  1     22    Inz('addlible busintl *Last')
     D*
     D ISODate         S               D
     D InPO            S              7
     D DecPO           S              7  0
     D*
     D Str             S              3  0
     D End             S              4  0
     D Len             S              4  0
     D Count           S              4  0
     D Loop            S              4  0
     D #Fnd            S              4  0
     D InCode          S             10
     D @Scrn1          S             01    Inz('Y')
     D CURRENTMO       S              2  0
     D X               S              2  0
     D Dec12           S             12  0
     D Chr12           S             12
     D OutDsm          S             03    Inz('HAN')
     D OutAddress      S             40
     D OutLoc          S             50
     D Name            S             09
     D Chr1            S             01
     D ScreenError     S              1
     D MONTH           S              2
     D CURRENTYR       S              4  0
     D YEAR            S              4
     D PYear1          S              4
     D PYear2          S              4
     D PYear3          S              4
     D FlagNo          S              1    Inz('N')
     D CmdString       S            256
     D CmdLength       S             15  5
     D*
     D* Program Info
     D*
     D                SDS
     D  @PGM                 001    010
     D  @PARMS               037    039  0
     D  @JOB                 244    253
     D  @USER                254    263
     D  @JOB#                264    269  0
     C*============================================================
     C*                   M A I N   L I N E
     C*============================================================
     C*
     C     @User         Chain     XABMAIL
     C                   If        %Found(XABMAIL)
     C                   Eval      W1EMAIL = %Trim(W1EMAIL) +
     C                             %trim(XAEADR)   +
     C                             %trim('@Code400.com')
     C                   Else
     C                   Eval      W1EMAIL = 'SomeOne@Code400.com'
     C                   Endif
     C*
     C                   Reset                   @Scrn1
     C*
     C                   Dow       @Scrn1 = 'Y'
     C                   Exfmt     WIN1
     C                   Select
     C                   When      *In03 Or *In12
     C                   Clear                   @Scrn1
     C                   Other
     C*
     C                   Exsr      $Valid
     C                   If        ScreenError = *Blanks
     C                   Exsr      $ReadIt
     C                   Exsr      $Email
     C                   Eval      W1MSG = 'File sent to Folder & Emailed'
     C                   Clear                   W1PO
     C                   Endif
     C*
     C                   Endsl
     C                   Enddo
     C                   Eval      *INLR = *On
     C*=============================================================
     C*  $ReadIt - Read the PO data
     C*=============================================================
     CSR   $ReadIt       Begsr
     C*
     C                   Exsr      $Open
     C*
     C                   Move      W1PO          DecPO
     C     PoKey01       Chain     SRBPOH
     C                   If        %Found(SRBPOH)
     C     PoKey01       Setll     SRBPOL
     C     PoKey01       Reade     SRBPOL
     C                   Dow       Not%Eof(SRBPOL)
     C*
     C                   If        OLSTAT <> 'D'
     C*
     C                   Z-add     OLOQTY        Dec12
     C                   Move      Dec12         Chr12
     C*
     C                   Do        12            X
     C                   Eval      Chr1 = %Subst(Chr12:X:1)
     C                   If        Chr1 <> '0'
     C                   Leave
     C                   Endif
     C                   Enddo
     C*
     C     OLPRDC        Chain     SRBPRG
     C                   If        %Found(SRBPRG)
     C*
     C                   Eval      XSRCDTA = %Trim(XSRCDTA) +
     C                             %Trim('"') + %Trim(PGPRDCS2) +
     C                             %Trim('",')
     C                             + %Trim(%Subst(Chr12:X))
     C*
     C                   Write     FMT1
     C                   Clear                   XSRCDTA
     C*
     C                   Endif
     C                   Endif
     C*
     C     PoKey01       Reade     SRBPOL
     C                   Enddo
     C                   Endif
     C*
     C                   EXSR      $StreamIt
     C                   Endsr
     C*
     C*=============================================================
     C*  $Open - reset the overides for each DSM to build
     C*=============================================================
     CSR   $Open         Begsr
     C*
     C* Setup member name(s)
     C*
     C                   Eval      Member1 = %Trim(NAME) + %Trim(')')
     C                   Eval      Member2 = %Trim(NAME) + %Trim(')')
     C                   Eval      Member3 = %Trim(NAME) + %Trim(')')
     C                   Eval      Member4 = %Trim(NAME) + %Trim(')')
     C                   Eval      Member5 = %Trim(NAME) + %Trim('.MBR/'')' )
     C*
     C                   If        %Open(SOURCE)
     C                   Close     SOURCE
     C                   Endif
     C*
     C*
     C* Clear the source file and do data base override
     C*
     C                   Movel(p)  CRTSRCPF      CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C* Add member that is the name
     C*
     C                   Movel(p)  ADDPFM        CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   Movel(p)  CLRPFM        CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   Movel(p)  OVRDBF        CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   If        Not%Open(SOURCE)
     C                   Open      SOURCE
     C                   Endif
     C*
     C* Create the IFS folder by user profile
     C*
     C                   Eval      Directory = %Trim(name) +
     C                             %Trim('''')
     C                   Movel(p)  MD            CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   Endsr
     C*
     C*=============================================================
     C*  $StreamIt - Streamfile the data.
     C*=============================================================
     C     $StreamIt     Begsr
     C*
     C                   If        %Open(SOURCE)
     C                   Close     SOURCE
     C                   Endif
     C*
     C*
     C* Delete old one by same PO Number
     C*
     C                   Eval      TheRest2 = %Trim(NAME)
     C                             +%Trim('/') + %Trim('PO') +
     C                             %Trim(W1PO) + %Trim('.csv')
     C                             + %Trim('''')
     C*
     C                   Movel(p)  DEL           CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C* Build the stream file command  'RJAPO/&USER/#######.###'
     C*
     C*
     C                   Eval      TheRest = %Trim('RJAPO/') +
     C                                       %Trim(NAME)    +
     C                                       %Trim('/')      +
     C                                       %Trim('PO') + %Trim(W1PO) +
     C                                       %Trim('.csv') + %Trim(''')')
     C                                       + ' STMFOPT(*REPLACE)'
     C                                       + ' STMFCODPAG(*PCASCII)'
     C*
     C                   Eval      OutLoc =
     C                                       %Trim('RJAPO/') +
     C                                       %Trim(NAME)    +
     C                                       %Trim('/')      +
     C                                       %Trim('PO') + %Trim(W1PO) +
     C                                       %Trim('.csv')
     C*
     C                   Movel(p)  CPYTOSTMF     CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C*
     C                   Endsr
     C*=============================================================
     C*  $Valid  - Check screen entries
     C*=============================================================
     CSR   $Valid        Begsr
     C*
     C                   Clear                   ScreenError
     C                   Clear                   W1MSG
     C*
     C                   If        W1PO = *Blanks Or W1PO = '0000000'
     C                   Eval      W1MSG = 'Invalid PO Entered.'
     C                   Eval      ScreenError = 'Y'
     C                   Else
     C                   Move      W1PO          DecPO
     C     PoKey01       Chain     SRBPOH
     C                   If        Not%Found(SRBPOH)
     C                   Eval      W1MSG = 'Invalid PO Entered.'
     C                   Eval      ScreenError = 'Y'
     C                   Endif
     C                   Endif
     C*
     C                   Eval      Name = %Trim('PO') + %Trim(W1PO)
     C*
     C                   Endsr
     C*
     C*=============================================================
     C*  $Email - Email this to someone
     C*=============================================================
     CSR   $Email        Begsr
     C*
     C                   Call      'BICTL02C'
     C                   Parm                    OutDsm
     C                   Parm      W1Email       OutAddress
     C                   Parm                    OutLoc
     C*
     C                   Endsr
     C*=============================================================
     C*  *Inzsr - Initial one time run subroutine.
     C*=============================================================
     C     *Inzsr        Begsr
     C*
     C*
     C* Klist(s)
     C*
     C     PoKey01       Klist
     C                   Kfld                    FlagNo
     C                   Kfld                    DecPO
     C*
     C     *MDY          Move      UDATE         ISODate
     C*
     C                   Movel(p)  ADDLIBLE      CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   Endsr
     C*=============================================================

    RPGLE  - Translate Lower case to Upper case
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     H DftActGrp(*No) Option(*SrcStmt : *NoDebugIO)
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      * Program Name:
      * Description :
      * Date Written:
      * Modification:
      * ~~~~~~~~~~~~
      *
      *
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     FINBOX     if   e           k disk    prefix(x)
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      * Program Information
      * ~~~~~~~~~~~~~~~~~~~
     D @PgmInfo       sds
     D  @PgmNam                1     10
     D  @Parms                37     39  0
     D  @MsgId                40     46
     D  @MsgDta               91    170
     D  @JobNam              244    253
     D  @UserId              254    263
     D  @JobNum              264    269  0
      *
      * Constants
      * ~~~~~~~~~
     D UpperCase       C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
     D LowerCase       C                   'abcdefghijklmnopqrstuvwxyz'
      *
      * Define Variables
      * ~~~~~~~~~~~~~~~~
     D XMLField        s           1000    inz(*blanks)
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *     M  A  I  N     L  I  N  E
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
     C                   eval      *inlr = *on
     C                   return
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C     *inzsr        begsr
      *
     C                   read      INBOX
     C                   dow       not %eof(INBOX)
      *
     C                   eval      XMLField = %xlate(LowerCase : UpperCase :
     C                                               %trim(xSRCDTA))
      *
     C                   read      INBOX
     C                   enddo
      *
     C                   endsr

    RPGLE  - CPYTOSTMF example reading XML file
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      * Program Name:
      * Description :
      * Written On  :
      *
      * Modification
      * ~~~~~~~~~~~~
      * Date        Mark   Int  Description
      * ~~~~~~~~    ~~~~   ~~~  ~~~~~~~~~~~
      *
      *
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     H Option(*SrcStmt: *NoDebugIO)  DftActGrp(*No)
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      * XML Source File
      * ~~~~~~~~~~~~~~~
     FBIGSOURCE if   e           k disk    rename(BIGSOURCE : format1)
     F                                     prefix(x)
      *
      *
      * XML Source File
      * ~~~~~~~~~~~~~~~
     FOUTSOURCE uf a e           k disk    rename(OUTSOURCE : format2)
     F                                     prefix(q)
     F                                     usropn
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      * Constants
      * ~~~~~~~~~
     D Up              C                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
     D Low             C                   const('abcdefghijklmnopqrstuvwxyz')
      *
      * Program Info
      * ~~~~~~~~~~~~
     D PgmInfo        SDS
     D  @PgmName               1     10
     D  @Parms                37     39  0
     D  @MsgID                40     46
     D  @JobName             244    253
     D  @UserId              254    263
     D  @JobNbr              264    269  0
      *
      *  Field Definitions.
      *  ~~~~~~~~~~~~~~~~~~
     D Next            S              4  0 inz(0)
     D Chr4            S              4
     D*
     D pos             S              5  0 inz(0)
     D OutFile         S             50
     D infile          S             50
      *
     D WorkData        s          30000    inz(*blanks)
     D TheHeader       s          30000    inz(*blanks)
     D Line#           S              3  0 inz(0)
     D WriteHeader     S             01    inz('Y')
     D pos2            S              5  0 inz(0)
     D pos3            S              5  0 inz(0)
      *
     D Cmdstring       s          40000    inz(*blanks)
     D CmdLength       s             15  5 inz(0)
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *  M A I N     L I N E
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      * Read the source file to populate WorkData
      *
      *
     C*
     C                   Reset                   WriteHeader
     C*
     C     *start        setll     BIGSOURCE
     C                   read      BIGSOURCE
     C                   dow       not %eof(BIGSOURCE)
     C*
     C                   eval      WorkData = %Trim(WorkData) + %trim(xSRCDTA)
     C*
     C*  The header is complete dont write anymore
     C*
     C                   eval      pos2 = %scan('' : xSRCDTA)
     C                   if        pos2 > 0
     C                   Eval      WriteHeader = 'N'
     C                   Endif
     C*
     C                   If        WriteHeader = 'Y'
     C                   eval      TheHeader = %Trim(TheHeader)+ %trim(xSRCDTA)
     C                   Endif
     C*
     C                   eval      pos3 = %scan('' : xSRCDTA)
     C                   if        pos3 > 0
     C                   Eval      Line# = (Line# + 1)
     C                   Endif
     C*
     C                   eval      pos = %scan('' : xSRCDTA)
     C                   if        pos > 0
     C                             Or Line# = 90.
     C*
     C                   exsr      $writeIFS
     C*
     C                   If        Line# = 90.
     C                   Exsr      $Continue
     C                   Endif
     C*
     C                   Clear                   Line#
     C*
     C                   endif
     C*
     C                   read      BIGSOURCE
     C                   enddo
     C
     C                   eval      *inlr = *on
     C                   return
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C     $WriteIFS     begsr
     C*
     C                   Eval      Next = (Next + 1)
     C                   Movel(p)  Next          Chr4
     C     '.'           Scan      InFile        Pos
     C                   Eval      OutFile = %Trim(%Subst(Infile:1:Pos-1))
     C                             + %Trim('-')
     C                             + %Trim(Chr4) + %Trim('.xml')
     C*
     C                   if        %open(OUTSOURCE)
     C                   close     OUTSOURCE
     C                   endif
      *
     C                   eval      CmdString = %trim('OVRDBF FILE(OUTSOURCE)') +
     C                             %trim('TOFILE(QTEMP/OUTSOURCE)')
     C                   eval      CmdLength = 256.
     C                   call      'QCMDEXC'                            99
     C                   parm                    CmdString
     C                   parm                    CmdLength
      *
     C                   eval      CmdString = 'CLRPFM OUTSOURCE'
     C                   eval      CmdLength = 256.
     C                   call      'QCMDEXC'                            99
     C                   parm                    CmdString
     C                   parm                    CmdLength
      *
     C                   if        not %open(OUTSOURCE)
     C                   open      OUTSOURCE
     C                   endif
      *
     C                   eval      qSRCDTA  = WorkData
     C                   write     format2
      *
     C                   if        %open(OUTSOURCE)
     C                   close     OUTSOURCE
     C                   endif
     C*
     C* Copy to stream file
     C* CPYTOSTMF FROMMBR('qsys.lib/qgpl.lib/outsource.file/outdata.mbr')
     C* TOSTMF('dsmorders/test.xml-01') STMFOPT(*REPLACE)
     C*
     C*
     C                   Eval      CmdString = 'CPYTOSTMF FROMMBR(''qsys.'
     C                             + %Trim('lib/qgpl.lib/outsource.file')
     C                             + %Trim('/outdata.mbr''')
     C                             + %Trim(') TOSTMF(''')
     C                             + %Trim('dsmorders/')
     C                             + %Trim(Outfile)
     C                             + %Trim(''') STMFOPT(*REPLACE)')
     C                             + %Trim('@@STMFCODPAG(*PCASCII)')
     C*
     C     '@':' '       Xlate     CmdString     CmdString
     C*
     C                   eval      CmdLength = 256.
     C*
     C                   call      'QCMDEXC'                            99
     C                   parm                    CmdString
     C                   parm                    CmdLength
     C*
     C*
     C*   QSYS/CHGAUT OBJ('dsmorders/*') USER(*PUBLIC) +
     C*                DTAAUT(*RWX) OBJAUT(*ALL)
     C*
     C                   Eval      CmdString = %Trim('CHGAUT OBJ(''dsmorde')
     C                             + %Trim('rs/*'' USER(*PUBLIC) DTAAUT')
     C                             + %Trim('(*RWX) OBJAUT(*ALL)')
     C                   Eval      CmdLength = 256.
     C*
     C                   call      'QCMDEXC'                            99
     C                   parm                    CmdString
     C                   parm                    CmdLength
     C*
     C                   Clear                   WorkData
     C*
     C                   endsr
     C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C*  $Continue - Set up program to send the rest of the file.
     C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C     $Continue     begsr
     C*
      *
     C                   if        not %open(OUTSOURCE)
     C                   open      OUTSOURCE
     C                   endif
     C*
     C                   Movel(p)  TheHeader     WorkData
     C*
     C                   endsr
     C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C* *inzsr - Initial one time run subroutine
     C*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C     *inzsr        begsr
      *
     C     *entry        plist
     C                   parm                    infile
      *
     C                   endsr
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

    RPGLE  - Six decimal date *MDY converted to *ISO
Posted By: Reynoo Moore   Contact

C*
     C* must cerify that this is a correct date
     C*
     C                   Move      ShipDateTxt   Dec6
     C     *MDY          Test(de)                Dec6
     C                   If        %Error
     C                   Eval      ShipDate = %Date()
     C                   Else
     C     *MDY          Move      Dec6          ShipDate
     C                   Endif
     C*

    RPGLE  - %Scan and replace example
Posted By: Reynoo Moore   Contact

*
      * Free of Charge
      *
     C                   eval      str = %scan('FOC="' : items(z))
     C                   if        str > 0
     C                   eval      str = str + 5
     C     '"'           scan      items(z):str  end
     C                   eval      len = (end - str)
     C                   eval      OLFOCC = %subst(items(z) : str : len)
     C                   endif

    RPGLE  - Delete with RPG
Posted By: Reynoo Moore   Contact

C*
     C* if line number is zero then must delete the header
     C*
     C                   If        LineNumber = *zeros
     C     DsmOrdL1Key   Chain     DSMHORDL1
     C                   If        %Found(DSMHORDL1)
     C                   Delete    OrdHdrR
     C                   Endif
     C                   Endif
     C*

    RPGLE  - Use api to get spooled file information
Posted By: Reynoo Moore   Contact

FMONITORP  UF   E           K DISK
     FDAILYP    iF   E           K DISK
     F*
     F* Source file to write new daily reports HTM to
     F*
     FDAILY     O    E             DISK    UsrOPn Prefix(X) Rename(DAILY:DLY)
     F*
      * PROGRAM STATUS DATA
     D                SDS
     D  PGMID                  1     10
     D  USERID               254    263
      * DATA QUEUE LAYOUT
     D QDATA           DS           128    INZ
     D  RCDID                  1     10
     D*                                      11  12 ??
     D  JOBID                 13     38
     D  JOBNM                 13     22
     D  JOBUSER               23     32
     D  JOBNBR                33     38
     D  SPLF                  39     48
     D  BSPLF#                49     52B 0
     D  OUTQ                  53     62
     D  OTQLIB                63     72
     D*                                      73 128 ??
     D* QUSRSPLA - LIST SPOOL FILE ATRIBUTES API
     D*                                      73 128 ??
     D RCVVAR          DS                  INZ
     D  BYTRTN                 1      4B 0
     D  BYTVAL                 5      8B 0
     D  SPLFID                25     40
     D  JOBNAM                41     50
     D  USRNAM                51     60
     D  JOBNUM                61     66
     D  FILNAM                67     76
     D  FILNUM                77     80B 0
     D  FRMTYP                81     90
     D  USRDTA                91    100
      * DEFINE BINANRY NUMBERS
     D                 DS
     D  RCVLEN                 1      4B 0
      * DEFINE CONSTANTS

     D ISODate         S               D
     D TodayISO        S               D
     D Available       S              1
     D DEC155          S             15  5
     D Dec8            S             08  0
     D Chr8            S             08
     D Chr4            S             04
     D Chr2            S             02
     D Chr8_2          S             08
     D Out8            S             08
     D C1DAY           S             09
     D Str             S             02  0
     D Year            S             04  0
     D ChrYear         S             04
     D Month           S             02  0
     D Day             S             02  0
     D ChrDay          S             02
     D Len             S             05  0
     D Next            S             05  0
     D Today           S             50
     D WorkField       S              5  0
     D MName           S            256
     D CmdString       S            256
     D CmdLength       S             15  5
     D DayOfWeek       S             07  0
     D*
     D* Days
     D*
     D DNames          S             63    Inz('Sunday   Monday   Tuesday  Wedn+
     D                                     esdayThursday Friday   Saturday ')
     D*
     D* Months
     D*
     D MNames          S            108    Inz('January  FebruraryMarch    Apri+
     D                                     l    May      June     July     +
     D                                     August   SeptemberOctober  Nove+
     D                                     mber December ')
     D*=====================================================================
     D*   Commands for QCMDEXC
     D*=====================================================================
     D*
     D* CLRPFM FILE(CGI_BIN/DAILY) MBR(DAILY)
     D*
     D CLRPFM          DS
     D Text1                   1     25    Inz('CLRPFM FILE(CGI_BIN/DAILY')
     D Text2                  26     37    Inz(') MBR(DAILY)')
     D*
     D* OVRDBF FILE(DAILY) TOFILE(CGI_BIN/DAILY) MBR(DAILY)
     D*
     D OVRDBF          DS
     D Text3                   1     27    Inz('OVRDBF FILE(DAILY)  TOFILE')
     D Text4                  27     53    Inz('(CGI_BIN/DAILY) MBR(DAILY)')
     D*
     D* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
     D*           TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
     D*          STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
     D*
     D*
     D**************************************************************
      *  MAIN LINE - RTV DATA QUEUE
     D**************************************************************
     C*
     C                   Exsr      $Daily
     C*
     C                   MOVE      *ON           *INLR
     C**************************************************************
      * SUBROUTINES:

     C**************************************************************
      * RETRIVE SPOOL FILE ATTRIBUTES

     C**************************************************************
     C     $RTVA         BEGSR
      *  CALL SYSTEM API
     C                   CALL      'QUSRSPLA'                           99
     C                   PARM                    RCVVAR
     C                   PARM      100           RCVLEN
     C                   PARM      'SPLA0100'    FMTNM             8
     C                   PARM                    JOBID            26
     C                   PARM      *BLANK        INTJOB           16
     C                   PARM      *BLANK        INTSPL           16
     C                   PARM                    SPLF
     C                   PARM                    BSPLF#
     C*
     C                   Select
     C                   When      JOB = 'QPRT160'
     C     WebKey2       Chain     MONITORP
     C                   Other
     C     WebKey1       Chain     MONITORP
     C                   Endsl
     C*
     C                   If        %Found(MONITORP)
     C*
     C                   Move      TodayISO      UsedDate
     C*
     C* last spooled info
     C*
     C                   Movel(p)  FILNAM        SFILE
     C                   Movel(p)  JOBNAM        SJOB
     C                   Movel(p)  USRNAM        SUSER
     C                   Movel(p)  JOBNUM        SNUMBER
     C                   Move      FILNUM        SSNUMBER
     C*
     C                   Do        5             Str
     C                   If        %Subst(SSNUMBER:Str:1) <> '0'
     C                   Leave
     C                   Else
     C                   Eval      %Subst(SSNUMBER:Str:1) = *Blanks
     C                   Endif
     C                   Enddo
     C*
     C                   Eval      SSNUMBER = %Trim(SSNUMBER)
     C*
     C                   Movel(p)  USRDTA        SUSERDATA
     C*
     C                   Update    MONR
     C*
     C     *MDY          Move      UDATE         ISODate
     C                   Move      ISODate       Dec8
     C                   Move      Dec8          Chr8_2
     C                   Subdur    1:*days       ISODate
     C                   Move      ISODate       Dec8
     C                   Move      Dec8          Chr8
     C                   Move      Chr8          Out8
     C*
     C                   Z-add     BSPLF#        Dec155
     C*
     C                   Eval      USRDTA = %Trim(USRDTA)
     C                   Call      'MONITORC2'                          99
     C                   Parm                    SPLF
     C                   Parm                    JOBNM
     C                   Parm                    JOBUSER
     C                   Parm                    JOBNBR
     C                   Parm                    DEC155
     C                   Parm                    WEBPAGE
     C                   Parm                    FOLDER
     C                   Parm                    Chr8
     C                   Parm                    HTML
     C                   Parm                    PDF
     C                   Parm                    EMAIL
     C                   Parm                    EADDRESS
     C                   Parm                    ESUBJECT
     C                   Parm                    ENOTE1
     C                   Parm                    Chr8_2
     C*
     C                   Endif
     C*
     C                   ENDSR
     C*==================================================================
     C* $Daily - Daily Reports
     C*==================================================================
     CSR   $Daily        Begsr
     C*
     C* Redundant date functions so that I can test
     C*
     C     *MDY          Move      UDATE         ISODate
     C                   Move      ISODate       Dec8
     C                   Move      Dec8          Chr8_2
     C                   Subdur    1:*days       ISODate
     C                   Move      ISODate       Dec8
     C                   Move      Dec8          Chr8
     C                   Move      Chr8          Out8
     C*
     C* Create string for today
     C*
     C*
     C                   Eval      Year  = %Subdt(ISODate:*Y)
     C                   Move      Year          ChrYear
     C                   Eval      Month = %Subdt(ISODate:*M)
     C                   Eval      Day   = %Subdt(ISODate:*D)
     C                   Move      Day           ChrDay
     C                   Exsr      $Day
     C                   Eval      Month = Month -1
     C                   Eval      MName = %Trim(%Subst(MNames:(Month*9):9))
     C                   Clear                   Today
     C                   Eval      Today  = %Trim(C1DAY) + '%The%'
     C                             + %Trim(ChrDay) + %Trim('%Of%')
     C                             + %Trim(MName) + %Trim('%The Year Of%')
     C                             + %Trim(ChrYear)
     C*
     C     '%':' '       Xlate     Today         Today
     C*
     C     *Start        Setll     DAILYP
     C                   Read      DAILYP
     C                   Dow       Not%Eof(DAILYP)
     C*
     C     '@@DATE'      Scan      DFIELD        Str
     C                   If        %Found
     C                   Eval      %Subst(DFIELD:Str:50) = Today
     C                   Endif
     C*
     C     '$$$$$$$$'    Scan      DFIELD        Str
     C                   If        %Found
     C                   Eval      %Subst(DFIELD:Str:08) = Chr8
     C                   Endif
     C*
     C     '%%%%%%%%'    Scan      DFIELD        Next
     C                   If        %Found
     C                             And Next > *Zeros
     C                   Eval      %Subst(DFIELD:Next:08) = Chr8
     C                   Endif
     C*
     C*
     C                   Movel(p)  DFIELD        XSRCDTA
     C*
     C*
     C                   Write     DLY
     C*
     C                   Read      DAILYP
     C                   Enddo
     C*
     C* Close the source member and then send it somewhere
     C*
     C                   If        %Open(DAILY)
     C                   Close     DAILY
     C                   Endif
     C*
     C*
     C* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
     C*           TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
     C*          STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
     C*
     C                   Eval      CmdString =%Trim('CPYTOSTMF FROMMBR(')  +
     C                                          %Trim('''')                +
     C                                          %Trim('/QSYS.LIB/CGI_BIN') +
     C                                          %Trim('.LIB/DAILY.FILE/D') +
     C                                          %Trim('AILY.MBR')          +
     C                                          %Trim('''')                +
     C                                          %Trim(') TOSTMF(')         +
     C                                          %Trim('''')                +
     C                                          %Trim('/WEB/REPORTS/')     +
     C                                          %Trim(Chr8)                +
     C                                          %Trim('/DailyReports.htm') +
     C                                          %Trim('''')                +
     C                                          %Trim(')')                 +
     C                                          %Trim('!STMFCODPAG(*PCAS') +
     C                                          %Trim('CII)')              +
     C                                          %Trim('!STMFOPT(*REPLACE)')
     C     '!':' '       Xlate     CmdString     CmdString
     C*
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            88
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C*
     C                   Endsr
     C*==================================================================
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
     C* $Day - What Day is Today.
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
     C     $Day          Begsr
     C*
     C*
     C     IsoDate       Subdur    D'1899-12-30' DayofWeek:*D
     C                   Div       7             DayOfWeek
     C                   Mvr                     DayOfWeek
     C*
     C                   If        DayOfWeek < 1.
     C                   Eval      DayOfWeek = DayOfWeek + 7.
     C                   Endif
     C*
     C                   Select
     C                   When      DayOfWeek = 1.
     C                   Movel(p)  'Sunday'      C1DAY
     C                   When      DayOfWeek = 2.
     C                   Movel(p)  'Monday'      C1DAY
     C                   When      DayOfWeek = 3.
     C                   Movel(p)  'Tuesday'     C1DAY
     C                   When      DayOfWeek = 4.
     C                   Movel(p)  'Wednesday'   C1DAY
     C                   When      DayOfWeek = 5.
     C                   Movel(p)  'Thursday'    C1DAY
     C                   When      DayOfWeek = 6.
     C                   Movel(p)  'Friday'      C1DAY
     C                   When      DayOfWeek = 7.
     C                   Movel(p)  'Saturday'    C1DAY
     C                   Endsl
     C*
     C*
     C                   Endsr
**************************************************************************
     C     *INZSR        BEGSR
      * ENTRY PARMS
      * RECEIVE DATA QUEUE PARMS
      * DEFINE VARIABLES
     C*
     C*  Klist
     C*
     C     WebKey1       Klist
     C                   Kfld                    JOBNM
     C                   Kfld                    SPLF
     C*
     C     WebKey2       Klist
     C                   Kfld                    JOBNM
     C                   Kfld                    SPLF
     C                   Kfld                    USRDTA
     C*
     C     *MDY          Move      UDATE         TodayISO
     C*
     C*Set up member to write to
     C*
     C*
     C* Build the DSM model(s)
     C*
     C                   Movel(p)  CLRPFM        CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            88
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   Movel(p)  OVRDBF        CmdString
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            88
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength
     C*
     C                   If        Not%Open(DAILY)
     C                   Open      DAILY
     C                   Endif
     C*
     C                   ENDSR


    RPGLE  - Function to center a field
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      * $GetComNam - Get Company Information
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     P$GetComNam       b
     D $GetComNam      pi            30a
     D   LenStr        s              3  0 inz(0)
     D   ComNum        s              3  0 inz(1)
     D   ComNam        s             30    inz(*blanks)
     D   TmpComNam     s             30    inz(*blanks)
      *
     C                   if        not %open(CCFILEL)
     C                   open      CCFILEL
     C                   endif
      *
     C                   eval      ComNum = 001.
     C     ComNum        Chain     CCFILEL
     C                   if        %found(CCFILEL)
     C                   eval      TmpComNam = %trim(CCCONM)
     C                   endif
      *
     C                   if        %open(CCFILEL)
     C                   close     CCFILEL
     C                   endif
      *
     C                   eval      LenStr = ((%len(TmpComNam) -
     C                             %len(%trim(TmpComNam))) / 2) + 1
     C                   eval      %subst(ComNam:LenStr) = %trim(TmpComNam)
      *
     C                   return    ComNam
      *
     P$GetComNam       e

    RPGLE  - Function to get day of the week
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      * $GetDoW - Get Day of Week
      *            1=Sun, 2=Mon, etc.
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     P$GetDoW          b
     D $GetDoW         pi             3a
     D  InpDate                        d   value
      *
     D DayOfWk         s             11p 0
     D AnySundayDate   s               d   datfmt(*iso)
     D                                     inz(d'1998-08-01')
     D WrkDate         s               d   datfmt(*iso)
     D DoWDesc         s              3    inz(*blanks)
      *
     C                   eval      WrkDate = InpDate
     C                   eval      DayOfWk = %diff(InpDate:AnySundayDate:*days)
     C                   div       7             DayOfWk
     C                   mvr                     DayOfWk
      *
     C                   if        DayOfWk <= 0
     C                   eval      DayOfWk = (DayOfWk + 7)
     C                   endif
      *
     C                   select
     C                   when      DayOfWk = 1
     C                   eval      DoWDesc = 'Sun'
     C                   when      DayOfWk = 2
     C                   eval      DoWDesc = 'Mon'
     C                   when      DayOfWk = 3
     C                   eval      DoWDesc = 'Tue'
     C                   when      DayOfWk = 4
     C                   eval      DoWDesc = 'Wed'
     C                   when      DayOfWk = 5
     C                   eval      DoWDesc = 'Thu'
     C                   when      DayOfWk = 6
     C                   eval      DoWDesc = 'Fri'
     C                   when      DayOfWk = 7
     C                   eval      DoWDesc = 'Sat'
     C                   endsl
      *
     C                   return    DoWDesc
      *
     P$GetDoW          E
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    RPGLE  - Clear messages subfile API
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      *    $ClrMsg - clear the messages from the screen
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C     $ClrMsg       begsr
      *
     C                   call      'QMHRMVPM'
     C                   parm                    PGMQ
     C                   parm                    STKCNT
     C                   parm                    MSGKY
     C                   parm                    MSGRMV
     C                   parm                    ERRCOD
      *
     C                   endsr

    RPGLE  - Write message subfile API
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      *    $SndMsg - Send a message to the message subfile
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C     $SndMsg       begsr
      *
     C                   call      'QMHSNDPM'
     C                   parm                    MSGID
     C                   parm                    MSGF
     C                   parm                    MSGDTA
     C                   parm                    DTALEN
     C                   parm                    MSGTYP
     C                   parm                    PGMQ
     C                   parm                    STKCNT
     C                   parm                    MSGKEY
     C                   parm                    ERRCOD
      *
     C                   endsr

    RPGLE  - Variables for message subfile
Posted By: Reynoo Moore   Contact

D                 DS                        inz
     D STKCNT                001    004B 0
     D DTALEN                005    008B 0
     D ERRCOD                009    012B 0
      *
      *
      * Program Info
      * ~~~~~~~~~~~~~
     D*               SDS
     D* @PGM                 001    010
     D* @Parms               037    039  0
     D* @JOB                 244    253
     D* @UserId              254    263
     D* @JOB#                264    269  0
     C                   eval      PgmQ = @PgmName
     C                   eval      DtaLen = 60
      *
      * Initialize the message subfile fields
      *
     C                   movel     'CODMSGF'     MSGF             20
     C                   movel     '*LIBL'       MSGLIB           10
     C                   move      MSGLIB        MSGF
     C                   move      *blanks       MSGKY            04
     C                   move      *blanks       MSGDTA           80
     C                   movel     '*DIAG'       MSGTYP           10
     C                   movel     '*ALL'        MSGRMV           10
     C                   movel     *blanks       MSGID            07
      *

    RPGLE  - Renaming record format with prefix fields
Posted By: Reynoo Moore   Contact

FC$USRBLDL1UF   E           K DISK    rename(C$USRR:ByModel) Prefix(Z)

    RPGLE  - Example of displaying a screen
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *    $DispSFL01   - Survey Type LookUp
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
     C     $DispSFL01    begsr
      *
     C                   exsr      $ClearSFL01
     C                   exsr      $LoadSFL01
     C                   exsr      $CLRMSG
      *
     C                   dow       @Scrn01 = 'Y'
      *
     C                   write     SUB01FKEY
     C                   write     MSGCTL                               99
     C                   exfmt     SUB01CTL
      *
     C                   if        CURREC <> *zeros
     C                   eval      RRn01   =  CURREC
     C                   eval      ScRRn01 =  CURREC
     C                   endif
      *
     C                   eval      SavScRRn01 = 1
     C                   if        ScRRn01 > 0
     C                   eval      SavScRRn01 = ScRRn01
     C                   endif
      *
     C                   exsr      $CLRMSG
      *
     C                   select
      *
      * F3 pressed end the program
      *
     C                   when      *in03 = *on
     C                   eval      @Scrn01 = 'N'
      *
      * F6=Add
      *
     C                   when      *in06 = *on
     C                   eval      ChangedRecord = 'Y'
     C                   eval      ScreenMode = 'ADD'
     C                   exsr      $Screen01
      *
      * F12=Return
      *
     C                   when      *in12 = *on
     C                   eval      @Scrn01 = 'N'
      *
      * other
      *
     C                   other
     C                   if        RRn01 > 0
     C                   exsr      $Process01
     C                   endif
      *
     C                   endsl
      *
     C                   if        ChangedRecord = 'Y' and ScreenError = 'N'
     C                   exsr      $ClearSFL01
     C                   exsr      $LoadSFL01
     C                   eval      ScreenError = 'N'
     C                   eval      ChangedRecord = 'N'
     C                   eval      ScRRn01 = SavScRRn01
     C                   endif
      *
     C                   enddo
      *
     C                   endsr
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    RPGLE  - Loading an entire subfile all at once
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      *  $LoadSFL01 - Load subfile display
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C     $LoadSFL01    begsr
      *
     C                   eval      S01CNAM = CompName
     C                   eval      S01CDAY = $GetDoW(%date())
      *
     C                   if        SavRRn01 > *zeros
     C                   eval      RRn01 = SavRRn01
     C                   eval      ScRRn01 = SavRRn01
     C                   endif
     C                   eval      ScRRn01 = (SavRRn01 + 1)
      *
      * Load the subfile fields
      *
     C     *start        setll     MONITORL2
     C                   read      MONITORL2                              89
     C                   dow       not %eof(MONITORL2)
      *
     C                   reset                   SUB01
     C                   eval      S01SPLF = SFILE
     C                   eval      S01UDTA = SUSERDATA
     C                   eval      S01HTML = HTML
     C                   eval      S01PDF  = PDF
     C                   eval      S01JNAM = SJOB
      *
     C                   eval      RRn01 = (RRn01 + 1)
     C                   write     SUB01
      *
     C                   read      MONITORL2                              89
     C                   enddo
      *
     C                   if        RRn01 = 0
     C                   eval      RRn01 = 1
     C                   eval      *in50 = *off
     C                   endif
     C                   if        RRn01 > 0 and *in89 = *on
     C                   eval      ScRRn01 = (SavRRn01 + 1)
     C                   endif
     C                   eval      SavRRn01 = RRn01
      *
     C                   endsr
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    RPGLE  - Clearing a subfile by writing subfile control
Posted By: Reynoo Moore   Contact

*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      *  $ClearSFL01 - Clear the subfile.
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C     $ClearSFL01   begsr
      *
     C                   eval      *in50 = *off
     C                   eval      *in51 = *off
     C                   eval      *in52 = *on
      *
     C                   write     SUB01CTL
      *
     C                   eval      *in50 = *on
     C                   eval      *in51 = *on
     C                   eval      *in52 = *off
      *
     C                   eval      RRn01 = 0
     C                   eval      ScRRn01 = 0
     C                   eval      SavRRn01 = 0
      *
     C                   endsr
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    RPGLE  - Simple if statment with error message subfile write
Posted By: Reynoo Moore   Contact

*
      * SPLF/Job Name/User Data must not be blanks
      *
     C                   if        C01SPLF = *blanks or C01JNAM = *blanks or
     C                             C01UDTA = *blanks
     C                   eval      MsgId = 'ROL0053'
     C                   eval      MsgDta = *blanks
     C                   exsr      $SndMsg
     C                   eval      *in40 = *on
     C                   eval      ScreenError01 = 'Y'
     C                   endif

    RPGLE  - Create user space
Posted By: Reynoo Moore   Contact

* Standard API error data structure
     d ErrorDs         DS                  INZ
     d  BytesProvd             1      4B 0 inz(116)
     d  BytesAvail             5      8B 0
     d  MessageId              9     15
     d  Err###                16     16
     d  Message               17    116
       * Name and location of the Output Queue
     d UserSpace       DS
     d  QSName                       10    Inz('SPOOL1')
     d  QSLibrary                    10    Inz('QTEMP')

       * Create the user space

     c                   CALL      'QUSCRTUS'
     c                   PARM                    UserSpace
     c                   PARM      *BLANKS       SpaceAttr        10
     c                   PARM      4096          SpaceLen
     c                   PARM      *BLANKS       SpaceVal          1
     c                   PARM      '*CHANGE'     SpaceAuth        10
     c                   PARM      *BLANKS       SpaceText        50
     c                   PARM      '*YES'        SpaceRepl        10
     c                   PARM                    ErrorDs

    RPGLE  - Identify Hex Codes for all function keys
Posted By: Reynoo Moore   Contact

.D*ame+++++++++++ETDsFrom+++To/L+++IDc.Keywords+++++++++++
     D F1              C                   CONST(X'31')
     D F2              C                   CONST(X'32')
     D F3              C                   CONST(X'33')
     D F4              C                   CONST(X'34')
     D F5              C                   CONST(X'35')
     D F6              C                   CONST(X'36')
     D F7              C                   CONST(X'37')
     D F8              C                   CONST(X'38')
     D F9              C                   CONST(X'39')
     D F10             C                   CONST(X'3A')
     D F11             C                   CONST(X'3B')
     D F12             C                   CONST(X'3C')
     D F13             C                   CONST(X'B1')
     D F14             C                   CONST(X'B2')
     D F15             C                   CONST(X'B3')
     D F16             C                   CONST(X'B4')
     D F17             C                   CONST(X'B5')
     D F18             C                   CONST(X'B6')
     D F19             C                   CONST(X'B7')
     D F20             C                   CONST(X'B8')
     D F21             C                   CONST(X'B9')
     D F22             C                   CONST(X'BA')
     D F23             C                   CONST(X'BB')
     D F24             C                   CONST(X'BC')
     D CLEAR           C                   CONST(X'BD')
     D ENTER           C                   CONST(X'F1')
     D HELP            C                   CONST(X'F3')
     D ROLLDN          C                   CONST(X'F4')
     D ROLLUP          C                   CONST(X'F5')
     D PRINT           C                   CONST(X'F6')
     D RCBKSP          C                   CONST(X'F8')
     D AUTENT          C                   CONST(X'3F')

    RPGLE  - OS/400 API Error Data Structure
Posted By: JimmyOctane   Contact

*********************************************
      *  OS/400 API Error Data Structure
      **********************************************
     **  API Error Return Code data structure
     D api_error       DS
     **  Bytes Provided
     D err_BProv                     10I 0 inz(%size(api_error))
     D*  Bytes Available
     D*    -- Test err_BAvail for > 0 then look at ERR_MSGID
     D*       for the CPF message ID that was issued.
     D err_BAvail                    10I 0 inz(0)
     D*  Exception Id
     D err_MsgID                      7A
     D*  Reserved
     D err_Resv1                      1A
     D*  extended error stuff, such as the message data fields
     D err_exterr                    64A
     D err_status      S              1A   INZ(*OFF)
     D err_flags       S             10I 0 INZ(0)


    RPGLE  - Remove quotes from a data string
Posted By: JimmyOctane   Contact

D qtScan          S              9B 0
     D qtText          S            256A
     C*-----------------------------------------------------------------
     C                   Z-ADD     1             qtScan
     C                   Dow       qtScan  > 0 and qtScan <= %size(qtText)
     c     ''''          Scan      qtText:qtScan qtScan
     C                   if        qtScan > 0
     C                   eval      qtText = %subst(qtText: 1 : qtScan) +
     C                              '''' +  %subst(qtText: qtScan+1)
     C                   Add       2             qtScan
     C                   endIf
     C                   endDo

    RPGLE  - Testing for valid *ISO date
Posted By: JimmyOctane   Contact

D*=======================================================
     D ISODate         S               D
     D Count           S             06  0
     D MonthD          S             02  0
     D YearD           S             04  0
     D ChrMonth        S             02
     D ChrYear         S             04
     D Chr6            S             06
     C*
     C*  OLDELT is a decimal field in data file with length of 8,0
     C*  Test(de) = Test date for error if error %Error = *On
     C*
     C     *ISO          Test(de)                OLDELT      
     C                   If        Not%Error
     C     *ISO          Move      OLDELT        ISODate
     C*
     C*  Using Extrct to extract the year and month from date
     C*  
     C                   Extrct    ISODate:*M    MonthD
     C                   Extrct    ISODate:*Y    YearD
     C                   Move      MonthD        ChrMonth
     C                   Move      YearD         ChrYear
     C                   Eval      Chr6 = ChrYear + ChrMonth
     C                   Move      Chr6          YEARMONTH
     C*
     C                   Z-add     Count         LINEITEMS
     C                   If        YearD  = 2002
     C                             Or YearD = 2001
     C                             And MonthD >= 10
     C                   Write     AVERAGER
     C                   Endif
     C                   Endif
     C*=======================================================

    RPGLE  - Defining constants
Posted By: JimmyOctane   Contact

D HTTPHeader      C                   CONST('Content-type: text/html')
     D NewLine         C                   CONST(X'15')
     D Yel             C                   CONST('')
     D End             C                   CONST('')

    RPGLE  - Defining subfiles in F specs
Posted By: JimmyOctane   Contact

FDRPT002D  cf   e             workstn infds(INFDS)
     F                                     sfile(SUB01 : RRn1)
     F                                     sfile(SUB02 : RRn2)
     F                                     sfile(SUB03 : RRn3)
     F                                     sfile(SUB04 : RRn4)

    RPGLE  - Using Data queues in RPGLE
Posted By: JimmyOctane   Contact

C*-------------------------------------------------------
     C* ENTRY PARMS
     C*
     C     *ENTRY        PLIST
     C                   PARM                    @DTAQ            10
     C                   PARM                    @QLIB            10
     C                   PARM                    @QLEN             5 0
     C                   PARM                    OUT8             08
     C*
     C* RECEIVE DATA QUEUE PARMS
     C*
     C     PRCVQ         PLIST
     C                   PARM      @DTAQ         DTAQ
     C                   PARM      @QLIB         QLIB
     C                   PARM      0             QLEN
     C                   PARM      *BLANK        QDATA
     C                   PARM      0             QWAIT             5 0
     C*
     C* DEFINE VARIABLES
     C*
     C     *LIKE         DEFINE    @DTAQ         DTAQ
     C     *LIKE         DEFINE    @QLIB         QLIB
     C     *LIKE         DEFINE    @QLEN         QLEN
     C*-------------------------------------------------------
     C*  RECEIVE DATA QUEUE - WAIT for ever
     C*
     C                   Dou       1 = 2
     C                   CALL      'QRCVDTAQ'    PRCVQ                  99
     C*
     C* When no more dataqueue entries bail.
     C*
     C                   IF        QLEN   = *Zeros
     C                   Leave
     C                   Else
     C                   EXSR      $RTVA                                      
     C                   Endif
     C                   Enddo
     C*-------------------------------------------------------

    RPGLE  - CPYTOSTMF QCMDEXC example
Posted By: JimmyOctane   Contact

C*
     C*
     C* CPYTOSTMF FROMMBR('/QSYS.LIB/CGI_BIN.LIB/DAILY.FILE/DAILY.MBR')
     C*           TOSTMF('/WEB/REPORTS/20020602/DailyReports.htm')
     C*          STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)
     C*
     C                   Eval      CmdString =%Trim('CPYTOSTMF FROMMBR(')  +
     C                                          %Trim('''')                +
     C                                          %Trim('/QSYS.LIB/CGI_BIN') +
     C                                          %Trim('.LIB/DAILY.FILE/D') +
     C                                          %Trim('AILY.MBR')          +
     C                                          %Trim('''')                +
     C                                          %Trim(') TOSTMF(')         +
     C                                          %Trim('''')                +
     C                                          %Trim('/WEB/REPORTS/')     +
     C                                          %Trim(Chr8)                +
     C                                          %Trim('/DailyReports.htm') +
     C                                          %Trim('''')                +
     C                                          %Trim(')')                 +
     C                                          %Trim('!STMFCODPAG(*PCAS') +
     C                                          %Trim('CII)')              +
     C                                          %Trim('!STMFOPT(*REPLACE)')
     C     '!':' '       Xlate     CmdString     CmdString
     C*
     C                   Eval      Len = %Len(%Trim(CmdString))
     C                   Call      'QCMDEXC'                            88
     C                   Parm                    CmdString
     C                   Parm      Len           CmdLength

    RPGLE  - Scan and replace entire string
Posted By: JimmyOctane   Contact

C*
     C     '&EXT'        Scan      WBTEXT
     C                   If        %Found
     C                   Eval      WBTEXT = %Trim(WBPEXT)
     C                   Endif
     C*
     C     '&DEPT'       Scan      WBTEXT
     C                   If        %Found
     C                   Eval      WBTEXT = %Trim(WBPDEPT)
     C                   Endif
     C*
     C     '&IMAGE'      Scan      WBTEXT
     C                   If        %Found
     C                   Eval      WBTEXT = 'No photo Available'
     C                   Endif

    RPGLE  - Reading equal a database
Posted By: JimmyOctane   Contact

C*
     C* Footer
     C*
     C     'F'           Setll     WBPHONE1WP
     C     'F'           Reade     WBPHONE1WP
     C                   Dow       Not%Eof(WBPHONE1WP)
     C*
     C                   eval      WrtDta = %trim(WBTEXT) +
     C                                      NewLine
     C                   EXSR      $WrStout
     C*
     C     'F'           Reade     WBPHONE1WP
     C                   Enddo

    RPGLE  - Writting data to browser (internet explorer) from Iseries
Posted By: JimmyOctane   Contact

D*----------------------------------------------------
     D*
     D* API error processing
     D*
     D WPError         DS
     D  EBytesP                1      4B 0 INZ(40)
     D  EBytesA                5      8B 0
     D  EMsgID                 9     15
     D  EReserverd            16     16
     D  EData                 17     56
     D*
     D* define the data for the API
     D* 
     D WrtDta          S           1024
     D WrtDtaLen       S              9B 0
     D Count           S             01  0
     D WNM1            S             50
     D WEX1            S             10
     D WDP1            S             10
     D WNM2            S             50
     D WEX2            S             10
     D WDP2            S             10
     D WNM3            S             50
     D WEX3            S             10
     D WDP3            S             10
     D*
     D NewLine         C                   CONST(X'15')
     C                   eval      WrtDta = %trim("Umm Hello!") 
     C                                      + NewLine
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C*  $WrStout - Write data to browser
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     CSR   $WrStOut      Begsr
     C*
     C                   eval      WrtDtaLen = %len(%trim(WrtDta))
     C                   CALLB     'QtmhWrStout'
     C                   PARM                    WrtDta
     C                   PARM                    WrtDtaLen
     C                   PARM                    WPError
      *
     C*
     C                   Endsr
     C*----------------------------------------------------

    RPGLE  - Creating an array of from defining an external table as data structure
Posted By: JimmyOctane   Contact

D*
     D* The file BUDGET hold budget info both $dollars and expected sold qtys
     D* We just want the money, so it starts in position 6 and ends with 77.
     D*  Its also stored by month (thats why 12) so now we have all $'s for all
     D* months in one place BUD 
     D*
     D               E DS                  EXTNAME(BUDGET)
     D  BUD                    6     77P 2
     D                                     DIM(12)

    RPGLE  - Stop debug from looping on file fields header spec
Posted By: JimmyOctane   Contact

H option(*srcstmt: *nodebugio)  dftactgrp(*no)

    RPGLE  - Date difference hour minute second
Posted By: JimmyOctane   Contact

C*
     C*DiffDays = %Diff(ToISO:FromISO:*DAYS)
     C*
     C     SAVEETIME     Subdur    SAVESTIME     DiffSec:*S
     C*
     C                   Eval      RunHours   = (DiffSec/3600)
     C                   Eval      RunMinutes = (DiffSec/60 - RunHours * 60)
     C                   Eval      RunSeconds = (DiffSec -((RunHours * 3600)+
     C                                          (RunMinutes * 60)))
     C*

    RPGLE  - Subroutine to backup libraries from a file using QCMDEXC
Posted By: JimmyOctane   Contact

C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
     C* $Backup - Backup the libraries/files from the system
     C* SAVLIB LIB(LIBRARY) DEV(&DEVICE) ENDOPT(&REWIND)
     C* SAVF(&SAVFLIB/&SAVF) SAVACT(*LIB) ACCPTH(*YES)
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
     C     $Backup       Begsr
     C*
     C     KeyName       Setll     BCKLIB03P
     C     KeyName       Reade     BCKLIB03P
     C                   Dow       Not%Eof(BCKLIB03P)
     C*
     C* save command  always use SAV command.
     C*
     C                   Select
     C                   When      TYPE = '*LIB'
     C                   Eval      SaveCmd = 'SAVLIB LIB('
     C                   When      TYPE = '*FIL'
     C                   Eval      SaveCmd = 'SAVOBJ OBJ('
     C                   When      TYPE = '*DOC'
     C                   Eval      SaveCmd = 'SAV'
     C                   Endsl
     C*
     C* SAVLIB LIB(JUNK) DEV(*SAVF) SAVF(JJFLIB/SAVF)
     C*
     C                   Eval      Device = 'DEV(' +  %Trim(TAPEDRIVE)
     C                             + %Trim(')')
     C                   Eval      EndOpt = %Trim('ENDOPT(')
     C                             + %trim(ENDOFTAPE) + %Trim(')')
     C*
     C*   write record for start of backup - Start Date And Time
     C*
     C                   If        Not%Open(BCKLIB04P)
     C                   Open      BCKLIB04P
     C                   Endif
     C*
     C                   If        Not%Eof(BCKLIB03P)
     C*
     C                   Time                    SAVESTIME
     C                   Time                    KeyTime
     C                   Move      *DATE         SAVESDATE
     C                   Move      *DATE         KeyDate
     C                   Write     BCK04R
     C*
     C                   Endif
     C*
     C                   If        %Open(BCKLIB04P)
     C                   Close     BCKLIB04P
     C                   Endif
     C*
     C                   Eval      CmdString = %Trim(SaveCmd) + %Trim('@@')
     C                             + %Trim(OBJECT) + %Trim(')@')
     C                             + %Trim(Device)+ %trim('@')+%Trim(EndOpt)
     C                             + %Trim('@SAVACT(*LIB) ACCPTH(*YES)')
     C*
     C     '@':' '       Xlate     CmdString     CmdString
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      256.          CmdLength
     C*
     C*   write record for start of backup - End Date And Time - Total run
     C*
     C     Back04Key     Klist
     C                   Kfld                    LISTNAME
     C                   Kfld                    OBJECT
     C                   Kfld                    KeyDate
     C                   Kfld                    KeyTime
     C*
     C                   If        Not%Open(BCKLIB04P)
     C                   Open      BCKLIB04P
     C                   Endif
     C*
     C     Back04Key     Chain     BCKLIB04P
     C                   If        %Found(BCKLIB04P)
     C                   Time                    SAVEETIME
     C                   Move      *DATE         SAVEEDATE
     C*
     C*DiffDays = %Diff(ToISO:FromISO:*DAYS)
     C*
     C     SAVEETIME     Subdur    SAVESTIME     DiffSec:*S
     C*
     C                   Eval      RunHours   = (DiffSec/3600)
     C                   Eval      RunMinutes = (DiffSec/60 - RunHours * 60)
     C                   Eval      RunSeconds = (DiffSec -((RunHours * 3600)+
     C                                          (RunMinutes * 60)))
     C*
     C                   Exsr      $LibInfo
     C*
     C                   Update    BCK04R
     C                   Endif
     C*
     C                   If        %Open(BCKLIB04P)
     C                   Close     BCKLIB04P
     C                   Endif
     C*
     C     KeyName       Reade     BCKLIB03P
     C                   Enddo
     C*
     C*  if there is a program to run then run it.
     C*
     C                   If        ENDPGM <> *Blanks
     C                   Eval      CmdString = 'CALL@@' + %Trim(ENDPGMLIB)
     C                             + %Trim('/')  + %Trim(ENDPGM)
     C     '@':' '       Xlate     CmdString     CmdString
     C                   Call      'QCMDEXC'                            99
     C                   Parm                    CmdString
     C                   Parm      256.          CmdLength
     C                   Endif
     C*
     C                   Endsr

    RPGLE  - Examples for FREE RPG
Posted By: Jamie Flanary   Contact

Programmers can specify search arguments in keyed Input/Output operations in
/FREE calculations in two new ways:

1. By specifying the search arguments (which can be expressions) in a list.
2. By specifying a data structure which contains the search arguments.

Examples:
 D custkeyDS e ds extname(custfile:*key)

/free
CHAIN (keyA : keyB : key3) custrec;
CHAIN %KDS(custkeyDS) custrec;
|
|
|
|
|
|


    RPGLE  - Various date examples
Posted By: Jamie Flanary   Contact

H*-----------------------------------------
     H* %MSeconds %Seconds, %Minutes, %Hours,
     H* %Days, %Months, and %Years.
     H* %Date, %Time, and %TimeStamp
     H*
     H*
     H*
     H*
     H*-----------------------------------------
     D*-----------------------------------------
     D* Program Info
     D*-----------------------------------------
     D                SDS
     D  @PGM                 001    010
     D  @PARMS               037    039  0
     D  @JOB                 244    253
     D  @USER                254    263
     D  @JOB#                264    269  0
     D*
     D*  Field Definitions.
     D*
     D ISOdate         S               D
     D USAdate         S               D   DatFmt(*USA)
     D XMASDate        S               D   Inz(D'2003-12-25')
     D LogonDate       S               D
     D Date_Start      S             15
     D MonthNames      S             12    Dim(12) CtData
     D Date_String     S             40

      *
      * Time Stamp
      *
     DTimeStamp        S               Z
      *
     D WorkISO         S               D
     D Month           S              2  0
     D Day             S              2  0
     D Year            S              4  0
     D Decimal8        S              8  0
     D LogMonth        S              2  0
     D LogDay          S              2
     D LogYear         S              4  0
     D NextMonth       S               D
     D EndOfMonth      S               D
      *
      * Variables for free RPG example + some above
      *
     D DateIn          S               D
     D FromISO         S               D
     D ToISO           S               D
     D DiffDays        S              3  0
     D WorkField       S              5  0
     D Name            S              9    Based(NamePtr)
     D Name2           S              9
     D NamePtr         S               *   Inz(%ADDR(Names))
     D Names           S             63    Inz('Sunday   Monday   Tuesday  Wedn+
     D                                     esdayThursday Friday   Saturday ')
     D*
     D* RPG-defined date formats and separators for Date data type
     D*
      * 2-Digit Year Formats
      * *MDY  Month/Day/Year  mm/dd/yy  8  09/26/03
      * *DMY  Day/Month/Year  dd/mm/yy  8  26/09/03
      * *YMD  Year/Month/Day  yy/mm/dd  8  03/09/26
      * *JUL  Julian          yy/ddd    6  03/926
     C*=====
      * 4-Digit Year Formats
      * *ISO  Int Standards Org yyyy-mm-dd  10  2003-09-26
      * *USA  IBM USA Standard  mm/dd/yyyy  10  09/26/2003
      * *EUR  IBM European Std  dd.mm.yyyy  10  26.09.2003
      * *JIS  Japan Indst Std   yyyy-mm-dd  10  2003-09-26
      *
      *
     C*
      *
      * Okay first lets get todays date
      * For display purposes the date is now
      *      Friday September 26th 2003
      *  so date now looks like this 2003-09-26
      *  because the default date type is *ISO
      *
     C                   Eval      ISOdate = %Date()
      *
      *  Now that I have the date in a date format
      *  (*ISO) I can do stuff to it.
      *  Once I move this date to a decimal 8,0 field
      *  the date is now in format 20030926
      *  Not very exciting..yet
      *
     C                   Move      ISODate       Decimal8
      *
      *  Now back to the *ISO date  lets add
      *  1 month to the date.
      *  date after will equal 2003-10-26
      *  %days and % years works the same as %months
      *
     C                   Eval      WorkISO  = ISODate + %Months(1)
      *
      *  Logon date is set equal to today then the month is extracted
      *  the "*M" is the same as "*Months"  LogMonth = 09.
      *                                     LogDay   = 26.
      *
     C                   Eval      LogonDate =  %Date()
     C                   Extrct    LogonDate:*Y  LogYear
     C                   Extrct    LogonDate:*M  LogMonth
     C                   Extrct    LogonDate:*D  LogDay
      *
      *  Build the date string - Later we will add the day name
      *
     C                   Eval      Date_String =
     C                              %Trim(MonthNames(LogMonth))
     C                              + %trim('@') + %Trim(LogDay)
     C                              + %trim(',@') + %Char(LogYear)
      *
      *  convert the "@" back to *Blanks
      *  Date_String = 'September 26, 2003'
      *
     C     '@':' '       Xlate     Date_String   Date_String
      *
      * TimeStamp = yyyy-mm-dd-hh.mm.ss.mmmmmm (length 26).
      * TimeStamp = '2003-09-26-15.16.26.531000'
      *
     C                   Eval      TimeStamp = %TimeStamp()
      *
      *  Free Format date stuff   By the way Name2 = 'Friday'
      *
      /Free
        DateIn   = %Date()                     ;
        ISODate  = %Date()                     ;
        ISODate  = DateIn                      ;
        Year     = %Subdt(ISODate:*Y)          ;
        Month    = %Subdt(ISODate:*M)          ;
        Day      = %Subdt(ISODate:*D)          ;
        FromISO  = ISODate - %YEARS(1)         ;
        ToISO    = ISODate                     ;
        DiffDays = %Diff(ToISO:FromISO:*DAYS)  ;
        ISODate  = DateIn                      ;

        WorkField = %Diff(ISODate:D'1899-12-31':*DAYS);
        WorkField = %REM(WorkField:7);

        NamePtr = NamePtr + (WorkField * 9);
        Name2 = Name;
      /End-Free
      *
      *  Build the date string - With The Day Name
      *  DATE_STRING = 'Friday  September 26, 2003              '
      *
     C                   Eval      Date_String =
     C                              %trim(Name) + %Trim('@@')
     C                              + %trim(MonthNames(LogMonth))
     C                              + %trim('@') + %Trim(LogDay)
     C                              + %trim(',@') + %Char(LogYear)
     C                   Eval      Date_String = %Xlate('@':' ':Date_String)
      *
      * Calculate the last day of the month
      * ENDOFMONTH = '2003-09-30'
      *
     C     ISODate       AddDur    1:*Months     NextMonth
     C                   Extrct    NextMonth:*D  DiffDays
     C     NextMonth     SubDur    DiffDays:*D   EndOfMonth


     C                   Eval      *INLR = *On
     C*----------------------------------------------------
** CTDATA MonthNames
January
February
March
April
May
June
July
August
September
October
November
December

    RPGLE  - Converting *Char to *Dec
Posted By: Jamie Flanary   Contact

c                   Eval      numericField =
     c                               %dec( %xlate(',':' ':alphaFld) : 15 : 2)


Note the %xlate replaces the thousands separator with a blank. 
You may also need to %xlate '$' and '*', depending on your data.
%dec hates thousands separators, but ignores all blanks. 
You will get a runtime error RNQ0105 if the argument isn't valid 
according to the rules found in the RPG reference. 


    RPGLE  - Free form RPG read entire table
Posted By: JimmyOctane   Contact

C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 
/free

// Loop through all records of file 
read file;

dow not %eof(file); // Process until end of file
   if %error;
      dsply 'Read error: process aborting.';
      leave;
   else;
      pos = %scan (',': name);
      if pos > 0;
         firstname = %trimr(%subst(name:1:pos-1));
         update file;
      endif;
   read file;
enddo;

/end-free
C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 
 

    RPGLE  - Write directly to IFS
Posted By: JimmyOctane   Contact

H dftactgrp( *no ) bnddir( 'QC2LE' ) OPTION(*SRCSTMT : *NODEBUGIO)
     H*============================================================
     H*
     H*============================================================
     FRUAF015D  IF   E             DISK
     FSRBNAM    IF   E           K DISK
     FSRBNFP    IF   E           K DISK
     FSRBNOI    IF   E           K DISK
     D*
     D RC              S             10I 0
     D FileNam         S             20A   INZ('/code400/File819.txt')
     D FileNamP        S               *   INZ(%ADDR(FileNam))
     D FileDescr       S             10I 0

     D O_CREAT         S             10I 0 INZ(8)
     D O_RDWR          S             10I 0 INZ(4)
     D O_TEXTDATA      S             10I 0 INZ(16777216)
     D O_CODEPAGE      S             10I 0 INZ(8388608)
     D Oflag           S             10I 0 INZ(0)
     D Omode           S             10U 0 INZ(511)
     D cp              S             10U 0 INZ(819)
     D WorkEmail       S             50
     D CmdString       S            512
     D CmdLength       S             15  5
     D SendEmail       S             50
     D Len             S             03  0
     D*
     D Big             S            500
     D Customer        S             11
     D Key#2           S             10    Inz('*PHONE')
     D Chr7            S             07
     D Dec7            S             07  0
     D Chr8            S             08
     D Chr4            S             04
     D Chr6            S             06
     D Negative        S             01
     D Chr2            S             02
     D Month           S             02  0
     D ChrMonth        S             02
     D Year            S             04  0
     D Day             S             02  0
     D ChrDay          S             02
     D ISODate         S               D
     D Str             S             03  0
     D Q               C                   CONST('''')
     D*
     D* Program Info
     D*
     D                SDS
     D  @PGM                 001    010
     D  @PARMS               037    039  0
     D  @JOB                 244    253
     D  @USER                254    263
     D  @JOB#                264    269  0
     D*
     D InID            S             11
     D InDirection     S             01
     D InTrans         S             15  5
     D*
     D ZeroBin         S              1A   INZ(*ALLX'00')
     D NLZero          S              2A   INZ(X'1500')
     D SI_Fmt          S             50A   INZ('\n')
     D SI_FmtP         S               *   INZ(%ADDR(SI_Fmt))
     D SI_Msg          S             50A
     D SI_MsgP         S               *   INZ(%ADDR(SI_Msg))
     D Num_DS          DS
     D Num_Hex                        4A   INZ(X'00000000')
     D Num                           10I 0 OVERLAY(Num_Hex)
     D Buf             S            500A
     D BufP            S               *   INZ(%ADDR(Buf))
     D BufLen          S             10U 0

     Dperror           PR            10I 0 EXTPROC('perror')
     Dconst                            *   VALUE

     Dsprintf          PR            10I 0 EXTPROC('sprintf')
     D                                 *   VALUE
     D                                 *   VALUE
     D                               10I 0 VALUE OPTIONS(*NOPASS)
     D                                 *   VALUE OPTIONS(*NOPASS)
      * Open Operations
      * value returned = file descriptor 0 (OK), -1 (Error)

     Dopen             PR            10I 0 EXTPROC('open')
     D                                 *   VALUE
     D                               10I 0 VALUE
     D                               10U 0 VALUE OPTIONS(*NOPASS)
     D                               10U 0 VALUE OPTIONS(*NOPASS)

      * Read Operations
      * value returned = number of bytes read or , -1 (Error)

     Dread             PR            10I 0 EXTPROC('read')
     D                               10I 0 VALUE
     D                                 *   Value
     D                               10U 0 VALUE

      * Write Operations
      * value returned = number of bytes Written or , -1 (Error)

     Dwrite            PR            10I 0 EXTPROC('write')
     D                               10I 0 VALUE
     D                                 *   VALUE
     D                               10U 0 VALUE

      * Close Operations
      * value returned = 0 (OK) or , -1 (Error)

     Dclose            PR            10I 0 EXTPROC('close')
     D                               10I 0 VALUE

      * Open Directory Operation
      * value returned = file descriptor 0 (OK), -1 (Error)

     Dopendir          PR              *   EXTPROC('opendir')
     D                                 *   VALUE

      * Read Directory Operation
      *


     Dreaddir          PR              *   EXTPROC('readdir')
     D                                 *   VALUE

      * Open Directory Operation
      * value returned = 0 (OK) or , -1 (Error)

     Dclosedir         PR            10I 0 EXTPROC('closedir')
     D                                 *   VALUE

      * Unlink a File from system... Delete File
      * value returned = 0 (OK) or , -1 (Error)

     Dunlink           PR            10I 0 EXTPROC('unlink')
     D                                 *   VALUE
     C     *MDY          Move      UDATE         ISODate
     C                   Extrct    ISODate:*Y    Year
     C                   Extrct    ISODate:*M    Month
     C                   Extrct    ISODate:*D    Day
     C                   Move      Year          Chr4
     C                   Move      Month         Chr2
     C                   Eval      Chr4 = %Trim(Chr2)  +
     C                             %Trim(%Subst(Chr4:3:2))
     C
     C                   Clear                   Str
     C     'MMYY'        Scan      FileNam       Str
     C                   If        %Found
     C                   Eval      %Subst(FileNam:Str:4) = Chr4
     C                   Endif
     C*
     C*
     C*
     C                   Z-add     O_CREAT       Oflag
     C                   Add       O_RDWR        Oflag
     C                   Add       O_CODEPAGE    Oflag

     C                   EVAL      FileDescr=open(FileNamP:Oflag:Omode:cp)

     C                   IF        FileDescr = -1
     C                   EVAL      RC = perror(FileNamP)
     C                   Return
     C                   ENDIF

     C                   EVAL      RC = close(FileDescr)

     C                   IF        RC = -1
     C                   EVAL      RC = perror(FileNamP)
     C                   Return
     C                   ENDIF

     C                   Z-Add     O_RDWR        Oflag
     C                   Add       O_TEXTDATA    Oflag

     C                   EVAL      FileDescr=open(FileNamP:Oflag)

     C                   IF        FileDescr = -1
     C                   EVAL      RC = perror(FileNamP)
     C                   Return
     C                   ENDIF
     C*----------------------------------------------------------------
     C* This is where the writting takes place
     C*----------------------------------------------------------------
     C                   EVAL      Buf='This is a Test number 1' + X'25'
     C     *Start        Setll     RUAF015D
     C                   Read      RUAF015D
     C                   Dow       Not%Eof(RUAF015D)
     C
     C                   Eval      %Subst(Big:001:11) = PRIME
     C                   Eval      %Subst(Big:016:30) = NXNAME
     C                   Eval      %Subst(Big:056:30) = NXADR1
     c                   Eval      %Subst(Big:086:30) = NXADR2
     C
     C*  Chain to srbnam and get city, state, zipcode
     C
     C                   Movel(p)  PRIME         Customer
     C     Customer      Chain     SRBNAM
     C                   If        %Found(SRBNAM)
     C                   Eval      %Subst(Big:116:20) = NAADR4
     C                   Eval      %Subst(Big:136:02) = NASPCD
     C                   Eval      %Subst(Big:138:10) =
     C                             %Trim(%Subst(NAPOCD:4:10))
     C*
     C*  Country code
     C*
     C                   Eval      %Subst(Big:281:05) = %Trim(NACOUN)
     C                   Endif
     C*
     C* Chain to srbnfp for the phone number
     C*
     C     Key01         Klist
     C                   Kfld                    Customer
     C                   KFLD                    Key#2
     C     Key01         Chain     SRBNFP
     C                   If        %Found(SRBNFP)
     C                   Eval      %Subst(Big:148:10) =
     C                             %Trim(%Subst(NFPHNO:1:3)) +
     C                             %Trim(%Subst(NFPHNO:5:7))
     C                   Endif
     C
     C*
     C*  take the date entered from customer master and send as date opened
     C*  format will be MMYY
     C*
     C                   Move      NACRDT        Chr8
     C                   Eval      %Subst(Big:158:04) =
     C                             %Trim(%Subst(Chr8:5:2)) +
     C                             %Trim(%Subst(Chr8:3:2))
     C*
     C*  Create the run date
     C*
     C     *MDY          Move      UDATE         ISODate
     C                   Extrct    ISODate:*Y    Year
     C                   Extrct    ISODate:*M    Month
     C                   Extrct    ISODate:*D    Day
     C                   Move      Month         ChrMonth
     C                   Move      Day           ChrDay
     C                   Eval      Chr8 = %Char(Month) + %Char(Day) +
     C                                    %Char(Year)
     C                   Move      Year          Chr4
     C                   Eval      Chr2 = %Subst(Chr4:3:2)
     C                   Eval      Chr6 = %Trim(ChrMonth) + %Trim(ChrDay)
     C                                    + %Trim(Chr2)
     C                   Eval      %Subst(Big:162:06) = Chr6
     C*
     C*  Create the last invoice MMYY format date
     C*
     C     Customer      Chain     SRBNOI
     C                   If        %Found(SRBNOI)
     C     *ISO          Test(De)                NOLIND
     C                   If        Not%Error
     C     *ISO          Move      NOLIND        ISODate
     C                   Extrct    ISODate:*Y    Year
     C                   Extrct    ISODate:*M    Month
     C                   Extrct    ISODate:*D    Day
     C                   Move      Month         ChrMonth
     C                   Move      Year          Chr4
     C                   Eval      Chr2 = %Subst(Chr4:3:2)
     C                   Eval      Chr4 = %Trim(ChrMonth) + %Trim(Chr2)
     C                   Eval      %Subst(Big:168:08) = Chr4
     C                   Endif
     C                   Endif
     C*
     C*  now do the balance, current and the 4 horsemen
     C*
     C                   If        BALANCE < *Zeros
     C                   Eval      BALANCE = (BALANCE * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C                   Move      BALANCE       Chr7
     C*
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:172:08) = Chr7 +%Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:172:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  current
     C*
     C                   Eval      Dec7 = CURRENT + NOTDUE
     C*
     C                   If        Dec7    < *Zeros
     C                   Eval      Dec7    = (Dec7 * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C*
     C                   Move      Dec7          Chr7
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:180:08) = Chr7  + %Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:180:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  30 days past
     C*
     C                   If        DUEM01  < *Zeros
     C                   Eval      DUEM01  = (DUEM01  * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C                   Move      DUEM01        Chr7
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:188:08) = Chr7  + %Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:188:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  60 days past
     C*
     C                   If        DUEM02  < *Zeros
     C                   Eval      DUEM02  = (DUEM02  * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C                   Move      DUEM02        Chr7
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:196:08) = Chr7  + %Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:196:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  90 days past
     C*
     C                   If        DUEM03  < *Zeros
     C                   Eval      DUEM03  = (DUEM03  * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C                   Move      DUEM03        Chr7
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:204:08) = Chr7  + %Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:204:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  Over 90 days past
     C*
     C                   If        DUEM04  < *Zeros
     C                   Eval      DUEM04  = (DUEM04  * -1)
     C                   Eval      Negative = 'Y'
     C                   Else
     C                   Eval      Negative = 'N'
     C                   Endif
     C                   Move      DUEM04        Chr7
     C                   If        Negative = 'Y'
     C                   Eval      %Subst(Big:212:08) = Chr7  + %Trim('-')
     C                   Else
     C                   Eval      %Subst(Big:212:08) = '0' + %Trim(Chr7)
     C                   Endif
     C*
     C*  Contact name
     C*
     C                   Eval      %Subst(Big:241:20) = %Trim(NOCONT)
     C*
     C*  write the line out.
     C*
     C                   EVAL      Buf = Big +  X'25'
     C                   Movel(p)  Big           Buf
     C                   Eval      %Subst(Buf:500:1) = X'25'
     C     X'25'         SCAN      Buf           BufLen                   30
     C                   EVAL      RC = write(FileDescr: BufP: BufLen)
     C                   Clear                   Big
     C                   Clear                   Buf
     C
     C                   Read      RUAF015D
     C                   Enddo
     C*
     C*Shut down the IFS file and prepare to email.
     C*
     C                   Exsr      $TheEnd
     C*----------------------------------------------------------------
     C*  T H E   E N D
     C*----------------------------------------------------------------
     CSR   $TheEnd       Begsr
     C                   IF        RC = -1
     C                   EVAL      RC = perror(FileNamP)
     C                   Return
     C                   ENDIF
     C*
     C* Close the File
     C*
     C                   EVAL      RC = close(FileDescr)
     C                   IF        FileDescr = -1
     C                   EVAL      RC = perror(FileNamP)
     C                   Return
     C                   ENDIF
     C*
     C                   Eval      *INLR = *On
     C*
     C                   Endsr
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
     C*  *INZSR - Initial one time run subroutine
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=
     CSR   *INZSR        Begsr
     C*
     C                   Endsr
     C*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=

    RPGLE  - test numeric
Posted By: jimmy octane   Contact

D NumParm         S              4
     D                 DS
     D Chk_Seasn               1      4
     D Chk_Numeric             1      4S 0

     C     *Entry        Plist
     C                   Parm                    NumParm
     C                   Eval      Chk_Seasn = NumParm
     C                   TestN                   Chk_Seasn            99
     C                   If        *IN99 = *On
     C                   If        Chk_Numeric >= *Zero
     C     'Good'        Dsply
     C                   Else
     C     'Bad'         Dsply
     C                   EndIf
     C                   Else
     C     'Bad'         Dsply
     C                   EndIf
     C                   Eval      *INLR = *On
 


    RPGLE  - Unique file name example
Posted By: JimmyOctane   Contact

H dftactgrp(*no) option(*srcstmt : *nodebugio)
      *
      * Field Definitions
      *
     D FileName        s             80
     D Prefix          s            256    Inz('Code400')
     D ISODate         s               D
     D ISOTime         s               T
     D Month           s              2  0
     D Day             s              3  0
     D Hour            s              3  0
     D Minute          s              3  0
     D Second          s              3  0
      *
      *-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *  M A I N     L I N E
      *-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      *
     C                   Eval      ISODate = %Date()
     C                   Eval      ISOTime = %Time()

     C                   Eval      Month = %Subdt(ISODate:*Months)
     C                   Eval      Day   = %Subdt(ISODate:*Days)
     C                   Eval      Hour  = %Subdt(ISOTime:*Hours)
     C                   Eval      Minute= %Subdt(ISOTime:*Minutes)
     C                   Eval      Second= %Subdt(ISOTime:*Seconds)

     C                   eval      FileName = %trim(Prefix) +
     C                             %trim(%Char(Month))+
     C                             %trim(%Char(Day))+
     C                             %trim(%Char(Hour))+
     C                             %trim(%Char(Minute))+
     C                             %trim(%Char(Second))+
     C                             %trim('.csv')

     C*
     C*  The variable FileName will look like .... Code4001014113435.csv
     C*  depending on the date and time of course.....
     C*

     C                   eval      *inlr = *on
     C                   return

    RPGLE  - Convert Date - free format
Posted By: JimmyOctane   Contact



V5R2
  /free
    numDate = %int(%char(date : *eur0);  //  ddmmyyyy
    numTS = %dec(%char(timestamp : *iso0) : 20 : 0);   //yyyymmddhhmmssuuuuuu
                /End Free
  


  V5R1
 
   H bnddir('QC2LE')   
   D atoll           pr            20i 0 extproc('atoll')   
   D  string                         *   value options(*string)
   
   /free 
   numDate = atoll(%char(date : *eur0));
                 /End Free
    



    RPGLE  - convert amount Numeric to WORDS
Posted By: JimmyOctane   Contact

Rewrite this later
E                    AR$        11  1               ALPHA AMOUNT
     E                    W          20  9               ARRAY OF WORDS
     E                    X       7  19  9               WORDS  1 TO 19
     E                    Y       7   8  9               WORDS 20 TO 90
     E                    MISC    7  10  9               MISC. WORDS
     E                    WORK        9  1               WORK ARRAY
     E                    AMT       150  1               RESULT ARRAY
      *
      *     PARAMETERS:  LIMIT = WORD LENGTH LIMIT (MAXIMUM 150),
      *     CHK$ = CHECK AMOUNT TO CONVERT (MAXIMUM 999,999,999.99),
      *     VALUE = SPELLED AMOUNT RETURNED TO CALLING PROGRAM, ERROR =
      *     ERROR FLAG WHEN SPELLED AMOUNT EXCEEDS LIMIT.
      *
     C           *ENTRY    PLIST
     C                     PARM           LIMIT   30       MAX: 150
     C                     PARM           CHK$   112       999,999,999.99
     C                     PARM           VALUE 150         RETURN VALUE
     C                     PARM           ERROR   1        ERROR FLAG
      *
      *     CONVERT CHECK AMOUNT TO POSITIVE, IF NECESSARY
      *
     C           CHK$      IFLT 0
     C                     Z-SUBCHK$      CHK$2  112
     C                     ELSE
     C                     Z-ADDCHK$      CHK$2
     C                     END
      *
      *     TRANSLATE CHECK AMOUNT INTO WORDS
      *
     C                     MOVEA'00'      *IN,06
     C                     MOVE *BLANKS   WORDS   4
     C                     MOVE *BLANKS   ERROR
      *
     C           WORDS     DOUEQ'QUIT'
     C                     MOVE *BLANKS   AMT
     C                     MOVE *BLANKS   W
     C                     MOVE CHK$2     CHK$A  11
     C                     MOVEACHK$A     AR$
     C                     Z-ADD1         I       30
      *
     C           CHK$2     IFGE 1000000                    OVER $1,000,000
     C                     MOVEAAR$,1     A03     3
     C                     EXSR SUBN30
     C                     MOVE MISC,2    W,I
     C                     ADD  1         I
     C                     END                             CHK$2>=1000000
      *
     C                     MOVEAAR$,4     A03              OVER $1,000
     C                     MOVE A03       N30
     C           N30       IFNE 0
     C                     EXSR SUBN30
     C                     MOVE MISC,3    W,I
     C                     ADD  1         I
     C                     END                             N30 IFNE 0
      *
     C                     MOVEAAR$,7     A03              LESS THAN $1000
     C                     MOVE A03       N30
     C           N30       CASNE*ZEROS    SUBN30
     C                     END
      *
     C           CHK$2     IFLT 1                          UNDER A BUCK
     C                     MOVE MISC,4    W,I
     C                     ADD  1         I
     C                     END                             CHK2$ IFLT 1
      *
     C                     MOVE MISC,5    W,I              ADD "DOLLARS
     C                     ADD  1         I                AND"
     C           *IN07     IFEQ '0'
     C                     MOVE MISC,6    W,I
     C                     ELSE
     C                     MOVE MISC,10   W,I
     C                     END                             *IN07 IFEQ '0'
     C                     ADD  1         I
      *
     C                     MOVEAAR$,10    A02     2        PROCESS CENTS
     C                     MOVE A02       N20
     C           N20       IFEQ *ZEROS
     C                     MOVE MISC,4    W,I
     C                     ADD  1         I
     C                     ELSE
     C           *IN06     IFEQ '0'
     C                     EXSR SUBN20
     C                     ELSE
     C                     MOVELA02       W,I
     C                     ADD  1         I
     C                     END                             *IN06 IFEQ '0'
     C                     END                             N20 IFEQ *ZERO
     C           N20       IFNE 01
     C                     MOVE MISC,7    W,I
     C                     ELSE
     C                     MOVE MISC,8    W,I
     C                     END                             N20 IFNE 01
     C                     ADD  1         I
      *
     C           CHK$      IFLT 0                          NEGATIVE AMOUNT
     C                     MOVE MISC,9    W,I
     C                     END                             CHK$ IFLT 0
      *
     C                     Z-ADD1         I                COMPRESS ARRAY
     C                     Z-ADD1         J       30       W
      *
     C           I         DOWLE19
     C                     MOVEAW,I       WORK
     C                     Z-ADD1         K       20
     C           ' '       LOKUPWORK,K                   05
     C           *IN05     IFEQ '0'
     C                     Z-ADD10        K
     C                     END
     C                     MOVEAWORK      AMT,J
     C                     ADD  K         J
     C                     ADD  1         I
     C           W,I       IFEQ *BLANKS
     C                     Z-ADD20        I
     C                     END
      *
     C                     END                             I DOWLE 19
      *
      *     IS THE RESULTANT CHARACTER STRING TOO LONG?  IF YES,
      *     TRY TO SHORTEN IT.
      *
     C           J         IFGT LIMIT
      *
      *     IF *IN07 IS ON, STRING IS TOO LONG.  EXIT WITH ERROR.
      *
     C           *IN07     IFEQ '1'
     C                     MOVE 'QUIT'    WORDS
     C                     MOVE 'Y'       ERROR
     C                     END
      *
      *     IF *IN06 IS ON, RETRY SHORTENING STRING.
      *
     C           *IN06     IFEQ '1'
     C                     MOVE '1'       *IN07
     C                     END
     C                     MOVE '1'       *IN06
     C                     ELSE
     C                     MOVE 'QUIT'    WORDS
     C                     END                             J IFGT LIMIT
      *
     C                     END                             WORDS LOOP
      *
      *      SETON LAST RECORD                                         LE
      *
     C                     MOVE *BLANKS   VALUE
     C           ERROR     IFNE 'Y'
     C                     MOVEAAMT       VALUE
     C                     END
      *
     C                     MOVE '1'       *INLR
      *
      *  SUBROUTINE TO TRANSLATE THE TWO RIGHT DIGITS OF EACH DIGIT
      *  TRIAD TO ITS SPELLED-OUT EQUIVALENT.
      *
      *
     CSR         SUBN20    BEGSR
     C           N20       IFGE 20
     C                     MOVELN20       N10
     C                     SUB  1         N10
     C                     MOVE Y,N10     W,I
     C                     ADD  1         I
     C                     MOVE N20       N10
     C           N10       IFNE 0
     C                     MOVE X,N10     W,I
     C                     ADD  1         I
     C                     END                             N10 IFNE 0
     C                     ELSE
     C           N20       IFNE 0
     C                     MOVE X,N20     W,I
     C                     ADD  1         I
     C                     END                             N20 IFNE 0
     C                     END                             N20 IFGE 20
     CSR                   ENDSR
      *
      *  SUBROUTINE TO TRANSLATE THE LEFTMOST DIGIT OF A TRIAD TO
      *  ITS WORD QUIVALENT AND STORE THE TWO RIGHTMOST DIGITS OF
      *  THE TRIAD IN VARIABLE N20 FOR SUBSEQUENT PROCESSING.
      *
     CSR         SUBN30    BEGSR
     C                     MOVE A03       N30     30
     C                     MOVELA03       N10     10
     C                     MOVE A03       N20     20
     C           N10       IFNE 0
     C                     MOVE X,N10     W,I
     C                     ADD  1         I
     C                     MOVE MISC,1    W,I
     C                     ADD  1         I
     C                     END                             N10 IFNE 0
     C                     EXSR SUBN20
     CSR                   ENDSR
      *
      *  WORD ARRAYS
      *
**
ONE      TWO      THREE    FOUR     FIVE     SIX      SEVEN
EIGHT    NINE     TEN      ELEVEN   TWELVE   THIRTEEN FOURTEEN
FIFTEEN  SIXTEEN  SEVENTEENEIGHTEEN NINETEEN
**
TWENTY   THIRTY   FORTY    FIFTY    SIXTY    SEVENTY  EIGHTY
NINETY
**
HUNDRED  MILLION, THOUSAND,NO       DOLLARS  AND      CENTS
CENT     CR       &

    RPGLE  - *ENTRY with a prototype
Posted By: JimmyOctane   Contact

dmain             pr                  extpgm('CODE400')
     d numberIn                      15p 5
     d*ENTRY
     dmain             pi
     d numberIn                      15p 5

     d text            s             15
     c                   if        %parms > 0
     c                   move      numberin      text
     c     text          dsply
     c                   else
     c     'Need number!'dsply
     c                   endif

     c                   eval      *inlr = *on




    RPGLE  - Retrieve IP with RPGLE
Posted By: JimmyOctane   Contact

H DFTACTGRP(*NO) BNDDIR('QC2LE')

     D GetIpAdr        PR            20a
     D  Device                       10a   CONST
      *
     D I_Net_Adr       S             16a
      *
     D                SDS
     D  Device               244    253
      *---------------------------------------------------------
      * Retrieve IP Address
     C                   Eval      I_Net_Adr   = GetIpAdr(Device)
     C                   Eval      I_Net_Adr   = %trim(I_Net_Adr)

     C     I_Net_Adr     Dsply
     C                   Eval      *Inlr = *On
      *    RtvIpAdr - Subprocedure To Get IP Address
      *---------------------------------------------------------
     P GetIpAdr        B                   Export
     D GetIpAdr        PI            20A
     D  Inp_Device                   10A   Const

     D Apierr          DS
     D  Bytprv                 1      4B 0 Inz(216)
     D  Bytavl                 5      8B 0 Inz
     D  Errorid                9     15A   Inz
     D  Reserved              16     16A   Inz
     D  ErrorDesc             17    216A   Inz

     D Net_Address     S             20A   INZ
     D Format          S              8A   Inz('DEVD0600')
     D Rcvar           S           5000A   Inz
     D Varlen          S              4B 0 Inz(5000)
     C                   Eval      Device = Inp_Device
     C                   Call      'QDCRDEVD'
     C                   Parm                    Rcvar
     C                   Parm                    Varlen
     C                   Parm                    Format
     C                   Parm                    Device
     C                   Parm                    Apierr
     C                   If        BytAvl = 0
     C                   Eval      Net_Address = %Subst(Rcvar:877:16)
     C                   Endif
     C                   Return    Net_Address
     P GetIpAdr        E


    RPGLE  - Generic template for Dynamic arrays in RPGIV
Posted By: prithviraj.D   Contact

The author of the code is Mr.Dave (Courtesy--Midrange .com)

The following text is the authors words about his code.

.....i.e Dave says
" Here is a generic program I use as a template when I'm building 
applications with dynamic arrays.  

FYI: When a ReAlloc is performed, "new" storage on the heap is allocated.
The "new" storage is initialized by the "old" storage.  The "old" storage 
is then released.The final amount of storage used is released with a DeAlloc 
or when the activation group dies.  

I hope it is what your looking for.  I'd be glad to help if you have any questions.
----- Dave  "


  *##########################################*  
                       Constants                               
  *##########################################*  
  * The size of an element in the array.                            
 D ArrayElmSize    C                   %Size(ArrayElm)              
                                                                    
  * The # of elements by which the array will be incremented        
  * each time memory is allocated.                                  

 D ArrayIncAmt     C                   5                            
  *###########################################*  
                    Data Structures                           
  *###########################################*  
  * Because the array is based, the compiler reserves no space      
  * for it at all and assumes you know what you are doing with      
  * the pointer ArrayPtr.                                           
  * If a variable is based, it means that it doesn't have any memory
  * dedicated to it - it isn't fixed at a specific address.         
  * It will be at wherever its 'basing pointer' is set to.          
  *######################################################*  
 D ArrayElm        DS                                               
 D   Name                        25                                 
 D   Address                     25                                 
                                                                    
  *############################################*  
              StandAlone Fields                          
  *############################################*  
 D Array           S                   Like(ArrayElm) Dim(32767)    
 D                                     Based(ArrayPtr)              
  * The current # of elements in the array.                         
 D Array#ofElm     S             10  0                              
                                                                    
  * The array index.                                                
 D ArrayIndex      S              5  0                              
                                                                    
  * The index of the last element of the array.                     
 D ArrayLastElm    S              5  0                              
  * The current # of elements in the array.                         
 D ArrayPtr        S               *                                
  * The current # of bytes of storage allocated to the array.       
 D ArrayStorage    S             10  0                              
  *##############################################* 
  *             Allocate initial storage for the array.             
  *##############################################* 
 C                   Eval      ArrayLastElm = 0                     
 C                   Eval      ArrayPtr = *Null                     
 C                   Eval      Array#ofElm = ArrayIncAmt    
        
 C                   Eval      ArrayStorage = Array#ofElm * ArrayElmSize 
 C                   Alloc     ArrayStorage  ArrayPtr               
    
                                                                    
    
 C                   Do        32767                                
    
                                                                    
    
 C                   If        ArrayLastElm = Array#ofElm           
    
 C                   Eval      Array#ofElm = Array#ofElm + ArrayIncAmt   
 C                   Eval      ArrayStorage = Array#ofElm * ArrayElmSize
 
 C                   ReAlloc   ArrayStorage  ArrayPtr               
    
 C                   EndIf                                          
    
                                                                    
    
 C                   Eval      ArrayLastElm = ArrayLastElm + 1      
    
 C                   Eval      Array(ArrayLastElm) = 'Who Cares'    
 
 C                   Eval      %Subst(Array(ArrayLastElm):25) = '123 Main Street' 
 C                   EndDo                                          
    
                                                                    
    
 C                   Eval      *INLR = *ON                          
     


    RPGLE  - Delay an RPG program
Posted By: prithviraj.D   Contact

PUTTING YOUR RPG PROGRAM TO SLEEP
Q: How do I insert pauses into my RPG program? In other words, how do I make 
my RPG program go to sleep for a while?

A: The easiest way is to sing it a lullaby. There are a few other ways, 
however.

You can use the Execute Command (QCMDEXC) API to run the DLYJOB command:

     D qcmdexc         pr                  ExtPgm('QCMDEXC')
     D   command                   3000A   const options(*varsize)
     D   length                      15P 5 const

      * wait for 5 seconds before continuing:
      *
     c                   callp     qcmdexc('DLYJOB DLY(5)': 13)

One nice thing about the DLYJOB command is that it can resume at a given 
time:

     D qcmdexc         pr                  ExtPgm('QCMDEXC')
     D   command                   3000A   const options(*varsize)
     D   length                      15P 5 const

      * wait until 02:17 before continuing:
      *
     c                   callp     qcmdexc('DLYJOB RSMTIME(021700)': 22)

The sleep() API is nice because the source code is both shorter and easier 
to read:

     H DFTACTGRP(*NO)

     D sleep           PR            10I 0 extproc('sleep')
     D   seconds                     10U 0 value

     c                   callp     sleep(10)

Sometimes you want to pause for less than a second, especially if you're 
doing an animation such as scrolling text or graphics. The usleep() API 
let's you specify your delay time in microseconds:

     H DFTACTGRP(*NO)

     D usleep          PR            10I 0 extproc('usleep')
     D   seconds                     10U 0 value

      * Note, usleep works with microseconds (one millionth of a second)
      *  so the following equates to one half of a second:

     c                   callp     usleep(500000)

The select() API (which is usually used in sockets programming) can also be 
used to put your program to sleep. One advantage of select() is that you can 
specify both whole seconds and fractional seconds in the same call:

     H DFTACTGRP(*NO)

     D select          PR            10I 0 extproc('select')
     D   max_fds                     10I 0 value
     D   read_set                      *   value
     D   write_set                     *   value
     D   excp_set                      *   value
     D   timeout                       *   value

     D timeval         ds
     D   tv_sec                      10I 0
     D   tv_usec                     10I 0

      *
      * tv_sec  = number of seconds
      * tv_usec = number of microseconds (one millionth of a second)
      *
      *   the following waits for 4.5 seconds:
      *

     c                   eval      tv_sec = 4
     c                   eval      tv_usec = 500000

     c                   callp     select(0: *NULL: *NULL: *NULL:
     c                                    %addr(timeval))



    RPGLE  - Data structures, Arrays and OVERLAY
Posted By: JimmyOctane   Contact

Those of you who have been using RPG IV for a while may not have noticed
that additional function has been added to the OVERLAY keyword. It is now
possible to specify the name of a data structure as the “parent” as you can see
in the following example:
D DayData DS
D 9A Inz('Monday')
D 9A Inz('Tuesday')
D 9A Inz('Wednesday')
D 9A Inz('Thursday')
D 9A Inz('Friday')
D 9A Inz('Saturday')
D 9A Inz('Sunday')
D DayName 9A Dim(7) Overlay(DayData)


    RPGLE  - Determine day of the week - subprocedure
Posted By: JimmyOctane   Contact

* Prototype for subprocedure 


D DayOfWeek PR 1 0
D InputDate D Datfmt(*ISO)
 * Days of the week name table -  note ield names are required
D NameData DS
D 9 Inz('Monday')
D 9 Inz('Tuesday')
D 9 Inz('Wednesday')
D 9 Inz('Thursday')
D 9 Inz('Friday')
D 9 Inz('Saturday')
D 9 Inz('Sunday')

 * Define the array as an overlay of the DS name

D Name 9 Dim(7) Overlay(NameData)
D DayName S 9
D WorkDate S D DatFmt(*ISO)

 * Program input parameter

C *Entry PList
C Parm WorkDate
 
* Using DayofWeek, initialize DayName with table Name 5

C Eval DayName = Name(DayOfWeek(WorkDate))

 * displaying result

C DayName Dsply

 * Terminate Program
C Eval *InLR = *On
 
 * SubProcedure: DayOfWeek (Day of the Week)
 * The subprocedure accepts a valid date (format *ISO) and returns
 * a number (1 digit) representing the day of the week
 * (Monday = 1, ... , Sunday = 7) 2

P DayOfWeek B

 * procedure interface definition 3

D DayOfWeek PI 1 0
D WorkDate D
D AnySunday C D'1999-06-13'
D WorkNum S 7 0
D WorkDay S 1 0
C WorkDate Subdur AnySunday WorkNum:*D
C WorkNum Div 7 WorkNum
C Mvr WorkDay

 * Returning result to the calling procedure

C If WorkDay < 1
C Return WorkDay + 7
C Else
C Return WorkDay
C Endif
 
* Procedure definition end marker 2
P E


    RPGLE  - This service program is a simple implementation of the Luhn MOD 10 algorithm which is often used to verify credit card numbers.
Posted By: Craig Caulfield   Contact

H DatFmt(*ISO) Option(*NoDebugIO) NoMain Debug(*Yes)

      *  Object ID  : LUHNSRV
      *
      *  Date       : 28 January 2004
      *
      *  Programmer : Craig Caulfield
      *
      *  Description: Verifies a number according to the standard
      *               Luhn MOD 10 algorithm. If the procedure
      *               returns 0, the incoming number conforms to
      *               the algorithm. For any other return value,
      *               the number isn't valid.
      *                    
      *               To create this service program:
      *                    
      *               CRTRPGMOD MODULE(LUHNSRV)     
      *               CRTSRVPGM SRVPGM(LUHNSRV) EXPORT(*ALL)     


      * Prototype for the procedure LuhnAlgorithm

     D LuhnAlgorithm   PR             1  0
     D incomingNum                   24A   value
                          
      /eject

     P LuhnAlgorithm   B                   export

     D LuhnAlgorithm   PI             1  0
     D incomingNum                   24A   value

      * Local fields
     D index           S              3  0
     D multiplier      S              3  0 inz(1)
     D workingNumber   S              3  0
     D workingLuhn     S              3  0

      /free

        for index = %len(%trim(incomingNum)) downto 1 by 1;

           workingNumber = %dec(%subst(incomingNum:index:1):3:0)
                            * multiplier;

           if workingNumber >= 10;

              workingLuhn += workingNumber - 9;

           else;

              workingLuhn += workingNumber;

           endIf;

           multiplier = 3 - multiplier;

        endFor;

        return %rem(workingLuhn : 10);

      /end-free

     P LuhnAlgorithm   E 


    RPGLE  - Scan memory (or userspace) for a given string
Posted By: prithiviraj.D   Contact

*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  ScanSpc():  Scan memory (or userspace) for a given string
      *
      *       Space = pointer to area of memory or user space to scan
      *      String = string to search for
      *     SpcSize = size of space to search
      *
      *  Returns 0 if nothing found, otherwise the position of the
      *             string in the space.
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P ScanSpc         B
     D ScanSpc         PI            10I 0
     D   Space                         *   value
     D   String                     256A   const varying options(*varsize)
     D   SpcSize                     10I 0 value

      * memchr(): Search memory for a character
     D memchr          PR              *   extproc('memchr')
     D   buf                           *   value
     D   chartofind                  10I 0 value
     D   bufsize                     10I 0 value

      * memcmp(): Compare two areas of memory
     D memcmp          PR            10I 0 extproc('memcmp')
     D   buf1                          *   value
     D   buf2                     65535A   const options(*varsize)
     D   size                        10I 0 value

     D                 DS
     D  Char                          1A
     D  Num                           3U 0 overlay(Char)

     D p_search        s               *
     D p_found         s               *

      /free

           if (%len(String) < 1);
              return 0;
           endif;

           Char = %subst(String: 1: 1);

           p_search = Space;

           dou (memcmp(p_found: String: %len(String)) = 0);
               p_found = memchr(p_search: Num: SpcSize);
               if (p_found = *NULL);
                  return 0;
               endif;
               p_search = p_found + 1;
           enddo;

           return (p_found - space) + 1;

      /end-free
     P                 E
 


    RPGLE  - CALENDAR
Posted By: Devendra Kumar R   Contact

**********************************************************************
      *                                                                    *
     ‚*  Program Name  : CALENDAR                                          *
     ‚*  Function      : To Select date.                                   *
      *                                                                    *
      **********************************************************************
      * šLogic         :€It Uses output fields to display the date.        *
      *                  1. Current date is obtained from system           *
      *                  2. For the current month, the first day of        *
      *                     of the month and no. of days in the month      *
      *                     is calculated.                                 *
      *                  3. Using this the datastructure is populated      *
      *                     then this value is copied to the display       *
      *                     fields.                                        *
      **********************************************************************

     ‚* Header Specifications
     ‚* =====================
      *
     H DFTACTGRP(*NO)

     ‚* Files Used
     ‚* ==========
      *
     š* Display file - Calendar
     FCALENDARFMCF   E             WORKSTN

     ‚* Procedures Used
     ‚* ===============
      *
     š* To get the day of the week
     D GetDay          PR             1  0
     D  Date                           D   Value
      *
     š* To get No of days in a month
     D GetDate         PR             2  0
     D  Date                           D   Value
      *
     š* This will return the month(Text) for the numeric passed.
     D GetMonth        PR             9
     D  Month                         2  0 Value

     ‚* Data Structures Used
     ‚* ====================
      *
     š* This DS is for Finding first day of the month.
     D Date_DS_1       DS
     D  DS_1_Date                      D   DATFMT(*USA) INZ
     D  DS_1_MM                       2S 0 OVERLAY(DS_1_Date:1)
     D  DS_1_DD                       2S 0 OVERLAY(DS_1_Date:4) inz(1)
     D  DS_1_YYYY                     4S 0 OVERLAY(DS_1_Date:7)
      *
     š* This DS will hold current date values.
     D Date_DS_2       DS
     D  DS_2_Date                      D   DATFMT(*USA) INZ
     D  DS_2_MM                       2S 0 OVERLAY(DS_2_Date:1) inz(5)
     D  DS_2_DD                       2S 0 OVERLAY(DS_2_Date:4) inz(31)
     D  DS_2_YYYY                     4S 0 OVERLAY(DS_2_Date:7) inz(2003)

     ‚* Variables Used
     ‚* ==============
      *
     D FirstDay        S              1  0
     D CurrDay         S              1  0
     D MaxDate         S              2  0
     D LiveMonth       S              2  0
     D LiveDate        S              2  0
     D LiveYear        S              4  0
      *
     D Dates           S              2    DIM(37)
     D Count           S              2  0
     D Temp            S              2  0
     D I               S              2  0
     D Selected        S               N   Inz(*Off)
     D Res             S              1

      **********************************************************************
     ‚*                 M A I N L I N E   P R O C E S S I N G              *
      **********************************************************************

     ˜* Exfmt the Calendar display till F3 or a date is Selected
     C                   DoW       Selected = *Off And *IN03 = *Off

     ˜* This calculates the date as per the (M+ or M-) and (Y+ or Y-)
     ˜* Triggered by the user and restores the display.
     C                   Select
     C                   When      OptYearM  = 1
     C                   Eval      DS_2_Date = DS_2_Date - %Years(1)
     C                   MoveA     '0010'        *In(41)
     C                   When      OptMonthM = 1
     C                   Eval      DS_2_Date = DS_2_Date - %Months(1)
     C                   MoveA     '1000'        *In(41)
     C                   When      OptMonthP = 1
     C                   Eval      DS_2_Date = DS_2_Date + %Months(1)
     C                   MoveA     '0100'        *In(41)
     C                   When      OptYearP  = 1
     C                   Eval      DS_2_Date = DS_2_Date + %Years(1)
     C                   MoveA     '0001'        *In(41)
     C                   EndSl

     ˜* Assigns the current values to the Datastructure one
     ˜* so that the maximum no of days and first day of the month
     ˜* is calculated.
     C                   Eval      Count = 0
     C                   Eval      DS_1_MM   = DS_2_MM
     C                   Eval      DS_1_YYYY = DS_2_YYYY

     ˜* This gets the first day of the month
     C                   Eval      FirstDay = GetDay(DS_1_Date)

     ˜* This gets the Current day (Today)
     C                   Eval      CurrDay = GetDay(DS_2_Date)

     ˜* This gets the no of days in the month
     C                   Eval      MaxDate  = GetDate(DS_1_Date)

     ˜* This gets the month(Text) of the month so that it can
     ˜* be displayed on the DSPF
     C                   Eval      Month = getMonth(DS_2_MM)
     C                   Move      DS_2_YYYY     Year

     ˜* This Subroutine populates the Datastructure for the Current
     ˜* Selection(Month and Year)
     C                   ExSr      InitDates

     ˜* This Turns the required indicators for display
     C                   ExSr      SetIndicators

     ˜* This assigns the values from the datastructure to the DSPF fields
     C                   ExSr      SetValues

     ˜* Displays the Calendar for the Current month and Year Selection
     C                   ExFmt     CALENDAR

     ˜* If user strikes Enter key apart from F3 then we have to see
     ˜* whether user has chosed any date.
     C                   If        *In03 = *Off
     C                   ExSr      CheckSel
     C                   EndIf
     C                   EndDo

     C                   If        Selected = *On
     C                   Move      Dates(I)      DS_2_DD
     C     DS_2_Date     Dsply                   Res
     C                   EndIf

     C                   Eval      *inlr = *on

      **********************************************************************
     ‚*    *INZSR        ==> Initialize Sub-Routine                        *
      **********************************************************************
     C     *INZSR        BegSr

     ˜* Current date is retrieved for initial display
     C                   Eval      DS_2_Date = %Date()
     C                   Eval      LiveMonth = DS_2_MM
     C                   Eval      LiveYear  = DS_2_YYYY
     C                   Eval      LiveDate  = DS_2_DD

     ˜* This frames the string which is displayed at the bottom
     C                   Eval      OutPut = %Char(LiveDate)   + ' ' +
     C                             %Trim(getMonth(LiveMonth)) + ', ' +
     C                             %Char(LiveYear)

     C                   Eval      *In41 = *On

     C                   EndSr

      **********************************************************************
     ‚*    InitDates     ==> Initialize the Datastructure                  *
     ‚*                      For Eg. consider the date September 2003      *
     ‚*                      1. The month has got 30 days                  *
     ‚*                      2. First day is Monday                        *
     ‚*                      Hence the DS is populated as follows:         *
     ‚*                        --> DS(1) = *Blanks                         *
     ‚*                        --> DS(2) = '1'                             *
     ‚*                        --> DS(3) = '2' .....                       *
     ‚*                        --> DS(32)= '30'                            *
     ‚*                        --> DS(33)= *Blanks .....                   *
     ‚*                        --> DS(37)= *Blanks                         *
      **********************************************************************
     C     InitDates     BegSr

     C                   Clear                   Dates

     C                   Eval      Temp = MaxDate + FirstDay

     C                   For       I = 1 to 37

     C                   Select
     C                   When      I <= FirstDay Or I > Temp
     C                   Eval      Dates(I) = *BLANKS
     C                   When      I > FirstDay And I <= Temp
     C                   Eval      Count = Count + 1
     C                   Move      Count         Dates(I)
     C                   EndSl

     C                   EndFor

     C                   EndSr

      **********************************************************************
     ‚*    SetIndicators ==> Turn Reqd. Indicators for display             *
      **********************************************************************
     C     SetIndicators BegSr

     C                   For       I = 50 to 56
     C                   Eval      *In(I) = *Off
     C                   EndFor

     C                   For       I = 60 to 96
     C                   Eval      *In(I) = *Off
     C                   EndFor

     C                   If        LiveMonth = DS_2_MM And
     C                             LiveYear  = DS_2_YYYY
     C                   Eval      *In(50 + CurrDay) = *On
     C                   Eval      *In(60 + LiveDate + FirstDay - 1) = *On
     C                   EndIf

     C                   EndSr

      **********************************************************************
     ‚*    SetValues     ==> Copies the DS to DSPF fields                  *
      **********************************************************************
     C     SetValues     BegSr

     C                   Move      Dates(1)      SET1
     C                   Move      Dates(2)      SET2
     C                   Move      Dates(3)      SET3
     C                   Move      Dates(4)      SET4
     C                   Move      Dates(5)      SET5
     C                   Move      Dates(6)      SET6
     C                   Move      Dates(7)      SET7

     C                   Move      Dates(8)      SET8
     C                   Move      Dates(9)      SET9
     C                   Move      Dates(10)     SET10
     C                   Move      Dates(11)     SET11
     C                   Move      Dates(12)     SET12
     C                   Move      Dates(13)     SET13
     C                   Move      Dates(14)     SET14

     C                   Move      Dates(15)     SET15
     C                   Move      Dates(16)     SET16
     C                   Move      Dates(17)     SET17
     C                   Move      Dates(18)     SET18
     C                   Move      Dates(19)     SET19
     C                   Move      Dates(20)     SET20
     C                   Move      Dates(21)     SET21

     C                   Move      Dates(22)     SET22
     C                   Move      Dates(23)     SET23
     C                   Move      Dates(24)     SET24
     C                   Move      Dates(25)     SET25
     C                   Move      Dates(26)     SET26
     C                   Move      Dates(27)     SET27
     C                   Move      Dates(28)     SET28

     C                   Move      Dates(29)     SET29
     C                   Move      Dates(30)     SET30
     C                   Move      Dates(31)     SET31
     C                   Move      Dates(32)     SET32
     C                   Move      Dates(33)     SET33
     C                   Move      Dates(34)     SET34
     C                   Move      Dates(35)     SET35

     C                   Move      Dates(36)     SET36
     C                   Move      Dates(37)     SET37

     C                   EndSr

      **********************************************************************
     ‚*    CheckSel      ==> Checks whether user has msde any selection    *
      **********************************************************************
     C     CheckSel      BegSr

     C                   For       I = 1 to 37
     C                   If        FLD = 'SET'+ %Char(I) and
     C                             Dates(I) <> *Blanks
     C                   Eval      Selected = *ON
     C                   Leave
     C                   EndIf
     C                   EndFor

     C                   EndSr

      **********************************************************************
     ‚*    GetDay        ==> This returns the day of the Date              *
     ‚*                      The logic implemented is:                     *
     ‚*                      %Rem(((Date) - (Standard Date)) / 7)          *
     ‚*                      The Standard date will be any Reference       *
     ‚*                      Day. If the reminder is Zero then the         *
     ‚*                      current day is standard day. If it is         *
     ‚*                      '1' then its monday like so...                *
      **********************************************************************
     P GetDay          B

     D  GetDay         PI             1  0
     D   Date                          D   Value

     D  Days           S             15P 0
     D  Day            S              1  0
     D  Sunday         C                   D'1999-12-19'

     C     Date          SubDur    Sunday        Days:*DAYS
     C                   Eval      Day = %Rem(Days:7)
     C                   If        Day < 0
     C                   Eval      Day = Day + 7
     C                   EndIf

     C                   Return    Day

     P                 E

      **********************************************************************
     ‚*    GetDay        ==> This returns the no of days in the month      *
     ‚*                      The logic implemented is:                     *
     ‚*                      Difference between Current date and           *
     ‚*                      (Current Date + One Month) in No of Days      *
      **********************************************************************
     P GetDate         B

     D  GetDate        PI             2  0
     D   Date                          D   Value

     D   Date1         S               D

     C                   Eval      Date1 = Date + %Months(1)
     C                   Return    %Diff(Date1:Date:*D)

     P                 E

      **********************************************************************
     ‚*    GetMonth      ==> This returns the Month in Text for the        *
     ‚*                      Numeric passed                                *
      **********************************************************************
     P GetMonth        B

     D  GetMonth       PI             9
     D   Month                        2  0 VALUE

     C                   Select
     C                   When      Month = 01
     C                   Return    'January'
     C                   When      Month = 02
     C                   Return    'February'
     C                   When      Month = 03
     C                   Return    'March'
     C                   When      Month = 04
     C                   Return    'April'
     C                   When      Month = 05
     C                   Return    'May'
     C                   When      Month = 06
     C                   Return    'June'
     C                   When      Month = 07
     C                   Return    'July'
     C                   When      Month = 08
     C                   Return    'August'
     C                   When      Month = 09
     C                   Return    'September'
     C                   When      Month = 10
     C                   Return    'October'
     C                   When      Month = 11
     C                   Return    'November'
     C                   When      Month = 12
     C                   Return    'December'
     C                   Other
     C                   Return    ' '
     C                   EndSl

     P                 E


**======================================================
                                              D  D  S
**======================================================


A*%%TS  SD  20030717  173714  USC2643     REL-V5R1M0  5722-WDS
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      CF03(03 'EXIT')
     A                                      MOUBTN(*ULP ENTER)
     A          R CALENDAR
     A*%%TS  SD  20030717  173714  USC2643     REL-V5R1M0  5722-WDS
     A                                      WINDOW(7 25 14 35)
     A                                      RTNCSRLOC(&REC &FLD)
     A            FLD           10A  H
     A            REC           10A  H
     A                                  1 14'Calendar'
     A                                      DSPATR(BL)
     A                                      DSPATR(HI)
     A                                  2  2'Month. .:'
     A                                      COLOR(BLU)
     A                                  3  2'Year. . :'
     A                                      COLOR(BLU)
     A            YEAR           4A  O  3 12COLOR(TRQ)
     A                                  5  2'SUN'
     A N50                                  COLOR(YLW)
     A  50                                  COLOR(WHT)
     A                                  5  7'MON'
     A N51                                  COLOR(BLU)
     A  51                                  COLOR(WHT)
     A                                  5 12'TUE'
     A N52                                  COLOR(BLU)
     A  52                                  COLOR(WHT)
     A                                  5 17'WED'
     A N53                                  COLOR(BLU)
     A  53                                  COLOR(WHT)
     A                                  5 22'THU'
     A N54                                  COLOR(BLU)
     A  54                                  COLOR(WHT)
     A                                  5 27'FRI'
     A N55                                  COLOR(BLU)
     A  55                                  COLOR(WHT)
     A                                  5 32'SAT'
     A N56                                  COLOR(YLW)
     A  56                                  COLOR(WHT)
     A            SET1           2A  O  6  3
     A N60                                  COLOR(YLW)
     A  60                                  COLOR(WHT)
     A            SET2           2A  O  6  8
     A N61                                  COLOR(GRN)
     A  61                                  COLOR(WHT)
     A            SET3           2A  O  6 13
     A N62                                  COLOR(GRN)
     A  62                                  COLOR(WHT)
     A            SET4           2A  O  6 18
     A N63                                  COLOR(GRN)
     A  63                                  COLOR(WHT)
     A            SET5           2A  O  6 23
     A N64                                  COLOR(GRN)
     A  64                                  COLOR(WHT)
     A            SET6           2A  O  6 28
     A N65                                  COLOR(GRN)
     A  65                                  COLOR(WHT)
     A            SET7           2A  O  6 33
     A N66                                  COLOR(YLW)
     A  66                                  COLOR(WHT)
     A            SET8           2A  O  7  3
     A N67                                  COLOR(YLW)
     A  67                                  COLOR(WHT)
     A            SET9           2A  O  7  8
     A N68                                  COLOR(GRN)
     A  68                                  COLOR(WHT)
     A            SET15          2A  O  8  3
     A N74                                  COLOR(YLW)
     A  74                                  COLOR(WHT)
     A            SET16          2A  O  8  8
     A N75                                  COLOR(GRN)
     A  75                                  COLOR(WHT)
     A            SET22          2A  O  9  3
     A N81                                  COLOR(YLW)
     A  81                                  COLOR(WHT)
     A            SET23          2A  O  9  8
     A N82                                  COLOR(GRN)
     A  82                                  COLOR(WHT)
     A            SET29          2A  O 10  3
     A N88                                  COLOR(YLW)
     A  88                                  COLOR(WHT)
     A            SET30          2A  O 10  8
     A N89                                  COLOR(GRN)
     A  89                                  COLOR(WHT)
     A            SET36          2A  O 11  3
     A N95                                  COLOR(YLW)
     A  95                                  COLOR(WHT)
     A            SET37          2A  O 11  8
     A N96                                  COLOR(GRN)
     A  96                                  COLOR(WHT)
     A            SET10          2A  O  7 13
     A N69                                  COLOR(GRN)
     A  69                                  COLOR(WHT)
     A            SET11          2A  O  7 18
     A N70                                  COLOR(GRN)
     A  70                                  COLOR(WHT)
     A            SET12          2A  O  7 23
     A N71                                  COLOR(GRN)
     A  71                                  COLOR(WHT)
     A            SET13          2A  O  7 28
     A N72                                  COLOR(GRN)
     A  72                                  COLOR(WHT)
     A            SET14          2A  O  7 33
     A N73                                  COLOR(YLW)
     A  73                                  COLOR(WHT)
     A            SET17          2A  O  8 13
     A N76                                  COLOR(GRN)
     A  76                                  COLOR(WHT)
     A            SET18          2A  O  8 18
     A N77                                  COLOR(GRN)
     A  77                                  COLOR(WHT)
     A            SET19          2A  O  8 23
     A N78                                  COLOR(GRN)
     A  78                                  COLOR(WHT)
     A            SET20          2A  O  8 28
     A N79                                  COLOR(GRN)
     A  79                                  COLOR(WHT)
     A            SET21          2A  O  8 33
     A N80                                  COLOR(YLW)
     A  80                                  COLOR(WHT)
     A            SET24          2A  O  9 13
     A N83                                  COLOR(GRN)
     A  83                                  COLOR(WHT)
     A            SET25          2A  O  9 18
     A N84                                  COLOR(GRN)
     A  84                                  COLOR(WHT)
     A            SET26          2A  O  9 23
     A N85                                  COLOR(GRN)
     A  85                                  COLOR(WHT)
     A            SET27          2A  O  9 28
     A N86                                  COLOR(GRN)
     A  86                                  COLOR(WHT)
     A            SET28          2A  O  9 33
     A N87                                  COLOR(YLW)
     A  87                                  COLOR(WHT)
     A            SET31          2A  O 10 13
     A N90                                  COLOR(GRN)
     A  90                                  COLOR(WHT)
     A            SET32          2A  O 10 18
     A N91                                  COLOR(GRN)
     A  91                                  COLOR(WHT)
     A            SET33          2A  O 10 23
     A N92                                  COLOR(GRN)
     A  92                                  COLOR(WHT)
     A            SET34          2A  O 10 28
     A N93                                  COLOR(GRN)
     A  93                                  COLOR(WHT)
     A            SET35          2A  O 10 33
     A N94                                  COLOR(YLW)
     A  94                                  COLOR(WHT)
     A            OUTPUT        25A  O 13  2COLOR(PNK)
     A            OPTMONTHM      2Y 0B  2 24PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
     A  41                                  DSPATR(PC)
     A                                      PSHBTNCHC(1 '-')
     A            OPTMONTHP      2Y 0B  2 29PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
     A  42                                  DSPATR(PC)
     A                                      PSHBTNCHC(1 '+')
     A            OPTYEARM       2Y 0B  3 24PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
     A  43                                  DSPATR(PC)
     A                                      PSHBTNCHC(1 '-')
     A            OPTYEARP       2Y 0B  3 29PSHBTNFLD((*NUMCOL 2) (*GUTTER 2))
     A  44                                  DSPATR(PC)
     A                                      PSHBTNCHC(1 '+')
     A                                  4  1'__________________________________-
     A                                      _'
     A                                      COLOR(BLU)
     A                                 12  1'__________________________________-
     A                                      _'
     A                                      COLOR(BLU)
     A            MONTH          9A  O  2 12COLOR(TRQ)
     A          R DUMMY
     A                                      KEEP
     A                                      ASSUME
     A                                  1  3' '





    RPGLE  - Clock Got ti of the FlyByNight Software Website NICE
Posted By: Rakesh   Contact

/*************************************************************           + 
      **                                                                      + 
      ** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» + 
      ** «» FlyByNight Software         AS/400 Technical Specialists       «» + 
      ** «» Eclipse the competition - run your business on an IBM AS/400.  «» + 
      ** «»                                                                «» + 
      ** «» Phone: +61 3 9419 0175      Mobile: +61 0411 091 400           «» + 
      ** «» Fax:   +61 3 9419 0175      mailto: shc@flybynight.com.au      «» + 
      ** «»                                                                «» + 
      ** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» + 
      **                                                                      + 
      ** This program started as a copy of Simon's Clock Program **           + 
      **  I appreciate his knowledge and have used it, but if    **           + 
      **  anything does not run right, that's me, not him.       **           + 
      **                    Booth Martin 2/00 booth@Martinvt.com **           + 
      **                                                         **           + 
      *************************************************************          */ 
             DCLF       FILE(CLKFIGFM) RCDFMT(*ALL)                  
                        /* Display file - digital clock            */
                                                                     
             DCL        VAR(&HR) TYPE(*CHAR) LEN(2)                  
                       /* Hour component of the time              */ 
             DCL        VAR(&MIN) TYPE(*CHAR) LEN(2)                 
                       /* Minute component of the time            */ 
             DCL        VAR(&SEC) TYPE(*CHAR) LEN(2)                 
                       /* Second component of the time            */ 
             DCL        VAR(&DAT6) TYPE(*CHAR) LEN(6)                
                       /* Current Date                            */ 
             DCL        VAR(&DOW) TYPE(*CHAR) LEN(4)                 
                       /* Current Day of week                     */ 
                                                                     
             DCL        VAR(&COL1) TYPE(*CHAR) LEN(1)                
                       /* Left component of the hour              */ 
             DCL        VAR(&COL2) TYPE(*CHAR) LEN(1)                
                       /* Right component of the hour             */ 
             DCL        VAR(&COL3) TYPE(*CHAR) LEN(1)                
                       /* Left component of the minute            */ 
             DCL        VAR(&COL4) TYPE(*CHAR) LEN(1)                 
                        /* Right component of the minute           */ 
             DCL        VAR(&COL5) TYPE(*CHAR) LEN(1)                 
                       /* Left component of the second            */  
             DCL        VAR(&COL6) TYPE(*CHAR) LEN(1)                 
                        /* Right component of the second           */ 
             DCL        VAR(&SYSNAME) TYPE(*CHAR) LEN(8)              
                                                                      
             RTVNETA    SYSNAME(&SYSNAME)                             
             CHGVAR     VAR(&TITLE) VALUE(' Official System Time +    
                          for' *BCAT &SYSNAME *CAT ' ')               
                                                                      
 AGAIN:      /* Get the current time  */                              
             RTVSYSVAL  SYSVAL(QHOUR) RTNVAR(&HR)                     
             RTVSYSVAL  SYSVAL(QMINUTE) RTNVAR(&MIN)                  
             RTVSYSVAL  SYSVAL(QSECOND) RTNVAR(&SEC)                  
             RTVSYSVAL  SYSVAL(QDATE) RTNVAR(&DAT6)                   
             RTVSYSVAL  SYSVAL(QDAYOFWEEK) RTNVAR(&DOW)               
 /* Display fields: Date, Julian date, and day-of-week */             
             CVTDAT     DATE(&DAT6) TOVAR(&JDAY) TOFMT(*JUL) TOSEP(/) 
             CVTDAT     DATE(&DAT6) TOVAR(&DAT) TOFMT(*MDY) TOSEP(/)    
             IF         COND(&DOW = '*SUN') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('   Sunday'))                           
             IF         COND(&DOW = '*MON') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('   Monday'))                           
             IF         COND(&DOW = '*TUE') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('  Tuesday'))                           
             IF         COND(&DOW = '*WED') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('Wednesday'))                           
             IF         COND(&DOW = '*THU') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('Thursday'))                            
             IF         COND(&DOW = '*FRI') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('  Friday'))                            
             IF         COND(&DOW = '*SAT') THEN(CHGVAR VAR(&DOWEEK) +  
                          VALUE('Saturday'))                            
                                                                        
             CHGVAR     VAR(&COL1) VALUE(%SST(&HR 1 1))                 
             CHGVAR     VAR(&COL2) VALUE(%SST(&HR 2 1))                 
                                                                        
             CHGVAR     VAR(&COL3) VALUE(%SST(&MIN 1 1))                
             CHGVAR     VAR(&COL4) VALUE(%SST(&MIN 2 1))               
                                                                       
             CHGVAR     VAR(&COL5) VALUE(%SST(&SEC 1 1))               
             CHGVAR     VAR(&COL6) VALUE(%SST(&SEC 2 1))               
                                                                       
             /* Set the indicators for the left digit of the hour  */  
             /*   -- leading zero is not shown                     */  
             IF         COND(&COL1 *EQ '1') THEN(CHGVAR VAR(&IN11) +   
                          VALUE('1'))                                  
             IF         COND(&COL1 *EQ '2') THEN(CHGVAR VAR(&IN12) +   
                          VALUE('1'))                                  
                                                                       
             /* Set the indicators for the right digit of the hour */  
             IF         COND(&COL2 *EQ '0') THEN(CHGVAR VAR(&IN20) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '1') THEN(CHGVAR VAR(&IN21) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '2') THEN(CHGVAR VAR(&IN22) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '3') THEN(CHGVAR VAR(&IN23) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '4') THEN(CHGVAR VAR(&IN24) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '5') THEN(CHGVAR VAR(&IN25) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '6') THEN(CHGVAR VAR(&IN26) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '7') THEN(CHGVAR VAR(&IN27) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '8') THEN(CHGVAR VAR(&IN28) +   
                          VALUE('1'))                                  
             IF         COND(&COL2 *EQ '9') THEN(CHGVAR VAR(&IN29) +   
                          VALUE('1'))                                  
                                                                       
             /* Set the indicators for the left digit of the minute */ 
             IF         COND(&COL3 *EQ '0') THEN(CHGVAR VAR(&IN30) +   
                          VALUE('1'))                                  
             IF         COND(&COL3 *EQ '1') THEN(CHGVAR VAR(&IN31) +   
                          VALUE('1'))                                  
             IF         COND(&COL3 *EQ '2') THEN(CHGVAR VAR(&IN32) +   
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '3') THEN(CHGVAR VAR(&IN33) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '4') THEN(CHGVAR VAR(&IN34) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '5') THEN(CHGVAR VAR(&IN35) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '6') THEN(CHGVAR VAR(&IN36) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '7') THEN(CHGVAR VAR(&IN37) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '8') THEN(CHGVAR VAR(&IN38) +    
                          VALUE('1'))                                   
             IF         COND(&COL3 *EQ '9') THEN(CHGVAR VAR(&IN39) +    
                          VALUE('1'))                                   
                                                                        
             /* Set the indicators for the right digit of the minute */ 
             IF         COND(&COL4 *EQ '0') THEN(CHGVAR VAR(&IN40) +    
                          VALUE('1'))                                   
             IF         COND(&COL4 *EQ '1') THEN(CHGVAR VAR(&IN41) +    
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '2') THEN(CHGVAR VAR(&IN42) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '3') THEN(CHGVAR VAR(&IN43) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '4') THEN(CHGVAR VAR(&IN44) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '5') THEN(CHGVAR VAR(&IN45) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '6') THEN(CHGVAR VAR(&IN46) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '7') THEN(CHGVAR VAR(&IN47) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '8') THEN(CHGVAR VAR(&IN48) +   
                          VALUE('1'))                                  
             IF         COND(&COL4 *EQ '9') THEN(CHGVAR VAR(&IN49) +   
                          VALUE('1'))                                  
                                                                       
             /* Set the indicators for the left digit of the second */ 
             IF         COND(&COL5 *EQ '0') THEN(CHGVAR VAR(&IN50) +   
                         VALUE('1'))                                   
             IF         COND(&COL5 *EQ '1') THEN(CHGVAR VAR(&IN51) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '2') THEN(CHGVAR VAR(&IN52) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '3') THEN(CHGVAR VAR(&IN53) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '4') THEN(CHGVAR VAR(&IN54) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '5') THEN(CHGVAR VAR(&IN55) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '6') THEN(CHGVAR VAR(&IN56) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '7') THEN(CHGVAR VAR(&IN57) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '8') THEN(CHGVAR VAR(&IN58) +    
                          VALUE('1'))                                   
             IF         COND(&COL5 *EQ '9') THEN(CHGVAR VAR(&IN59) +    
                          VALUE('1'))                                   
                                                                       
             /* Set the indicators for the Right digit of the Second */
             IF         COND(&COL6 *EQ '0') THEN(CHGVAR VAR(&IN60) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '1') THEN(CHGVAR VAR(&IN61) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '2') THEN(CHGVAR VAR(&IN62) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '3') THEN(CHGVAR VAR(&IN63) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '4') THEN(CHGVAR VAR(&IN64) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '5') THEN(CHGVAR VAR(&IN65) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '6') THEN(CHGVAR VAR(&IN66) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '7') THEN(CHGVAR VAR(&IN67) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '8') THEN(CHGVAR VAR(&IN68) +   
                          VALUE('1'))                                  
             IF         COND(&COL6 *EQ '9') THEN(CHGVAR VAR(&IN69) +   
                          VALUE('1'))                                 
                                                                      
             /* Display the clock face                             */ 
             SNDRCVF    RCDFMT(RFIGLET) WAIT(*NO)                     
             MONMSG     MSGID(CPF0887) EXEC(DO)                       
             RCVMSG     MSGTYPE(*EXCP)                                
             RCVF                                                     
             IF         COND(&PB2 *EQ 01) THEN(WRKMSG MSGQ(*SYSOPR))  
             IF         COND(&PB2 *EQ 02) THEN(GOTO CMDLBL(AGAIN))    
             IF         COND(&PB2 *EQ 03) THEN(GOTO CMDLBL(ENDJOB))   
             IF         COND(&IN03 *EQ '1') THEN(GOTO CMDLBL(ENDJOB)) 
             IF         COND(&IN06 *EQ '1') THEN(WRKMSG MSGQ(*SYSOPR))
             ENDDO                                                    
             DLYJOB     DLY(1)                                        
                                                                      
             CHGVAR     VAR(&IN11) VALUE('0')                         
             CHGVAR     VAR(&IN12) VALUE('0')                         
             CHGVAR     VAR(&IN20) VALUE('0')                         
             CHGVAR     VAR(&IN21) VALUE('0')                         
             CHGVAR     VAR(&IN22) VALUE('0')                         
             CHGVAR     VAR(&IN23) VALUE('0') 
             CHGVAR     VAR(&IN24) VALUE('0') 
             CHGVAR     VAR(&IN25) VALUE('0') 
             CHGVAR     VAR(&IN26) VALUE('0') 
             CHGVAR     VAR(&IN27) VALUE('0') 
             CHGVAR     VAR(&IN28) VALUE('0') 
             CHGVAR     VAR(&IN29) VALUE('0') 
             CHGVAR     VAR(&IN30) VALUE('0') 
             CHGVAR     VAR(&IN31) VALUE('0') 
             CHGVAR     VAR(&IN32) VALUE('0') 
             CHGVAR     VAR(&IN33) VALUE('0') 
             CHGVAR     VAR(&IN34) VALUE('0') 
             CHGVAR     VAR(&IN35) VALUE('0') 
             CHGVAR     VAR(&IN36) VALUE('0') 
             CHGVAR     VAR(&IN37) VALUE('0') 
             CHGVAR     VAR(&IN38) VALUE('0') 
             CHGVAR     VAR(&IN39) VALUE('0') 
             CHGVAR     VAR(&IN40) VALUE('0') 
             CHGVAR     VAR(&IN41) VALUE('0') 
             CHGVAR     VAR(&IN42) VALUE('0') 
             CHGVAR     VAR(&IN43) VALUE('0')   
             CHGVAR     VAR(&IN44) VALUE('0')   
             CHGVAR     VAR(&IN45) VALUE('0')   
             CHGVAR     VAR(&IN46) VALUE('0')   
             CHGVAR     VAR(&IN47) VALUE('0')   
             CHGVAR     VAR(&IN48) VALUE('0')   
             CHGVAR     VAR(&IN49) VALUE('0')   
             CHGVAR     VAR(&IN50) VALUE('0')   
             CHGVAR     VAR(&IN51) VALUE('0')   
             CHGVAR     VAR(&IN52) VALUE('0')   
             CHGVAR     VAR(&IN53) VALUE('0')   
             CHGVAR     VAR(&IN54) VALUE('0')   
             CHGVAR     VAR(&IN55) VALUE('0')   
             CHGVAR     VAR(&IN56) VALUE('0')   
             CHGVAR     VAR(&IN57) VALUE('0')   
             CHGVAR     VAR(&IN58) VALUE('0')   
             CHGVAR     VAR(&IN59) VALUE('0')   
             CHGVAR     VAR(&IN60) VALUE('0')   
             CHGVAR     VAR(&IN61) VALUE('0')   
             CHGVAR     VAR(&IN62) VALUE('0')   
             CHGVAR     VAR(&IN63) VALUE('0')   
             CHGVAR     VAR(&IN64) VALUE('0')   
             CHGVAR     VAR(&IN65) VALUE('0')   
             CHGVAR     VAR(&IN66) VALUE('0')   
             CHGVAR     VAR(&IN67) VALUE('0')   
             CHGVAR     VAR(&IN68) VALUE('0')   
             CHGVAR     VAR(&IN69) VALUE('0')   
             GOTO       CMDLBL(AGAIN)           
                                                
ENDJOB:      ENDPGM                             
                     Display FIle
A*************************************************************           
     A**                                                                      
     A** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» 
     A** «» FlyByNight Software         AS/400 Technical Specialists       «» 
     A** «» Eclipse the competition - run your business on an IBM AS/400.  «» 
     A** «»                                                                «» 
     A** «» Phone: +61 3 9419 0175      Mobile: +61 0411 091 400           «» 
     A** «» Fax:   +61 3 9419 0175      mailto: shc@flybynight.com.au      «» 
     A** «»                                                                «» 
     A** «»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«» 
     A**                                                                      
     A** This program started as a copy of Simon's Clock Program **           
     A**  I appreciate his knowledge and have used it, but if    **           
     A**  anything does not run right, that's me, not him.       **           
     A**                   Booth Martin 2/00 Booth@MartinVT.com  **           
     A**                                                         **           
     A*************************************************************           
     A*%%FD -  clock  -                                                       
     A*%%EC                                                                   
     A                                      DSPSIZ(24 80 *DS3)        
     A          R RFIGLET                                             
     A*%%TS  SD  20000223  104532  BOOTH       REL-V4R4M0  5769-PW1   
     A                                      CF03(03 'EXIT')           
     A                                      CF06(06 'SYSOP Messages') 
     A                                      CF08(08 'Settings')       
     A                                      BLINK                     
     A                                      OVERLAY                   
     A                                      WINDOW(2 6 9 65 *NOMSGLIN)
     A                                      WDWBORDER((*COLOR WHT))   
     A                                      WDWTITLE((*TEXT &TITLE))  
     A  11                              2  1'   _    '                
     A  11                              3  1'  / |   '                
     A  11                              4  1'  | |   '                
     A  11                              5  1'  | |   '                
     A  11                              6  1'  |_|   '                
     A  12                              2  1' ____   '                
     A  12                              3  1'|___ \  '                
     A  12                              4  1'  __) | '                
     A  12                              5  1' / __/  '                
     A  12                              6  1'|_____| '       
     A  21                              2 10'   _    '       
     A  21                              3 10'  / |   '       
     A  21                              4 10'  | |   '       
     A  21                              5 10'  | |   '       
     A  21                              6 10'  |_|   '       
     A  22                              2 10' ____   '       
     A  22                              3 10'|___ \  '       
     A  22                              4 10'  __) | '       
     A  22                              5 10' / __/  '       
     A  22                              6 10'|_____| '       
     A  23                              2 10' _____  '       
     A  23                              3 10'|___ /  '       
     A  23                              4 10'  |_ \  '       
     A  23                              5 10' ___) | '       
     A  23                              6 10'|____/  '       
     A  24                              2 10' _  _   '       
     A  24                              3 10'| || |  '       
     A  24                              4 10'| || |_ '       
     A  24                              5 10'|__   _|'       
     A  24                              6 10'   |_|  '  
     A  25                              2 10' ____   '  
     A  25                              3 10'| ___|  '  
     A  25                              4 10'|___ \  '  
     A  25                              5 10' ___) | '  
     A  25                              6 10'|____/  '  
     A  26                              2 10'  __    '  
     A  26                              3 10' / /_   '  
     A  26                              4 10'|  _ \  '  
     A  26                              5 10'| (_) | '  
     A  26                              6 10' \___/  '  
     A  27                              2 10' _____  '  
     A  27                              3 10'|___  | '  
     A  27                              4 10'   / /  '  
     A  27                              5 10'  / /   '  
     A  27                              6 10' /_/    '  
     A  28                              2 10'  ___   '  
     A  28                              3 10' ( _ )  '  
     A  28                              4 10' / _ \  '  
     A  28                              5 10'| (_) | '  
     A  28                              6 10' \___/  '  
     A  29                              2 10'  ___   '  
     A  29                              3 10' / _ \  '  
     A  29                              4 10'| (_) | '  
     A  29                              5 10' \__, | '  
     A  29                              6 10'   /_/  '  
     A  20                              2 10'  ___   '  
     A  20                              3 10' / _ \  '  
     A  20                              4 10'| | | | '  
     A  20                              5 10'| |_| | '  
     A  20                              6 10' \___/  '  
     A  31                              2 25'   _    '  
     A  31                              3 25'  / |   '  
     A  31                              4 25'  | |   '  
     A  31                              5 25'  | |   '  
     A  31                              6 25'  |_|   '  
     A  32                              2 25' ____   '  
     A  32                              3 25'|___ \  '  
     A  32                              4 25'  __) | '  
     A  32                              5 25' / __/  '  
     A  32                              6 25'|_____| '   
     A  33                              2 25' _____  '   
     A  33                              3 25'|___ /  '   
     A  33                              4 25'  |_ \  '   
     A  33                              5 25' ___) | '   
     A  33                              6 25'|____/  '   
     A  34                              2 25' _  _   '   
     A  34                              3 25'| || |  '   
     A  34                              4 25'| || |_ '   
     A  34                              5 25'|__   _|'   
     A  34                              6 25'   |_|  '   
     A  35                              2 25' ____   '   
     A  35                              3 25'| ___|  '   
     A  35                              4 25'|___ \  '   
     A  35                              5 25' ___) | '   
     A  35                              6 25'|____/  '   
     A  36                              2 25'  __    '   
     A  36                              3 25' / /_   '   
     A  36                              4 25'|  _ \  '   
     A  36                              5 25'| (_) | '   
     A  36                              6 25' \___/  '  
     A  37                              2 25' _____  '  
     A  37                              3 25'|___  | '  
     A  37                              4 25'   / /  '  
     A  37                              5 25'  / /   '  
     A  37                              6 25' /_/    '  
     A  38                              2 25'  ___   '  
     A  38                              3 25' ( _ )  '  
     A  38                              4 25' / _ \  '  
     A  38                              5 25'| (_) | '  
     A  38                              6 25' \___/  '  
     A  39                              2 25'  ___   '  
     A  39                              3 25' / _ \  '  
     A  39                              4 25'| (_) | '  
     A  39                              5 25' \__, | '  
     A  39                              6 25'   /_/  '  
     A  30                              2 25'  ___   '  
     A  30                              3 25' / _ \  '  
     A  30                              4 25'| | | | '  
     A  30                              5 25'| |_| | '  
     A  30                              6 25' \___/  '    
     A  41                              2 34'   _    '    
     A  41                              3 34'  / |   '    
     A  41                              4 34'  | |   '    
     A  41                              5 34'  | |   '    
     A  41                              6 34'  |_|   '    
     A  42                              2 34' ____   '    
     A  42                              3 34'|___ \  '    
     A  42                              4 34'  __) | '    
     A  42                              5 34' / __/  '    
     A  42                              6 34'|_____| '    
     A  43                              2 34' _____  '    
     A  43                              3 34'|___ /  '    
     A  43                              4 34'  |_ \  '    
     A  43                              5 34' ___) | '    
     A  43                              6 34'|____/  '    
     A  44                              2 34' _  _   '    
     A  44                              3 34'| || |  '    
     A  44                              4 34'| || |_ '    
     A  44                              5 34'|__   _|'    
     A  44                              6 34'   |_|  '    
     A  45                              2 34' ____   '    
     A  45                              3 34'| ___|  '    
     A  45                              4 34'|___ \  '    
     A  45                              5 34' ___) | '    
     A  45                              6 34'|____/  '    
     A  46                              2 34'  __    '    
     A  46                              3 34' / /_   '    
     A  46                              4 34'|  _ \  '    
     A  46                              5 34'| (_) | '    
     A  46                              6 34' \___/  '    
     A  47                              2 34' _____  '    
     A  47                              3 34'|___  | '    
     A  47                              4 34'   / /  '    
     A  47                              5 34'  / /   '    
     A  47                              6 34' /_/    '    
     A  48                              2 34'  ___   '    
     A  48                              3 34' ( _ )  '    
     A  48                              4 34' / _ \  '    
     A  48                              5 34'| (_) | '    
     A  48                              6 34' \___/  '     
     A  49                              2 34'  ___   '     
     A  49                              3 34' / _ \  '     
     A  49                              4 34'| (_) | '     
     A  49                              5 34' \__, | '     
     A  49                              6 34'   /_/  '     
     A  40                              2 34'  ___   '     
     A  40                              3 34' / _ \  '     
     A  40                              4 34'| | | | '     
     A  40                              5 34'| |_| | '     
     A  40                              6 34' \___/  '     
     A  51                              2 49'   _    '     
     A  51                              3 49'  / |   '     
     A  51                              4 49'  | |   '     
     A  51                              5 49'  | |   '     
     A  51                              6 49'  |_|   '     
     A  52                              2 49' ____   '     
     A  52                              3 49'|___ \  '     
     A  52                              4 49'  __) | '     
     A  52                              5 49' / __/  '     
     A  52                              6 49'|_____| '   
     A  53                              2 49' _____  '   
     A  53                              3 49'|___ /  '   
     A  53                              4 49'  |_ \  '   
     A  53                              5 49' ___) | '   
     A  53                              6 49'|____/  '   
     A  54                              2 49' _  _   '   
     A  54                              3 49'| || |  '   
     A  54                              4 49'| || |_ '   
     A  54                              5 49'|__   _|'   
     A  54                              6 49'   |_|  '   
     A  55                              2 49' ____   '   
     A  55                              3 49'| ___|  '   
     A  55                              4 49'|___ \  '   
     A  55                              5 49' ___) | '   
     A  55                              6 49'|____/  '   
     A  56                              2 49'  __    '   
     A  56                              3 49' / /_   '   
     A  56                              4 49'|  _ \  '   
     A  56                              5 49'| (_) | '   
     A  56                              6 49' \___/  '    
     A  57                              2 49' _____  '    
     A  57                              3 49'|___  | '    
     A  57                              4 49'   / /  '    
     A  57                              5 49'  / /   '    
     A  57                              6 49' /_/    '    
     A  58                              2 49'  ___   '    
     A  58                              3 49' ( _ )  '    
     A  58                              4 49' / _ \  '    
     A  58                              5 49'| (_) | '    
     A  58                              6 49' \___/  '    
     A  59                              2 49'  ___   '    
     A  59                              3 49' / _ \  '    
     A  59                              4 49'| (_) | '    
     A  59                              5 49' \__, | '    
     A  59                              6 49'   /_/  '    
     A  50                              2 49'  ___   '    
     A  50                              3 49' / _ \  '    
     A  50                              4 49'| | | | '    
     A  50                              5 49'| |_| | '    
     A  50                              6 49' \___/  '      
     A  61                              2 58'   _    '      
     A  61                              3 58'  / |   '      
     A  61                              4 58'  | |   '      
     A  61                              5 58'  | |   '      
     A  61                              6 58'  |_|   '      
     A  62                              2 58' ____   '      
     A  62                              3 58'|___ \  '      
     A  62                              4 58'  __) | '      
     A  62                              5 58' / __/  '      
     A  62                              6 58'|_____| '      
     A  63                              2 58' _____  '      
     A  63                              3 58'|___ /  '      
     A  63                              4 58'  |_ \  '      
     A  63                              5 58' ___) | '      
     A  63                              6 58'|____/  '      
     A  64                              2 58' _  _   '      
     A  64                              3 58'| || |  '      
     A  64                              4 58'| || |_ '      
     A  64                              5 58'|__   _|'      
     A  64                              6 58'   |_|  '    
     A  65                              2 58' ____   '    
     A  65                              3 58'| ___|  '    
     A  65                              4 58'|___ \  '    
     A  65                              5 58' ___) | '    
     A  65                              6 58'|____/  '    
     A  66                              2 58'  __    '    
     A  66                              3 58' / /_   '    
     A  66                              4 58'|  _ \  '    
     A  66                              5 58'| (_) | '    
     A  66                              6 58' \___/  '    
     A  67                              2 58' _____  '    
     A  67                              3 58'|___  | '    
     A  67                              4 58'   / /  '    
     A  67                              5 58'  / /   '    
     A  67                              6 58' /_/    '    
     A  68                              2 58'  ___   '    
     A  68                              3 58' ( _ )  '    
     A  68                              4 58' / _ \  '    
     A  68                              5 58'| (_) | '    
     A  68                              6 58' \___/  '
     A  69                              2 58'  ___   '
     A  69                              3 58' / _ \  '
     A  69                              4 58'| (_) | '
     A  69                              5 58' \__, | '
     A  69                              6 58'   /_/  '
     A  60                              2 58'  ___   '
     A  60                              3 58' / _ \  '
     A  60                              4 58'| | | | '
     A  60                              5 58'| |_| | '
     A  60                              6 58' \___/  '
     A                                  3 20' _ '     
     A                                  4 20'(_)'     
     A                                  5 20' _ '     
     A                                  6 20'(_)'     
     A                                  3 44' _ '     
     A                                  4 44'(_)'     
     A                                  5 44' _ '     
     A                                  6 44'(_)'     
     A            TITLE         50   P                
     A            PB2            2Y 0B  9  1PSHBTNFLD((*GUTTER 1))        
     A                                      PSHBTNCHC(1 'M>essages' CF06) 
     A                                      PSHBTNCHC(2 'S>ettings' CF08) 
     A                                      PSHBTNCHC(3 'E>xit' CF03)     
     A            DOWEEK         9A  O  8 56COLOR(WHT)                    
     A            DAT            8A  O  9 57COLOR(WHT)                    
     A                                  8 49'Day:'                        
     A            JDAY           6A  O  9 49COLOR(WHT)                    





 


    RPGLE  -  Convert spooled file to HTML. cmd
Posted By: Rakesh   Contact

F* OBJECT NAME....: CVTSPLHTMR                                           */ 
     F* DESCRIPTION....: Convert spooled file to HTML.                        */ 
     F* RELEASE........: V4R2                                                 */ 
     F* COMPILE NOTES..: 1) Execute the following prior to compile:           */ 
     F*                        CRTPF FILE(QTEMP/FILEIN) +                     */ 
     F*                          RCDLEN(202)  SIZE(*NOMAX)                    */ 
     F*                        CRTPF FILE(QTEMP/FILEOUT) +                    */ 
     F*                          RCDLEN(1024) SIZE(*NOMAX)                    */ 
     F*                                                                       */ 
     F* DATE WRITTEN...: 02/08/2001                                           */ 
     F* AUTHOR.........: copy from ibm site                                   */ 
     F*************************************************************************/ 
     F* 
     F*---------------------------------------------------------------- 
     F* FILE DEFINITION 
     F*---------------------------------------------------------------- 
     F* 
     FFILEIN  IF  F     202            DISK 
     FFILEOUT O   F    1024            DISK                      A 
     E* 
     E*---------------------------------------------------------------- 
     E* Tables/Arrays: 
     E*---------------------------------------------------------------- 
     E* 
     E* String in (spooled file record). 
     E                    STI       202  1 
     E* String out (HTML). 
     E                    STO      1024  1 
     E* 
     E* HTML header usage. 
     E                    HTH     1  10 80 
     E* 
     E* HTML detail usage. 
     E                    HTD     1   4 80 
     E* 
     E* HTML footer usage 
     E                    HTF     1   3 80 
     I* 
     I*---------------------------------------------------------------- 
     I* Named constants. 
     I*---------------------------------------------------------------- 
     I* 
     I              '0123456789'          C         KDIGTS 
     I              '!@#'                 C         KFROM 
     I              '<>&'                 C         KTO 
     I* 
     I*---------------------------------------------------------------- 
     I* FILES 
     I*---------------------------------------------------------------- 
     I* 
     IFILEIN  NS  01 
     I                                        1   3 INSKPB 
     I                                        4   4 INSPCB 
     I                                        5 202 INDATA 
     C* 
     C*---------------------------------------------------------------- 
     C* Main 
     C*---------------------------------------------------------------- 
C* 
     C                     EXSR INZ001 
     C                     EXSR HTHEAD 
     C                     EXSR HTDETL 
     C                     EXSR HTFOOT 
     C                     EXSR EXIT 
     C* 
     C*---------------------------------------------------------------- 
     C* Initialize. 
     C*---------------------------------------------------------------- 
     C           INZ001    BEGSR 
     C* 
     C           *ENTRY    PLIST 
     C                     PARM           P1LPP   3 
     C* 
     C* If LPP is not numeric, set default. 
     C           KDIGTS    CHECKP1LPP     X 
     C           X         IFNE *ZEROS 
     C                     Z-ADD068       LPP     30 
     C                     ELSE 
     C                     MOVE P1LPP     LPP 
     C                     ENDIF 
     C* 
     C* Initialize counters. 
     C                     Z-ADD*ZEROS    WKLPP   30 
     C                     Z-ADD0         LADD    30 
     C                     Z-ADD0         LCNT    30 
     C                     Z-ADD0         LSKPB   30 
     C                     Z-ADD0         LSPCB   30 
     C* 
     C                     ENDSR 
     C* 
     C*---------------------------------------------------------------- 
     C* Write HTML header records. 
     C*---------------------------------------------------------------- 
     C           HTHEAD    BEGSR 
     C* 
     C                     DO   10        X       40 
     C                     MOVEAHTH,X     WK80   80 P 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      OODTA1    P 
     C                     MOVE *BLANKS   OODTA2    P 
     C                     MOVE *BLANKS   OODTA3    P 
     C                     MOVE *BLANKS   OODTA4    P 
     C                     EXCPTOUTDTA 
     C                     ENDDO 
     C* 
     C                     ENDSR 
     C* 
     C*---------------------------------------------------------------- 
     C* Write HTML detail records. 
     C*---------------------------------------------------------------- 
     C           HTDETL    BEGSR 
     C* 
     C                     DO   *HIVAL 
     C* 
     C                     READ FILEIN                   90 
     C* 
     C           *IN90     IFEQ *ON 
     C                     LEAVE 
     C                     ENDIF 
     C* 
     C* Convert Skip-Before from alpha to numeric. 
     C           INSKPB    IFNE *BLANKS 
     C                     MOVE INSKPB    LSKPB 
     C                     ELSE 
     C                     MOVE *ZEROS    LSKPB 
     C                     ENDIF 
     C* 
     C* Convert Space-Before from alpha to numberic. 
     C           INSPCB    IFNE *BLANKS 
     C                     MOVE INSPCB    LSPCB 
     C                     ELSE 
     C                     MOVE *ZEROS    LSPCB 
     C                     ENDIF 
     C* 
     C* Skip before handling within current page. 
     C           LSKPB     IFNE *ZEROS 
     C           LCNT      ANDGT*ZEROS 
     C           LCNT      ANDLTLSKPB 
     C           LSKPB     SUB  LCNT      LADD 
     C                     SUB  1         LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ELSE 
     C*                    : 
     C* Skip before handling to fill prior page & then start new page. 
     C           LSKPB     IFNE *ZEROS 
     C           LCNT      ANDGT*ZEROS 
     C           LCNT      ANDGTLSKPB 
     C           LCNT      ANDLELPP 
     C           LPP       SUB  LCNT      LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     Z-ADD*ZEROS    LCNT 
     C           LSKPB     SUB  1         LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ELSE 
     C*                    : : 
     C* Skip before handling to fill prior page & then start new page. 
     C           LSKPB     IFNE *ZEROS 
     C           LCNT      ANDGT*ZEROS 
     C           LCNT      ANDGTLSKPB 
     C           LCNT      ANDGTLPP 
     C* 
     C                     Z-ADDLPP       WKLPP 
     C                     DO   *HIVAL 
     C                     ADD  LPP       WKLPP 
     C           WKLPP     IFGE LCNT 
     C                     LEAVE 
     C                     ENDIF 
     C                     ENDDO 
     C* 
     C           WKLPP     SUB  LCNT      LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     Z-ADD*ZEROS    LCNT 
     C           LSKPB     SUB  1         LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ELSE 
     C*                    : : : 
     C* Skip before handling for new page. 
     C           LSKPB     IFNE *ZEROS 
     C           LCNT      ANDEQ*ZEROS 
     C           LSKPB     SUB  1         LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ELSE 
     C*                    : : : : 
     C* Space before handling. 
     C           LSPCB     IFNE *ZEROS 
     C           LSPCB     ANDGT1 
     C           LSPCB     SUB  1         LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ENDIF 
     C                     ENDIF 
     C                     ENDIF 
     C                     ENDIF 
     C                     ENDIF 
     C* 
     C* Convert non-blank lines 
* 
      *     Determine last non-blank character. 
     C           ' '       CHEKRINDATA    ENDPOS  30 
     C           ENDPOS    IFEQ *ZEROS 
     C                     Z-ADD200       ENDPOS 
     C                     ENDIF 
      * 
      *     Convert characters in string/record. 
     C                     MOVEAINDATA    STI 
     C                     MOVEA*BLANKS   STO 
     C                     Z-ADD1         I       40 
     C                     Z-ADD1         O       40 
      * 
     C                     DO   *HIVAL 
      * 
      *          Leave if over max array size. 
     C           I         IFGT 200 
     C           O         ORGT 1024 
     C                     LEAVE 
     C                     ENDIF 
      * 
      *          Set beginning of string. 
     C           I         IFEQ 1 
     C                     MOVEAHTD,2     WK80 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      LINF1B  6 
     C                     MOVEALINF1B    STO,O 
     C                     ADD  6         O 
     C                     ENDIF 
      * 
      *          If at end of string, set line feed and get out. 
     C           I         IFGT ENDPOS 
     C                     MOVEAHTD,3     WK80 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      LINF1E  5 
     C                     MOVEALINF1E    STO,O 
     C                     ADD  7         O 
     C                     LEAVE 
     C                     ENDIF 
      * 
      *          Skip if not in column range (ultimately pass parm) 
     C           I         IFLT 1 
     C           I         ORGT 200 
     C                     ITER 
     C                     ENDIF 
      * 
      *          Convert spaces to hidden characters. 
      *           (This eliminates the line wrap and makes things 
      *            more difficult(tedious) for someone to manually 
      *            copy/change the HTML code) 
     C           STI,I     IFEQ ' ' 
     C                     MOVEAHTD,1     WK80 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      LINSPC  6 
     C                     MOVEALINSPC    STO,O 
     C                     ADD  6         O 
     C                     ELSE 
     C                     MOVEASTI,I     STO,O 
     C                     ADD  1         O 
     C                     ENDIF 
     C* 
     C                     ADD  1         I 
     C* 
     C                     ENDDO 
     C* 
     C* Skip duplicate lines when used for bold purposes. 
     C                     MOVEASTO,1     NWDTA1256 P 
     C                     MOVEASTO,257   NWDTA2256 P 
     C                     MOVEASTO,513   NWDTA3256 P 
     C                     MOVEASTO,769   NWDTA4256 P 
     C           LSPCB     IFEQ *ZEROS 
     C           LSKPB     ANDEQ*ZEROS 
     C           NWDTA1    ANDEQOODTA1 
     C           NWDTA2    ANDEQOODTA2 
     C           NWDTA3    ANDEQOODTA3 
     C           NWDTA4    ANDEQOODTA4 
     C                     ITER 
     C                     ENDIF 
     C* 
     C* Write non-blanks lines. 
     C                     MOVEASTO,1     OODTA1256 P 
     C                     MOVEASTO,257   OODTA2256 P 
     C                     MOVEASTO,513   OODTA3256 P 
     C                     MOVEASTO,769   OODTA4256 P 
     C                     EXCPTOUTDTA 
     C                     ADD  1         LCNT 
     C* 
     C* Reset line counter for page (if last line was just output) 
     C           LCNT      IFEQ LPP 
     C                     Z-ADD*ZEROS    LCNT 
     C                     ENDIF 
     C* 
     C                     ENDDO 
     C* 
     C* LR time filling of last page. 
     C           LCNT      IFGT *ZEROS 
     C           LPP       SUB  LCNT      LADD 
     C                     EXSR HTDET1                     Add blank lines 
     C                     ENDIF 
     C* 
     C                     ENDSR 
     C* 
     C*---------------------------------------------------------------- 
     C* SR to add blank lines. 
     C*---------------------------------------------------------------- 
     C           HTDET1    BEGSR 
     C* 
     C           LADD      IFGT *ZERO 
     C                     DO   LADD 
     C                     MOVEAHTD,4     WK80 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      LINF2B  4 
     C                     EXCPTOUTBLK 
     C                     ADD  1         LCNT 
     C                     ENDDO 
     C                     ENDIF 
     C* 
     C                     ENDSR 
     C* 

C*---------------------------------------------------------------- 
     C* Write HTML footer records. 
     C*---------------------------------------------------------------- 
     C           HTFOOT    BEGSR 
     C* 
     C                     DO   3         X       40 
     C                     MOVEAHTF,X     WK80      P 
     C           KFROM:KTO XLATEWK80      WK80 
     C                     MOVELWK80      OODTA1    P 
     C                     MOVE *BLANKS   OODTA2    P 
     C                     MOVE *BLANKS   OODTA3    P 
     C                     MOVE *BLANKS   OODTA4    P 
     C                     EXCPTOUTDTA 
     C                     ENDDO 
     C* 
     C                     ENDSR 
     C* 
     C*---------------------------------------------------------------- 
     C* Exit subroutine. 
     C*---------------------------------------------------------------- 
     C           EXIT      BEGSR 
     C* 
     C                     MOVE *ON       *INLR 
     C                     RETRN 
     C* 
     C                     ENDSR 
     C*---------------------------------------------------------------- 
     C* OUTPUT SPECS: 
     C*---------------------------------------------------------------- 
     OFILEOUT EADD             OUTBLK 
     O                         LINF2B     4 
     O        EADD             OUTDTA 
     O                         OODTA1   256 
     O                         OODTA2   512 
     O                         OODTA3   768 
     O                         OODTA4  1024 
** HTH - HTML standard header usage 
!HTML@ 
!HEAD@ 
!TITLE@Report created by CVTSPLHTM (Convert AS/400 Spooled File to HTML)!/TITLE@ 
!META NAME="Generator" CONTENT="CVTSPLHTM (Convert AS/400 Spooled File to HTML)"@ 
!META NAME="Author"CONTENT="CVTSPLHTM (Convert AS/400 Spooled File to HTML)"@ 
!style@ 
P {font-family:Courier New; font-weight:500; font-size:8.0 pt} 
!/style@ 
!/HEAD@ 
!P@ 
** HTD - HTML detail usage 
#nbsp; 
!NOBR@ 
!/BR@ 
!BR@ 
** HTF - HTML standard footer usage
!/FONT@ 
!/BODY@ 
!/HTML@ 

=============================CMD=========================================

 CMD        PROMPT('CONVERT SPOOLED FILE TO HTML')     
                                                       
 PARM       KWD(FILE) TYPE(*NAME) LEN(10) MIN(1) +     
              PROMPT('SPOOLED FILE')                   
                                                       
 PARM       KWD(DESTFIL) TYPE(*CHAR) LEN(8) +          
             MIN(1) ALWUNPRT(*NO) +                    
             EXPR(*YES) PROMPT('DESTINATION FILE')     
                                                       
 PARM       KWD(DESTFLR) TYPE(*CHAR) LEN(80) +         
             DFT('HTML/REPORTS') EXPR(*YES) +          
             PROMPT('DESTINATION FOLDER')              
                                                       
                                                       
 PARM       KWD(JOB) TYPE(QJOB) DFT(*) SNGVAL((*)) +   
               PROMPT('JOB NAME')                      
                                                       
 PARM       KWD(SPLNBR) TYPE(*DEC) LEN(4) DFT(*LAST) + 
              RANGE(-1 9999) SPCVAL((*ONLY 0) (*LAST + 
              -1)) PROMPT('SPOOLED FILE NUMBER')       
                                                       
 PDESTFLR:   PMTCTL     CTL(DESTFLR) COND((*EQ *RETRIEVE))             
                                                                       
  QJOB:       QUAL       TYPE(*NAME) LEN(10)                           
              QUAL       TYPE(*NAME) LEN(10) PROMPT('USER')            
              QUAL       TYPE(*CHAR) LEN(6) RANGE('000000' '999999') + 
              PROMPT('NUMBER')  



==============================CL Program=================================

/* OBJECT NAME....: CVTSPLHTMC                                       */ 
/* DESCRIPTION....: Convert spooled file to HTML.                    */ 
/* RELEASE........: V4R2                                             */ 
/* COMPILE NOTES..: 1) Execute the following prior to compile:       */ 
/*                        CRTPF FILE(QTEMP/CVTSPLHTMZ) RCDLEN(133) + */ 
/*                        MBR(*FILE) OPTION(*NOSOURCE) SIZE(*NOMAX)  */ 
/* AUTHOR.........: Copy from IBM Site Eric Nepsund                  */ 
/*********************************************************************/ 
                                                                        
             PGM        PARM(&SPLFNAME &DESTFIL &DESTFLR &PMQUALJOB +   
                          &SPLNBR)                                      
                                                                        
/* Input variables */                                                   
             DCL        VAR(&SPLFNAME)   TYPE(*CHAR) LEN(10)            
             DCL        VAR(&DESTFIL)    TYPE(*CHAR) LEN(8)             
             DCL        VAR(&DESTFLR)    TYPE(*CHAR) LEN(80)            
             DCL        VAR(&PMQUALJOB)  TYPE(*CHAR) LEN(26)            
             DCL        VAR(&SPLNBR)     TYPE(*DEC)  LEN(4)             
                                                                        
/* Input variables (Qualified names) */ 
              DCL        VAR(&PMJBNM) TYPE(*CHAR) LEN(10)               
              DCL        VAR(&PMUSNM) TYPE(*CHAR) LEN(10)               
              DCL        VAR(&PMJBNO) TYPE(*CHAR) LEN(6)                
                                                                        
 /* Program variables */                                                
              DCL        VAR(&PAGLEN)    TYPE(*CHAR) LEN(3)             
              DCL        VAR(&SPLNBRA)   TYPE(*CHAR) LEN(4)             
              DCL        VAR(&DESTFIL1)  TYPE(*CHAR) LEN(12)            
                                                                        
 /* Program variables for default spool file number & page length */    
              DCL        VAR(&PAGLENOVR) TYPE(*CHAR) LEN(3)             
              DCL        VAR(&SPLNBROVR) TYPE(*CHAR) LEN(4)             
              DCL        VAR(&SPLNMBGET) TYPE(*CHAR) LEN(5)             
              DCL        VAR(&SPLRECTYP) TYPE(*CHAR) LEN(21)            
 /* Program variables for creating folder(s) to store HTML documents */ 
              DCL        VAR(&NWFLRFRM) TYPE(*DEC)  LEN(3) VALUE(001)   
              DCL        VAR(&NWFLRTO)  TYPE(*DEC)  LEN(3) VALUE(000)   
              DCL        VAR(&NWFLRLEN) TYPE(*DEC)  LEN(3) VALUE(000)   
              DCL        VAR(&INFLRLEN) TYPE(*DEC)  LEN(3) VALUE(1)     
              DCL        VAR(&INFLRLEN) TYPE(*DEC)  LEN(3) VALUE(1)      
              DCL        VAR(&INFLR)    TYPE(*CHAR) LEN(63)              
              DCL        VAR(&NWFLR)    TYPE(*CHAR) LEN(12)              
              DCL        VAR(&FLRCNT)   TYPE(*DEC)  LEN(3) VALUE(000)    
              DCL        VAR(&SCNSTR)    TYPE(*CHAR) LEN(80)             
              DCL        VAR(&SCNSTRLEN) TYPE(*DEC)  LEN(3) VALUE(80)    
              DCL        VAR(&SCNBEGPOS) TYPE(*DEC)  LEN(3)              
              DCL        VAR(&SCNPAT)    TYPE(*CHAR) LEN(1)              
              DCL        VAR(&SCNPATLEN) TYPE(*DEC)  LEN(3)              
              DCL        VAR(&SCNXLT)    TYPE(*CHAR) LEN(1) VALUE('1')   
              DCL        VAR(&SCNTRM)    TYPE(*CHAR) LEN(1) VALUE('1')   
              DCL        VAR(&SCNWLDCRD) TYPE(*CHAR) LEN(1) VALUE(' ')   
              DCL        VAR(&SCNRTNVAL) TYPE(*DEC)  LEN(3)              
                                                                         
  /* Standard variables.                                              */ 
               DCL        VAR(&MSGDTA)  TYPE(*CHAR) LEN(200)             
               DCL        VAR(&MSGERR)  TYPE(*LGL) LEN(1) VALUE('0')     
               DCL        VAR(&MSGF)    TYPE(*CHAR) LEN(10)              
               DCL        VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)              
               DCL        VAR(&MSGID)   TYPE(*CHAR) LEN(7)               
                                                                       
 /* Files */                                                           
             DCLF       FILE(CVTSPLHTMZ)                               
/*********************************************************************/
/* Standard logic                                                    */
/*********************************************************************/
                                                                       
/* Global message monitor. */                                          
             MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(MSGSTART))     
             MONMSG     MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))    
                                                                       
/* Global message monitor. */                                          
             CHGVAR     VAR(&PMJBNM) VALUE(%SST(&PMQUALJOB 1 10))      
             CHGVAR     VAR(&PMUSNM) VALUE(%SST(&PMQUALJOB 11 10))     
             CHGVAR     VAR(&PMJBNO) VALUE(%SST(&PMQUALJOB 21 6))      
                                                                       
/*********************************************************************/
/* Main logic.                                                       */
/*********************************************************************/
/* Delete temporary files, if they exist */                            
 DLTF       FILE(QTEMP/CVTSPLHTMX)                                     
              MONMSG     MSGID(CPF0000)                                
              DLTF       FILE(QTEMP/CVTSPLHTMY)                        
              MONMSG     MSGID(CPF0000)                                
              DLTF       FILE(QTEMP/CVTSPLHTMZ)                        
              MONMSG     MSGID(CPF0000)                                
/* Retrieve job defaults. */                                           
             IF COND(&PMQUALJOB *EQ '*') THEN(DO)                      
               RTVJOBA    JOB(&PMJBNM) USER(&PMUSNM) NBR(&PMJBNO)      
             ENDDO                                                     
                                                                       
/* Set defaults for page length & spooled file number */               
             CHGVAR     VAR(&PAGLEN)    VALUE('068') /* Default */     
             CHGVAR     VAR(&SPLNBRA)   VALUE(&SPLNBR)                 
                                                                       
 /* Retrieve default spooled file number for *LAST & *FIRST special  */
 /* values, and also the actual page length of the spooled file.     */
                                                                       
               CHGVAR     VAR(&PAGLENOVR) VALUE('   ')                 
               CHGVAR     VAR(&SPLNBROVR) VALUE(' ')                   
               CHGVAR     VAR(&SPLNMBGET) VALUE(' ')                   
               IF COND(&SPLNBR *EQ -1) THEN(DO)                        
                 CHGVAR     VAR(&SPLNMBGET) VALUE('*LAST')             
               ENDDO                                                   
               IF COND(&SPLNBR *EQ 0) THEN(DO)                         
                 CHGVAR     VAR(&SPLNMBGET) VALUE('*ONLY')             
               ENDDO                                                   
                                                                       
  IF COND(&SPLNMBGET *EQ ' ') THEN(DO)                                 
                CHGVAR     VAR(&SPLNMBGET) VALUE(&SPLNBR)              
              ENDDO                                                    
                                                                       
              CRTPF      FILE(QTEMP/CVTSPLHTMZ) RCDLEN(133) +          
                         MBR(*FILE) OPTION(*NOSOURCE) SIZE(*NOMAX)     
                                                                       
              OVRPRTF    FILE(QPRTSPLQ) PRTTXT(*BLANK) HOLD(*YES) +    
                                                                       
                         USRDTA(@TEMP@)                                 
              WRKSPLFA   FILE(&SPLFNAME) JOB(&PMJBNO/&PMUSNM/&PMJBNM) + 
                         SPLNBR(&SPLNMBGET) OUTPUT(*PRINT)              
              DLTOVR     FILE(QPRTSPLQ)                                 
                                                                        
              CPYSPLF    FILE(QPDSPSFA) TOFILE(CVTSPLHTMZ) +            
                         SPLNBR(*LAST) MBROPT(*REPLACE) +               
                         CTLCHAR(*FCFC)                                 
   DLTSPLF    FILE(QPDSPSFA) SPLNBR(*LAST)                              
                                                                        
  READLP:      RCVF RCDFMT(CVTSPLHTMZ)                                  
               MONMSG CPF0864 EXEC(GOTO READLPX)                        
                                                                        
                 /* Retrieve spooled file number */                     
       CHGVAR     VAR(&SPLRECTYP)  VALUE(%SST(&CVTSPLHTMZ 46 21))       
       IF COND(&SPLRECTYP *EQ 'Number  . . . . . . :') THEN(DO)         
                 IF COND(&SPLNMBGET *EQ '*LAST' *OR  +                  
                       &SPLNMBGET *EQ '*ONLY') THEN(DO)                 
         CHGVAR     VAR(&SPLNBROVR)  VALUE(%SST(&CVTSPLHTMZ 72 4))      
                                                                        
                                                                       
                   IF COND((%SST(&SPLNBROVR 4 1)) *NE ' ') THEN(DO)    
                     CHGVAR VAR(&SPLNBROVR) VALUE(%SST(&SPLNBROVR 1 4))
                     GOTO CMDLBL(READLP)                               
                   ENDDO                                               
 IF COND((%SST(&SPLNBROVR 3 1)) *NE ' ') THEN(DO)                      
         CHGVAR VAR(&SPLNBROVR) VALUE('0' *CAT %SST(&SPLNBROVR 1 3))   
                    GOTO CMDLBL(READLP)                                
                  ENDDO                                                
                  IF COND((%SST(&SPLNBROVR 2 1)) *NE ' ') THEN(DO)     
                    CHGVAR VAR(&SPLNBROVR) +                           
                    VALUE('00' *CAT %SST(&SPLNBROVR 1 2))              
                    GOTO CMDLBL(READLP)                                
                  ENDDO                                                
 IF COND((%SST(&SPLNBROVR 1 1)) *NE ' ') THEN(DO)                      
                    CHGVAR VAR(&SPLNBROVR) +                           
                    VALUE('000' *CAT %SST(&SPLNBROVR 1 1))             
                    GOTO CMDLBL(READLP)                                
                  ENDDO                                                
                 ENDDO                                                 
                 IF COND((%SST(&SPLNBROVR 1 4)) *EQ ' ') THEN(DO)      
                   CHGVAR VAR(&SPLNBROVR) VALUE('0000')                
                   GOTO CMDLBL(READLP)                                 
                 ENDDO                                                 
               ENDDO                                                   
               ENDDO                                                   
                                                                       
/* Retrieve page length */                                             
        CHGVAR     VAR(&SPLRECTYP)  VALUE(%SST(&CVTSPLHTMZ 4 21))      
               IF COND(&SPLRECTYP *EQ ' Length . . . . . . .') THEN(DO)
                 CHGVAR VAR(&PAGLENOVR)  VALUE(%SST(&CVTSPLHTMZ 48 3)) 
                                                                       
                 IF COND((%SST(&PAGLENOVR 3 1)) *NE ' ') THEN(DO)      
                   CHGVAR VAR(&PAGLENOVR) VALUE(%SST(&PAGLENOVR 1 3))  
                   GOTO CMDLBL(READLPX)                                
                 ENDDO                                                 
                 IF COND((%SST(&PAGLENOVR 2 1)) *NE ' ') THEN(DO)      
      CHGVAR VAR(&PAGLENOVR) VALUE('0' *CAT %SST(&PAGLENOVR 1 2))      
                   GOTO CMDLBL(READLPX) 
                  ENDDO                                             
                  IF COND((%SST(&PAGLENOVR 1 1)) *NE ' ') THEN(DO)  
       CHGVAR VAR(&PAGLENOVR) VALUE('00' *CAT %SST(&PAGLENOVR 1 1)) 
                    GOTO CMDLBL(READLPX)                            
  ENDDO                                                             
                   IF COND((%SST(&PAGLENOVR 1 3)) *EQ ' ') THEN(DO) 
                     CHGVAR VAR(&PAGLENOVR) VALUE('000')            
                     GOTO CMDLBL(READLPX)                           
                   ENDDO                                            
                   GOTO CMDLBL(READLPX)                             
                 ENDDO                                              
   GOTO       CMDLBL(READLP)                                        
                                                                    
   READLPX:    IF COND(&SPLNBROVR *GE '0001' +                      
            *AND &SPLNBROVR *LE '9999') THEN(DO)                    
      CHGVAR     VAR(&SPLNBR)  VALUE(&SPLNBROVR)                    
                        CHGVAR     VAR(&SPLNBRA) VALUE(&SPLNBROVR)  
                  ENDDO                                             
IF COND(&PAGLENOVR *GE '001' +                                        
                *AND &PAGLENOVR *LE '999') THEN(DO)                   
       CHGVAR     VAR(&PAGLEN)  VALUE(&PAGLENOVR)                     
             ENDDO                                                    
                                                                      
/* Convert to HTML format in physical file  */                        
CRTPF      FILE(QTEMP/CVTSPLHTMX) RCDLEN(202)  SIZE(*NOMAX)           
      CRTPF      FILE(QTEMP/CVTSPLHTMY) RCDLEN(1024) SIZE(*NOMAX)     
      CPYSPLF    FILE(&SPLFNAME) TOFILE(QTEMP/CVTSPLHTMX) +           
                 JOB(&PMJBNO/&PMUSNM/&PMJBNM) +                       
                 SPLNBR(&SPLNBR) MBROPT(*ADD) CTLCHAR(*PRTCTL)        
                                                                      
OVRDBF FILE(FILEIN)  TOFILE(QTEMP/CVTSPLHTMX) MBR(*FIRST)             
             OVRDBF FILE(FILEOUT) TOFILE(QTEMP/CVTSPLHTMY) MBR(*FIRST)
             CALL   PGM(*LIBL/CVTSPLHTMR) PARM(&PAGLEN)               
             DLTOVR FILE(FILEIN)                                      
             DLTOVR FILE(FILEOUT)                                     
    /* Create QDLS folder(s) if they do not exist */                      
    CHGVAR     VAR(&SCNSTR) VALUE(&DESTFLR)                               
                 CHGVAR     VAR(&SCNPAT)    VALUE('/')                    
                 CHGVAR     VAR(&SCNPATLEN) VALUE(001)                    
                 CHGVAR     VAR(&SCNBEGPOS) VALUE(001)                    
                                                                          
                                                                          
             IF COND(&SCNSTR *NE ' ') THEN(DO)                            
 FLDRLP:       CALL QCLSCAN PARM(&SCNSTR &SCNSTRLEN &SCNBEGPOS &SCNPAT +  
                    &SCNPATLEN &SCNXLT &SCNTRM &SCNWLDCRD &SCNRTNVAL)     
                                                                          
                                                                          
  /* 2 or more folders */                                                 
                IF COND(&SCNRTNVAL *GT 0) THEN(DO)                        
                  CHGVAR VAR(&FLRCNT)     VALUE(&FLRCNT + 1)              
                  CHGVAR VAR(&NWFLRFRM)   VALUE(&SCNBEGPOS)               
                  CHGVAR VAR(&NWFLRTO)    VALUE(&SCNRTNVAL -1)            
                  CHGVAR VAR(&NWFLRLEN)   VALUE(&NWFLRTO - &NWFLRFRM +1)  
           CHGVAR VAR(&NWFLR)  VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))   
   IF COND(&NWFLRFRM *EQ 1) THEN(DO)
                     CHGVAR VAR(&INFLR) VALUE('*NONE')                  
                   ENDDO                                                
                                                                        
  IF COND(&NWFLRFRM *GT 1) THEN(DO)                                     
                     CHGVAR VAR(&INFLRLEN) VALUE(&NWFLRFRM -2)          
                    CHGVAR VAR(&INFLR) VALUE(%SST(&SCNSTR 1 &INFLRLEN)) 
                   ENDDO                                                
                                                                        
 CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +                    
                         CVTSPLHTM command')                            
                  MONMSG MSGID(CPF0000)                                 
                  MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))    
                  CHGVAR VAR(&SCNBEGPOS) VALUE(&SCNRTNVAL +1)           
                  GOTO CMDLBL(FLDRLP)                                   
                ENDDO                                                   
                                                                        
 /* Only 1 folder */                                                    
               IF COND(&FLRCNT *LE 0) THEN(DO)                          
                 CHGVAR VAR(&NWFLRFRM)   VALUE(&SCNBEGPOS)              
                 CHGVAR VAR(&NWFLRFRM)   VALUE(&SCNBEGPOS)             
                 CHGVAR VAR(&NWFLRTO)    VALUE(&SCNBEGPOS + 12)        
                 CHGVAR VAR(&NWFLRLEN)   VALUE(12)                     
         CHGVAR VAR(&NWFLR)  VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))  
                 CHGVAR VAR(&INFLR) VALUE('*NONE')                     
                 CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +   
                        CVTSPLHTM command')                            
                 MONMSG MSGID(CPF0000)                                 
                 MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))    
               ENDDO                                                   
                                                                       
  /* Pickup last folder, if 2 or more folders */                       
                IF COND(&FLRCNT *GE 1) THEN(DO)                        
                  CHGVAR VAR(&NWFLRFRM)   VALUE(&SCNBEGPOS)            
                  CHGVAR VAR(&NWFLRTO)    VALUE(&SCNBEGPOS + 12)       
                  CHGVAR VAR(&NWFLRLEN)   VALUE(12)                    
CHGVAR VAR(&NWFLR)  VALUE(%SST(&SCNSTR &NWFLRFRM &NWFLRLEN))           
                 IF COND(&NWFLRFRM *GT 1) THEN(DO)                     
                   CHGVAR VAR(&INFLRLEN) VALUE(&NWFLRFRM -2)           
                   CHGVAR VAR(&INFLR) VALUE(%SST(&SCNSTR 1 &INFLRLEN)) 
                                                                       
                  ENDDO                                                     
                  CRTFLR FLR(&NWFLR) INFLR(&INFLR) TEXT('Created by +       
                         CVTSPLHTM command')                                
                  MONMSG MSGID(CPF0000)                                     
                  MONMSG MSGID(IWS1612) EXEC(GOTO CMDLBL(MSGSTART1))        
                ENDDO                                                       
                                                                            
              ENDDO                                                         
                                                                            
 /* Move HTML document into folder  */                                      
              CHGVAR     VAR(&DESTFIL1) VALUE(&DESTFIL *TCAT '.htm')        
              CPYTOPCD   FROMFILE(*LIBL/CVTSPLHTMY) TOFLR(&DESTFLR) +       
                           FROMMBR(*FIRST) TODOC(&DESTFIL1) +               
                           REPLACE(*YES)                                    
                                                                            
              DLTF       FILE(QTEMP/CVTSPLHTMX)                             
              DLTF       FILE(QTEMP/CVTSPLHTMY)                             
                                                                            
 /* Return. */                                                              
                                                                            
 /*********************************************************************/   
 /*Standard message handling routine.                                 */   
 /*********************************************************************/   
 MSGSTART:   IF         COND(&MSGERR *EQ '1') THEN(SNDPGMMSG +             
                           MSGID(CPF9999) MSGF(QCPFMSG) +                  
                           MSGTYPE(*ESCAPE))                               
                                                                           
              CHGVAR     VAR(&MSGERR) VALUE('1')                           
                                                                           
 /*Move the diagnostic messages up to the next level.*/                    
 MSGDIAG:    RCVMSG     MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +     
                          MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)                 
                                                                           
             IF         COND(&MSGID *EQ '       ') THEN(GOTO +             
                          CMDLBL(MSGCOMP))                                 
                                                                           
   SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +                         
                            MSGDTA(&MSGDTA) MSGTYPE(*DIAG)                 
                                                                           
               GOTO       CMDLBL(MSGDIAG)                                  
 /* Move the completion messages up to the next level.*/               
 MSGCOMP:    RCVMSG     MSGTYPE(*COMP) MSGDTA(&MSGDTA) MSGID(&MSGID) + 
                        MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)               
                                                                       
 IF         COND(&MSGID *EQ '       ') THEN(GOTO +                     
                           CMDLBL(MSGESC))                             
                                                                       
              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +          
                           MSGDTA(&MSGDTA) MSGTYPE(*COMP)              
                                                                       
              GOTO       CMDLBL(MSGCOMP)                               
                                                                       
 /* Re-send the last escape message (if there is one).*/               
  MSGESC:     RCVMSG     MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
                           MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)            
                                                                       
  IF         COND(&MSGID *EQ '       ') THEN(RETURN)                   
                                                                       
               SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +         
             SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +        
                          MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)          
                                                                    
 MSGSTART1:  CHGVAR     VAR(&MSGDTA) VALUE('** Not Authorized to +  
           Access Floder ' *CAT &NWFLR)                             
                                                                    
  CHGVAR     VAR(&MSGDTA) VALUE(&MSGDTA *TCAT ' Please Gain +       
Access to folder from your System Admin and try Command Again. **') 
                                                                    
          /*SNDMSG     MSG(&MSGDTA) TOUSR(&PMUSNM)*/                
            SNDPGMMSG  MSGID(CPF9898) MSGF(*LIBL/QCPFMSG) +         
                         MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)           
                                                                    
                                                                    
            
ENDPGM                                                                                                          
             
                                                                                                       
                                                                                                               
 


    RPGLE  - Data Structure Array
Posted By: chris hayden   Contact

D                 Ds                  Inz                         
D errorArray                   129    Dim(9999)                   
D  err_polnbr                    9a   Overlay(errorArray)         
D  err_lname                    25a   Overlay(errorArray:*Next)   
D  err_efdate                         Overlay(errorArray:*Next)   
D                                     Like(cadmpedt)              
D  err_vehyear                        Overlay(errorArray:*Next)   
D                                     Like(cadmvehyr)             
D  err_vehmake                        Overlay(errorArray:*Next)   
D                                     Like(cadmvehmk)             
D  err_insvin                         Overlay(errorArray:*Next)   
D                                     Like(cadmivin)              
D  err_trntyp                         Overlay(errorArray:*Next)   
D                                     Like(cadmpcde)              
D  err_field1                   10a   overlay(errorArray:*Next)   
D  err_field2                   10a   overlay(errorArray:*Next)   
D  err_field3                   20a   overlay(errorArray:*Next)   

C* load the array with the database fields
C                   Eval      err_polnbr(X)   = cadmpoln  
C                   Eval      err_lname(X)   = cadmilnam  
C                   Movel     cadmpedt      err_efdate(x) 
C                   Eval      err_vehyear(X) = cadmvehyr  
C                   Eval      err_vehmake(X) = cadmvehmk  
C                   Eval      err_insvin(X)  = cadmivin   
C                   Eval      err_trntyp(X)  = cadmpcde   
C                   Eval      err_field2(X)  = Cadmtrer   

C* print the array
P $PrtRecords     B                                                
                                                                   
D $PrtRecords     PI                                               
                                                                   
C                   Sorta     errorArray                           
                                                                   
C                   Eval      X = 1                                
                                                                   
C                   For       z = 1 to %Elem(errorArray)           
                                                                   
C                   If        err_polnbr(X) <> *Blanks             
C                   Eval      R@POLNR   = err_polnbr(X)            
C                   Eval      R@LNAME   = err_lname(X)             
C                   Eval      R@EFDATE  = err_efdate(X)            
C                   Eval      R@VEHYEAR = err_vehyear(X)           
C                   Eval      R@VEHMAKE = err_vehmake(X)           
C                   Eval      R@INSVIN  = err_insvin(X)            
C                   Eval      R@TRNTYP  = err_trntyp(X)            
C                   Eval      R@FIELD1  = err_field1(X)            
C                   Eval      R@FIELD2  = err_field2(X)            
C                   Eval      R@FIELD3  = err_field3(X)        
                                                               
C                   Callp     $OverFlow                        
                                                               
C                   Eval      TotCount = TotCount + 1          
                                                               
C                   write     DETAIL                           
                                                               
C                   Endif                                      
                                                               
C                   Eval      X = X + 1                        
                                                               
C                   Endfor                                     
                                                               
C                   Callp     $OverFlow                        
                                                               
C                   write     Totals                           
                                                               
C                   write     EndReport                        
P $PrtRecords     E    
  


    RPGLE  - PRTF Utility.
Posted By: asrpg400   Contact

PRTF Utility. This program reads a printer file 
DDS source member, creates a RPG IV source member to print the 
DDS, compiles and executes the RPG program. This is useful for 
documenting external printer files and producing 
prototypes during the development phase. 

*************************************************************************
Place PRTF Object in a library and mention it in Call.

CALL PGM(LIBRARY/XPRTTST1) PARM(PRTF OBJECT NAME)
*************************************************************************
  PGM        PARM(&MBR)
             DCL        VAR(&MBR) TYPE(*CHAR) LEN(10)
/* CHECK WHETHER OBJECT IS AVALIABLE OR NOT */
             CHKOBJ  OBJ(QTEMP/QRPGLESRC) OBJTYPE(*FILE) MBR(PRTSAMPLE)
             MONMSG     CPF9801 EXEC(DO) /* FILE NOT FOUND */
             RCVMSG     MSGTYPE(*EXCP) RMV(*YES)
/* IF OBJECT NOT FOUND THEN CREATE OBJECT */
             CRTSRCPF   FILE(QTEMP/QRPGLESRC) RCDLEN(112) MBR(*NONE) +
                          MAXMBRS(*NOMAX) SIZE(*NOMAX) AUT(*ALL)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO
/* ADDING MEMBER TO SOURCE PF */
             ADDPFM     FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
                          SRCTYPE(RPGLE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO
             ADDPFM     FILE(QTEMP/QRPGLESRC) MBR(SAMPLE) +
                          SRCTYPE(RPGLE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

             ENDDO

/* ADDING MEMBER TO SOURCE PF WHEN FILE FOUND & MEMBER NOT FOUND */
             MONMSG     CPF9815 EXEC(DO) /* MEMBER NOT FOUND */
             RCVMSG     MSGTYPE(*EXCP) RMV(*YES)
             ADDPFM     FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE) +
                          SRCTYPE(RPGLE)
              MONMSG     MSGID(CPF0000) EXEC(DO)
              GOTO       CMDLBL(ABC)
              ENDDO

              ADDPFM     FILE(QTEMP/QRPGLESRC) MBR(SAMPLE) +
                           SRCTYPE(RPGLE)
              MONMSG     MSGID(CPF0000) EXEC(DO)
              GOTO       CMDLBL(ABC)
              ENDDO

              ENDDO
/* CLEARING MEMBER PRTSAMPLE */
             CLRPFM     FILE(QTEMP/QRPGLESRC) MBR(PRTSAMPLE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

/* OVRDBF TO INDICATE WHICH FILE AND MEMBER IS TO BE PROCESSED */
             OVRDBF     FILE(QRPGLESRC) TOFILE(QTEMP/QRPGLESRC) +
                          MBR(PRTSAMPLE)
             MONMSG     MSGID(CPF0000 CPF9999) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

/* GETTING FIELD DESCRIPTION OF &MBR */
             DSPFFD     FILE(&MBR) OUTPUT(*OUTFILE) +
                          OUTFILE(QTEMP/DSPFFD)
/* CALLING RPGLE PROGRAM */
             CALL       PGM(XPRTTRY) PARM(&MBR)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

/* COMPILING PROGRAM */
             CRTBNDRPG  PGM(QTEMP/SAMPLE) SRCFILE(QTEMP/QRPGLESRC) +
                          DFTACTGRP(*NO) ACTGRP(*CALLER) OUTPUT(*NONE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

/* OVRPRTF &MBR TO CHANGE ATTRIBUTE PRTTXT */
             OVRPRTF    FILE(&MBR) PRTTXT(*BLANK)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO

/* CALLING PGM TO GET THE SPOOL FILE */
             CALL       PGM(QTEMP/SAMPLE)
             MONMSG     MSGID(CPF0000) EXEC(DO)
             GOTO       CMDLBL(ABC)
             ENDDO
 ABC:        ENDPGM

**************************************************************************************

f********* File Definition ***************
     fdspffd    if   e             disk
     fqrpglesrc o    f  112        disk

     d********* Definitions *******************
     d f_spec          ds           112
     d   f_seq                 1      6  0 inz
     d   f_id                 18     18    inz('F')
     d   f_file               19     28
     d   f_o                  29     29    inz('o')
     d   f_f                  34     34    inz('e')
     d   f_dev                48     57    inz('printer')

     d d_spec          ds           112
     d   d_seq                 1      6  0 inz
     d   d_id                 18     18    inz('D')
     d   d_name               19     33
     d   d_External           34     34
     d   d_DefType            36     37
     d   d_From               38     44
     d   d_To                 45     61
     d   d_datatype           52     52
     d   d_decimals           53     54
     d   d_keywords           56     92

     d c_spec          ds           112
     d   c_seq                 1      6  0 inz
     d   c_id                 18     18    inz('C')
     d   factor_1             24     37
     d   oper                 38     47
     d   Factor_2             48     61
     d   Factor_2x            48     92
     d   Result               62     75

     d record_name     s             10
     d rec_for         s             10
     d field_name      s             10
     d field_type      s              1
     d loop            s              1  0
     d do_once         s               n

     c********** Starting Of Main PGM **********************************
     c                   eval      *in35 = *on
     c                   eval      *in45 = *on

     c********** Starting With Once Subroutine (One Time Entry)*********
     c                   if        not do_once
     c                   exsr      once
     c                   endif
     c******************************************************************
     c                   dow       *in30 = *off
     c     start         tag
     c                   read      QWHDRFFD                               25

     c*********** Process End Of File(One Time Entry @End Of Pgm)*******
     c                   if        *in25 = *on
     c                   eval      record_name = whname
     c                   goto      end
     c                   endif
     c******************************************************************
     c                   move      whflde        field_name
     c                   move      whfldt        field_type

     c******** For Printing First Record Format(One Time Entry)*********
     c                   if        record_name <> whname
     c                             and loop = 0
     c                             and *in35 = *off
     c                   eval      oper = 'write'
     c                   eval      factor_2 = record_name
     c                   eval      f_seq = f_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      *in35 = *on
     c                   eval      loop = 1
     c                   endif

     c***Condition Check: Print Record Formates between 1st & Last RF*****
     c                   if        rec_for = whname
     c                             and *in45 = *off
     c                   goto      sel
     c                   endif

     c                   if        rec_for <> whname
     c                             and *in45 = *off
     c                   exsr      rec1
     c                   endif

     c********** Select For Numeric and Character Operations **********
     c     sel           tag
     c                   eval      *in45 = *on
     c                   select
     c                   when      whfldt = 'L'
     c                             or whfldt = 'T'
     c                             or whfldt = 'Z'
     c                   eval      oper = 'time'
     c                   eval      result = field_name
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   when      whfldt = 'B'
     c                             or whfldt = 'B'
     c                             or whfldt = 'S'
     c                             or whfldt = 'P'
     c                             or whfldt = 'F'
     c                   exsr      number
     c                   when      whfldt = 'A'
     c                   exsr      character
     c                   endsl

     c********** End Select **********************************************

     c********** For Printing Last Record Format *************************
     c     end           tag
     c                   eval      *in30 = *on
     C                   exsr      lr
     c                   seton                                            lr
     c                   enddo

     c********** Main PGM End *********************************************

     c     once          begsr
     c                   eval      do_once = *on
     c     *entry        plist
     c                   parm                    file             10
     c                   move      file          f_file
     c                   eval      f_seq = f_seq + 100
     c                   write     qrpglesrc     f_spec
     c                   eval      d_seq = f_seq
     c                   eval      c_seq = d_seq
     c                   eval      oper = 'move'
     c                   eval      Factor_2 = '*off'
     c                   eval      Result   = '*in'
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      oper = 'exsr'
     c                   eval      Factor_2 = 'print'
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      oper = 'eval'
     c                   eval      Factor_2x = '*inlr = *on'
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      factor_1 = 'print'
     c                   eval      oper = 'begsr'
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   endsr

     c     character     begsr
     c                   eval      oper = 'move'
     c                   eval      factor_2 = '*all''X'''
     c                   eval      result = field_name
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      *in35 = *off
     c                   exsr      record
     c                   endsr

     c     number        begsr
     c                   eval      oper = 'z-sub'
     c                   eval      factor_2 = '*all''9'''
     c                   eval      result = field_name
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      *in35 = *off
     c                   exsr      record
     c                   endsr

     c     lr            begsr
     c                   eval      oper = 'write'
     c                   eval      factor_2 = record_name
     c                   eval      f_seq = f_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   eval      oper = 'endsr'
     c                   eval      c_seq = c_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   endsr

     c     record        begsr
     c                   if        record_name = *blanks
     c                             or record_name = whname
     c                   move      whname        record_name
     c                   goto      start
     c                   endif
     c                   if        record_name <> whname
     c                             and loop = 1
     c                   eval      rec_for = whname
     c                   setoff                                           45
     c                   goto      start
     c                   endif
     c                   endsr

     c     rec1          begsr
     c                   eval      *in45 = *on
     c                   eval      record_name = rec_for
     c                   eval      oper = 'write'
     c                   eval      factor_2 = record_name
     c                   eval      f_seq = f_seq + 100
     c                   write     qrpglesrc     c_spec
     c                   reset                   c_spec
     c                   goto      sel
     c                   endsr
************************************************************************ 


    RPGLE  - Scan and replace - %scan / %replace
Posted By: Mike Haston   Contact

p #replace        b                   export                
                                                            
d #replace        pi         32767a   varying               
d  inString                  32767a   value varying         
d  from                      32767a   value varying         
d  to                        32767a   value varying         
                                                            
 /free                                                      
                                                            
   dow %scan( from : inString ) > 0 ;                       
     inString = %replace( to : inString                     
              : %scan( from : inString ) : %len( from ) );  
   enddo;                                                   
                                                            
   return inString;   
        
p #replace        e                


    RPGLE  - Use BIFF %REPLACE
Posted By: Matt Tyler   Contact

Using %REPLACE biff in RPG
Matt Tyler
11 Dec 2001
Rating: -3.09- (out of 5)

Stop concatenating strings together just to build command strings. 
Now you can put your command string in your program as one 
constant string and use the %REPLACE to run the command with 
different parameters, similar to what PDM does with 
option commands.

At (A), the command string is contained in one constant. 
Each parameter I want to replace with different values 
at each call all start with the "&" character and a 
two-character string meant to represent something to 
myself.

At (B) I use the %REPLACE biff to replace my "PDM option parameters" 
with actual values from file OUTQP. The %REPLACE biff can replace 
a varying number of characters with a varying number of characters. 
That means you do not have to replace three characters with three 
characters. The fourth parameter ("source length to replace") 
tells the system to replace only that many characters of the 
original string adding any remaining replacement characters 
directly afterward. The effect is the command is expanded to 
accommodate the replaced parameters.

When all parameters are replaced, I execute the command at (C).

Code:

* Input file build from TAATOOL, CVTOUTQ
     FOUTQP     IF   E             DISK

      * Non-selected splf control TO outq
     DDTAARA1          DS           150    DTAARA(DTAARA1 )
     D OUTQ1                         10

      * Default printer outq
     DDTAARA2          DS           128    DTAARA(DTAARA2)
     D OUTQ2                         10

      ** OS/400 Command processor.
     DQcmdExc          PR                  ExtPgm('QCMDEXC')
     D CmdString                   3000    OPTIONS(*VARSIZE) CONST
     D CmdLength                     15P 5 CONST
     D CmdOpt                         3    OPTIONS(*NOPASS)                     

      * Stand-alone fields ****************
     D cmdexc          S            256
     D cmdlen          S             15  0

      * Constants definitions  ************
      *******( A )*******
     D ChgSplfa        C                   'CHGSPLFA FILE(&SF) JOB(&J#/&JU/&JN)-
     D                                      SPLNBR(&SN) OUTQ(&OQ)'
     D DltSplf         C                   'DLTSPLF FILE(&SF) JOB(&J#/&JU/&JN)-
     D                                      SPLNBR(&SN)'

     C                   IN        DTAARA1
     C                   IN        DTAARA2

     C                   READ      OUTQP
     C                   DOW       NOT %eof(OUTQP)
     C                   EVAL      CmdExc = ChgSplfa
      *******( B )*******
      * Replace &SF with SPFILE (Splf name)
     C                   EVAL      CmdExc = %Replace(%trim(SPFILE)       :
     C                                               CmdExc              :
     C                                               %scan('&SF': CmdExc):
     C                                               3)
      * Replace &JN with SPJNAM (Splf job name)
     C                   EVAL      CmdExc = %Replace(%trim(SPJNAM)       :
     C                                               CmdExc              :
     C                                               %scan('&JN': CmdExc):
     C                                               3)
      * Replace &JU with SPUSER (Splf job user)
     C                   EVAL      CmdExc = %Replace(%trim(SPUSER)       :
     C                                               CmdExc              :
     C                                               %scan('&JU': CmdExc):
     C                                               3)
      * Replace &J# with SPJNBR (Splf job number)
     C                   EVAL      CmdExc = %Replace(%trim(SPJNBR)       :
     C                                               CmdExc              :
     C                                               %scan('&J#': CmdExc):
     C                                               3)
      * Replace &SN with SPFNBR (Splf number)
     C                   EVAL      CmdExc = %Replace(%trim(SPFNBR)       :
     C                                               CmdExc              :
     C                                               %scan('&SN': CmdExc):
     C                                               3)
      * Replace &OQ with RETLQ
     C                   IF        Outq2 = 'Y'
     C                   EVAL      CmdExc = %Replace(%trim(OUTQ2)        :
     C                                               CmdExc              :
     C                                               %scan('&OQ': CmdExc):
     C                                               3)
     C                   ELSE
      *  -OR - Replace &OQ with TOOUTQ
     C                   EVAL      CmdExc = %Replace(%trim(OUTQ1 )       :
     C                                               CmdExc              :
     C                                               %scan('&OQ': CmdExc):
     C                                               3)

     C                   ENDIF

      *******( C )*******
     C                   EVAL      CmdLen = %len(CmdExc)
     C                   CALLP     Qcmdexc(CmdExc: CmdlEN)
      * Insert your code to do whatever with OUTQ entry.
      *                 /
      *                  :
      *                  :
      *                  :
      *                 /
      * Insert your code to do whatever with OUTQ entry.

     C                   READ      OUTQP
     C                   ENDDO

     C                   EVAL      *INLR = *ON
 


    RPGLE  - %Lookup on a data structure array
Posted By: Werner Noll   Contact

D                 Ds                                                  
D arySub                              Dim( 100)                       
D  SumSub                             Like( GlSub  ) Overlay(arySub:1)
D  SubDl01                            Like( GlExa  ) Overlay(arySub:11
                                                                      
D GlSub           S             10A                                   
D GlExa           S             10A                                   
D SubToSum        S             20A                                   
                                                                      
C                   _Eval      SubToSum = arySub(%Lookup(GlSub:SumSub))
                                                                      
C                   Return                                            

I inserted some definitions to get it compiled.
 


    RPGLE  - replace *Entry with prototypes
Posted By: chris hayden   Contact

D $Entry          Pr                  extpgm('OE0094F')      
D parmOrd                        9  0                        
D parmThere                      1a                          
                                                             
D $Entry          Pi                                         
D parmOrd                        9  0                        
D parmThere                      1a                          
 


    RPGLE  - %timestamp
Posted By: chris hayden   Contact

D                 DS                                         
D TimeStamp                       z                          
D Cur_Date                        d   Overlay(TimeStamp)     
D Cur_Time                        t   Overlay(TimeStamp:12)  

 timeStamp =  %Timestamp;     
                              
           
 


    RPGLE  - rpg free example
Posted By: chris hayden   Contact

// jobdat 8,0, jobtim 6,0                                  
                                                           
jobdat = %Uns( %Char( %Date( timeStamp ) : *ISO0 ) );      
                                                           
jobtim = %Uns( %Char( %Time( timeStamp ) : *HMS0 ) );      
                                                           
// convert character to numeric                            
dtseq = %Int(PDTSEQ);                                      
                                                           
// convert numeric to character                            
Rhdate = %Char(Rhjdt@);                                    
                                                           
// no more key lists                                       
Setll (wrkCorp#: wrkCo#: wrkCust#) Arlcsmst;               
Reade (wrkCorp#: wrkCo#: wrkCust#) Arlcsmst;               
                                                           
Chain (wrkCorp# : wkrCo# : wrkCust# ) Arlcsmst;            
                                                           
// get todays date                                         
Date8s0 = %Uns(%Char(%Date():*ISO0));                      

Date8a0 = %Char(%Date():*USA0);                  
                                                 
// TodaysDate defined as a "D" field             
ToDaysDate = %Date();                            
                                                 
BirthDate = %DATE(BirthYMD:*USA);                
                                                 
DaysOld = %DIFF(Today:BirthDate:*DAYS);          
                                                 
DaysOld = %DIFF(%DATE() :                        
          %DATE(BirthYMD:*USA) :                 
          *DAYS);                                
                                                 
DueDate = InvDate + %DAYS(30);                   
                                                 
//convert a date back to a character field       
DateCharacter = %CHAR(Date:*ISO0);               
                                                 
DateNumeric = %UNS(%CHAR(Date:*ISO0));           

// retrieve the month                                                
MM = %SubDt(SomeDate : *Months);                                     
                                                                     
// check the month                                                   
If %SubDt(SomeDate : *Months) = ReportMonth;                         
                                                                     
// scan for string, check result                                     
If %Scan(SomeSrch : SomeString) > 0;                                 
                                                                     
// thetimenow defined as a "T" field                                 
TheTimeNow = %Time();                                                
                                                                     
// Assuming the 8.0 Field is to be in YYYYMMDD Format:               
// Assuming the 6.0 Field is to be in HHMMSS Format:                 
                                                                     
YYYYMMDD = %Int( %Char( ToDaysDate : *ISO0 ) );                      
HHMMSS   = %Int( %Char( TheTimeNow : *HMS0 ) );                      
                                                                     
// You Need V5R2 to use %uns                                         
YYYYMMDD = %uns( %char( %date : *ISO0 ) );                           

HHMMSS   = %uns( %char( %time : *HMS0 ) );               
                                                         
Eval DueDate = LoanDate + %Years(YY)  +                  
                              %Months(MM) +              
                              %Days(DD);                 
                                                         
OutDate = DueDate - %Days( 14 );                         
                                                         
EndTime = StrTime + %Hours( 8 );                         
                                                         
NbrDays = %Diff( DueDate : OutDate : *Days )             
                                                         
NbrHrs  = %Diff( EndTime : StrTime : *Hours )            
                                                         
BirthYear = %SubDt( BirthDate : *Years );                
                                                         
CurHour   = %SubDt( CurTime : *Hours );                  
                                                         
SomeTimestamp = %Timestamp( CharTimestamp );             

SomeDate = %Date( CharDate : *MDY0 )                  
                                                      
SomeTime = %Time( CharTime : *USA  )                  
                                                      
ISODueDt = %Date( EurDueDt : *Eur ) ;                 
                                                      
ISODate = %Date( NumericDate ) + %Days( 5 ) ;         
                                                      
YYYY = %SubDt( ISODate : *Years ) ;                   
                                                      
MM = %SubDt( ISODate : *Months ) ;                    
                                                      
DD = %SubDt( ISODate : *Days ) ;                      
                                                      
count += 1;        // increment count by 1            
count -= 5;        // decrement count                 
count *= (a+b);    // multiply count by (a+b)         
count /= 17;       // divide count by 17              
count **= 3;       // cube the count                  

string += 'QED.';  // append to the end of string       
                                                        
ptr += %len(var);  // increment pointer                 
                                                        
date += %years(2) + %months(5) - %days(17);             
                                                        
// using procedures in expressions                      
                                                        
if  MyFunc1(string1) = %trim (MyFunc2(string2));        
            %subst(X(3))= MyFunc3('abc');               
endif;                                                  
                                                        
                                                        
//only update certain fields available v5r2             
UPDATE EmpRec %FIELDS(Salary:Status);                   
                                                        
// no more EVAL                                         
dataBaseField = screenField;                            
                                                        
*inlr = *On;                                            

// no more CALLP                                     
$CopyNotes( Scr_OrgOrd : Scr_Ord# );                 
                                                     
// julian dates                                      
LongJulA = %Char(%Date(DMY:*DMY):*LongJul0) ;        
                                                     
// qualified data structure                          
Price = OrderDetail.Part.Cost;                       
                                                     
// qualified data structure with arrays              
price = Order(I+17). ItemList(p). Part. Cost;        
                                                     
// get the number of elements in the array           
ArraySize = %elem (Array);                           
                                                     
// convert string to decimal with positions          
number = %dec(string:7:2);                           

// for loops                                     
 For Index = StartVal To EndVal By IncVal;       
       ExSr Process;                             
   EndFor;                                       
                                                 
 For Counter = 1 To NbrLoops;                    
       ExSr Process;                             
   EndFor;                                       

 // Monitor for Errors                                
  Monitor;                                            
      Dou %EOF(TimeRecord);                           
        Read TimeRecord;                              
        If %EOF(TimeRecord);                          
          Leave;                                      
        Else;                                         
          TotalPay = (RegHours * Rate)                
                     + (OvtHours * Rate * 1.5)        
                     + (DblHours * Rate * 2);         
          Update TimeRecord;                          
        Endif;                                        
      Enddo;                                          
                                                      
  On-error 1218;                // Record locked      
        Dsply 'TimeRecord record locked.';            
       Leave;                                         
  On-error 1011:1211:*FILE;     // File error         
       Dsply 'Unexpected file error occurred.';       
       Leave;                                         

   On-error *PROGRAM;            // Non-file error            
             Dsply 'Unexpected program error occurred.';      
             Leave;                                           
  Endmon;                                                     
                                                              
  // Error Extension                                          
  Chain(E) SlcKey  Master;                                    
   Select;                                                    
    When %Error;                                              
     MasterIOErr();                                           
    When Not %Found( Master );                                
     MasterNFnd();                                            
    Other;                                                    
     ProcMaster();                                            
   EndSl;                                                     
                                                              
  // divide and remainder                                     
    quote  = %div( total : count );                           
    remain = %rem( total : count );                           
                     
msg    = 'total divided by count = ' +              
            %char(quote) + ' remainder ' +          
                %char(remain);                      
 


    RPGLE  - Generate a random number
Posted By: jamie flanary   Contact

        d instartnumber   s             15  5
     d inendnumber     s             15  5
     d inrandomnumber  s             15  5
     d wkseed          s              9  9
     d wkstartnumber   s              6  0
     d wkendnumber     s              6  0
     d wkrandomnumber  s              6  0
     d range           s              6  0
     d time            s             12  0
     c     *entry        plist
     c                   parm                    instartnumber
     c                   parm                    inendnumber
     c                   parm                    inrandomnumber
      *
     c                   eval      wkstartnumber  = instartnumber
     c                   eval      wkendnumber    = inendnumber
     c                   eval      wkrandomnumber = inrandomnumber
      *
     c                   if        wkseed = *zeros
     c                   time                    time
     c     .000000001    mult      time          wkseed
     c                   endif
      *
     c                   if        wkstartnumber = *zeros and
     c                             wkendnumber = *zeros   or
     c                             wkendnumber < wkstartnumber
     c                   eval      wkstartnumber = 1
     c                   eval      wkendnumber = 999999
     c                   endif
      *
     c                   eval      range = (wkendnumber -wkstartnumber) + 1
      *
     c                   mult      9821          wkseed
     c                   add       .211327       wkseed
     c                   eval      wkrandomnumber =  (wkseed * range) +
     c                             wkstartnumber
     c                   eval      *inlr = *on


    RPGLE  - QLGSORT - Use APi to sort subfile data
Posted By: jamie flanary   Contact

*==============================================================
      * Subroutine - SortSfl
      *
      *  For information on Sort API's see
      *  OS/400 National Language Support API Guide
      *  This subroutine sorts the subfile records.
      *==============================================================

     c     $SortSFL      begsr
      *
      * Initialize the key fields to sort on.
      * Load S1PRO#     field as key field, 07 byte, dec, ascending sequence.
      *
     c                   eval      KeyStart   = 1
     c                   eval      KeySize    = 07
     c                   eval      KeyDtaTyp  = 2
     c                   eval      KeyAscDesc = 1
     c                   eval      KeyInf(1)  = KeyInfDs
      *
      * Load S1CNAM     field as key field, 30 byte, char , descending sequence.
      *
     c                   eval      KeyStart   = 8
     c                   eval      KeySize    = 30
     c                   eval      KeyDtaTyp  = 6
     c                   eval      KeyAscDesc = 2
     c                   eval      KeyInf(2)  = KeyInfDs
      *
      * Load other sort parameters.
      *
     c                   eval      BlockLen  = 80 + 16 * MaxKey
     c                   eval      NbrOfKeys = 2                                Variable
     c                   eval      RecLen    = %size(SFLRCD)
      *
      * Initialize Sort I/O API fields.
      *
     c                   eval      IORecLen = RecLen
     c                   eval      IORecCnt = 1
      *
      * All done initializing.
      * First step - Initialize the sort routine.
      *
     c                   call      'QLGSORT'
     c                   parm                    SortBlock
     c                   parm                    NotUsed
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    ReturnSize
     c                   parm                    Error
      *
      * Next step - write records to I/O routine.
      *
     c                   eval      IOType = 1
      *
      * read the entire subfile
      *
     c                   for       count   = 1 to Savrrn
      *
     c     count         chain     SUB01
      *
     c                   if        %found
      *
     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    SflRcd
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    Error
      *
     c                   endif
      *
     c                   endfor
      *
      * Next step - Signal end of input, clear subfile for reload.
      *
     c                   eval      IOType = 2
     c
     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    SflRcd
     c                   parm                    NotUsed
     c                   parm                    SizeList
     c                   parm                    NotUsed
     c                   parm                    Error
      *
      *    Clear the subfile
      *
     c                   exsr      $ClearSFL
      *
      * Final step - write the records back to the subfile.
      *
     c                   eval      IOType = 3
      *
      *
      * read the entire subfile
      *
     c                   for       count   = 1 to Savrrn
      *
     c                   call      'QLGSRTIO'
     c                   parm                    SortIOBloc
     c                   parm                    NotUsed
     c                   parm                    SflRcd
     c                   parm                    IORecLen
     c                   parm                    NotUsed
     c                   parm                    Error
      *
     c                   eval      RRN1 = Count
     c                   eval      SCRRN = RRN1
     c                   write     Sub01
      *
     c                   endfor
     c                   eval      SubfileEnd = *on
     c                   z-add     SCRRN         SavRrn
      *
     c                   if        SavRrn = *Zeros  And   SubfileEnd
     c                   eval      DisplaySubfile = *Off
     c                   else
     c                   eval      RRN1  = 1.
     c                   eval      SCRRN = 1.
     c                   endif
      *
     c                   endsr
      *=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
      *  $PosSubfile - Position the subfile
      *=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-==-
     cSR   $PosSubfile   begsr
      *
     c                   for       count   = 1 to Savrrn
      *
     c     count         chain     SUB01
     c                   if        %found        and
     c                             S1PRO# = C1PRO#  or
     c                             %found        and
     c                             S1PRO# > C1PRO#  or
     c                             count = Savrrn
      *
     c                   eval      RRN1 = Count
     c                   eval      SCRRN = Count
      *
      * check to see last pink record and un-pink it
      *
     c                   if        LastPinkRRN > *Zeros
     c     LastPinkRRN   chain     SUB01
     c                   if        %found
     c                   eval      Pink = *Off
     c                   update    SUB01
     c                   clear                   LastPinkRRN
     c                   endif
     c                   endif
      *
     c     Count         chain     SUB01
     c                   if        %found
     c                   clear                   C1PRO#
     c                   eval      Pink = *On
     c                   update    SUB01
     c                   eval      Pink = *Off
     c                   z-add     Count         LastPinkRrn
     c                   leave
     c                   endif
      *
     c                   endif
      *
     c                   endfor
      *
     c                   endsr
      * 


    RPGLE  - DSPDEVU (6/8): DISPLAY LIST OF USER'S ACTIVE SCREEN
Posted By: bossé yvain   Contact

** LISTE DES SOURCES   :                                                     
      ** DSPDEVU     CMD                                                               
      ** DSPDEVUC    CLP                                                               
      ** DSPDEVUD    CLP                                                           
      ** DSPDEVUE    DSPF                                                          
      ** DSPDEVUM    CLP                                                           
      ** DSPDEVUS    RPGLE                                                         
      ** QPDSPAJBL1  LF                                                            
      ** QPDSPAJBP   PF                                                                                      
˜*************************************************************************      
      *˜
      *˜Programme : DSPDEVU  AFFICHAGE ECRANS D'UN USER (DSPDEVU)
      *˜                     DISPLAY ALL USER'S ACTIVE SCREEN
      *˜
      *˜Mode appel: CMD : DSPDEVU
      *˜
      *˜Remarques : POSSIBILITE D'ENVOYER UN MESSAGE A L'UTILISATEUR
      *˜            POSSIBILITY TO SEND BREACK MESSAGE TO THIS USER
      *˜
      *˜Remarques : SOUS FICHIER EN CHARGEMENT DYNAMIQUE
      *˜            DYNAMIC SUBFILE
      *˜
      *‚Date Créa.: xx/09/04  Auteur : Yvain Bossé
      *‚                               ybosse@wanadoo.fr
      *‚                               ybosse@free.fr
      *‚Date Modif  Objet modification
      *‚°°°°°°°°°°  °°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
      *
      *˜************************************************************************

     ‚* ------------------------------------------------------------------------
     ‚*              DECLARATION DES FICHIERS
     ‚* ------------------------------------------------------------------------
     ‚* Fichier Ecran
     FDSPDEVUE  CF   E             WORKSTN
     F                                     SFILE(DSPDEV072:WREC72)
     ‚* Fichier des écrans actifs d'un utilisateur
     FQPDSPAJBL1IF   E           K DISK
     ‚*
     ‚* ------------------------------------------------------------------------
     ‚*              DECLARATION DES CONSTANTES/ZONES/TABLEAUX
     ‚* ------------------------------------------------------------------------
     ‚*
     D SFLP72          C                   CONST(012)
     ‚*
     D                 DS
     D QNBJOB                  1      6  0
     D TNBJOB                  1      6
     ‚*
     ‚* ------------------------------------------------------------------------
     ‚*              PARAMETRES EN ENTREE/SORTIE
     ‚* ------------------------------------------------------------------------
     ‚*
     C     *ENTRY        PLIST
     C                   PARM                    REFRESH           1
     ‚*
     ‚* ------------------------------------------------------------------------
     ‚*              LISTE DES CLES D'ACCES FICHIER
     ‚* ------------------------------------------------------------------------
     ‚*
     ‚* QPDSPAJBL1
     C     KDSPA1        KLIST
     C                   KFLD                    QUSER
     C                   KFLD                    QECRAN
     C                   KFLD                    QNBJOB
     ‚*
     ‰**************************************************************************
     ‰*------------------------------------------------------------------------*
     ‰*         ˆ DEBUT DE PROGRAMME // BEGIN PROGRAM ‰
     ‰*------------------------------------------------------------------------*
     ‰**************************************************************************
     ‚*
     C                   SETON                                        02
     ‚*
     C     *INRT         DOWEQ     '0'
     C     *IN02         CASEQ     '1'           ECR02
     C                   END
     C                   END
     C                   SETON                                        LR
     ‚*
     š**************************************************************************
     š* ECR02 - LISTE DES ECRANS DU USER
     š*         DISPLAY ALL USER'S ACTIVE SCREEN
     š**************************************************************************
     ‚*
     C     ECR02         BEGSR
     ‚*
     C                   SETOFF                                       02
     ‚*
     C                   DOU       ERR02 = *OFF
     ‚*
     C                   EXSR      àFPG72
     ‚*
     C                   WRITE     DSPDEV082
     C                   SETOFF                                       63
     C                   SETON                                        65
     ‚*
    ?C     ERR02         DOUEQ     *OFF
     C                   WRITE     DSPDEV082
     C     WMAX72        COMP      *ZERO                              64
     C                   EXFMT     DSPDEV002
     C                   MOVE      *OFF          ERR02             1
     ‚*
     ‚*F3 = FIN / END
    ˆC     *INKC         IFEQ      *ON
     C                   EVAL      *INRT = *ON
     C                   LEAVE
    ˆC                   ENDIF
     ‚* F5 = REACTUALISE / REFRESH
    ˆC     *INKE         IFEQ      *ON
     C                   EVAL      *INRT = *ON
     C                   EVAL      REFRESH = *ON
     C                   LEAVE
    ˆC                   ENDIF
     ‚* ROLLUP
    ˆC     *IN61         IFEQ      *ON
     C                   EXSR      àRUP72
     C                   EVAL      ERR02 = *ON
    ˆC                   ENDIF
     ‚*ROLLDOWN
    ˆC     *IN62         IFEQ      *ON
     C                   EXSR      àRDW72
     C                   EVAL      ERR02 = *ON
    ˆC                   ENDIF
     ‚*
    ˆC                   IF        NOT *INKL
     C                             AND NOT *INKC
     C                             AND WMAX72 > *ZEROS
     C                             AND ERR02 = *OFF
     C                   EVAL      ERR02 = *ON
     C                   READC     DSPDEV072                              90
    ˜C                   DOW       NOT *IN90
     C                   EXSR      CTL72
     C                   EVAL      WCHX72 = ' '
     C                   UPDATE    DSPDEV072
    šC                   IF        ERR02 = *ON
     C                   LEAVE
    šC                   ENDIF
     C                   READC     DSPDEV072                              90
    ˜C                   ENDDO
    ˆC                   ENDIF
     ‚*
    ?C                   ENDDO
     ‚*
     C                   ENDDO
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àFPG72 - CHARGEMENT PREMIERE PAGE SFL SFL72
     š*          LOAD FIRST SCREEN OF THE SUBFILE
     š**************************************************************************
     ‚*
     C     àFPG72        BEGSR
     ‚*
     C                   MOVE      *OFF          àEOF72            1
     C                   MOVE      *ON           àBOF72            1
     C                   Z-ADD     *ZERO         WMAX72            4 0
     ‚*
     C                   EXSR      àRUP72
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àLPG72 - CHARGEMENT DERNIERE PAGE SFL 72
     š*          LOAD LAST SCREEN OF THE SUBFILE
     š**************************************************************************
     ‚*
     C     àLPG72        BEGSR
     ‚*
     C                   MOVE      *ON           àEOF72
     C                   MOVE      *OFF          àBOF72
     C                   Z-ADD     *ZERO         WMAX72
     ‚*
     C                   EXSR      àRDW72
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àCLR72 - REMISE A BLANC SFL 72
     š*          CLEAR SUBFILE
     š**************************************************************************
     ‚*
     C     àCLR72        BEGSR
     ‚*
     C                   Z-ADD     *ZERO         WMAX72            4 0
     C                   SETON                                        6365
     C                   SETOFF                                       64
     C                   WRITE     DSPDEV002
     C                   SETON                                        6465
     C                   SETOFF                                       63
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àRUP72 - CHARGEMENT PAGE SUIVANTE SFL 72
     š*          LOAD NEXT SCREEN OF THE SUBFILE
     š**************************************************************************
     ‚*
     C     àRUP72        BEGSR
     ‚*
    ˆC                   IF        àBOF72 = *ON
     C                   MOVE      'S'           àMODR             1
     C                   EXSR      àPOS72
    ˆC                   ENDIF
     ‚*
     C                   Z-ADD     *ZERO         àNBR72            3 0
     ‚*
     C                   READ      QDSPAJ                                 95
     ‚*
    ˆC     *IN95         DOUEQ     *ON
     C     àNBR72        OREQ      SFLP72
     ‚*
    ˜C     àNBR72        IFEQ      *ZERO
     C                   EXSR      àCLR72
    ˜C                   ENDIF
    ˜C     *IN95         IFEQ      *OFF
     C                   EXSR      àADD72
     C                   ADD       1             àNBR72
    šC                   IF        àNBR72 = 1
     C                   Z-ADD     1             WLIG72
    šC                   ENDIF
    ˜C                   ENDIF
     ‚*
    ˜C     àNBR72        IFLT      SFLP72
     C                   READ      QDSPAJ                                 95
    ˜C                   ENDIF
     ‚*
    ˆC                   ENDDO
     ‚*
    ˆC     *IN95         IFEQ      *ON
     C                   MOVE      *ON           àEOF72
     C                   Z-ADD     àNBR72        SVMAX72           3 0
    ˆC                   ENDIF
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àRDW72 - CHARGEMENT PAGE ARRIERE SFL 72
     š*          LOAD PREVIOUS SCREEN OF THE SUBFILE
     š**************************************************************************
     ‚*
     C     àRDW72        BEGSR
     ‚*
     ‚** positionnement fichier type - clÉ UNIQUE -
    ˆC     WMAX72        IFEQ      *ZERO
     C                   MOVE      'F'           àMODR
    ˆC                   ELSE
     C                   MOVE      'P'           àMODR
    ˆC                   ENDIF
     C                   EXSR      àPOS72
     ‚*
     ‚* chargement ss/fichier
     C                   Z-ADD     0             àWN30             3 0
     C     SFLP72        ADD       1             àWN30
    ˆC                   DO        àWN30
     C                   READP     QDSPAJ                                 95
    ˆC  N95              ENDDO
     ‚** positionnement fichier type - clÉ UNIQUE -
     ‚*
    ˆC     *IN95         IFEQ      *ON
     C                   MOVE      *ON           àBOF72
    ˆC                   ENDIF
     ‚*
     C                   EXSR      àRUP72
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àPOS72 - POSITIONNEMENT SFL 72
     š*          FIND RECORD ON THE SUBFILE
     š**************************************************************************
     ‚*
     C     àPOS72        BEGSR
     ‚*
    ˆC     àMODR         IFEQ      'S'
     C                   MOVE      *OFF          àBOF72
     C     *LOVAL        SETLL     QDSPAJ
    ˆC                   ELSE
     ‚*
    ˜C     àMODR         IFEQ      'F'
     C     àMODR         OREQ      'P'
     C                   MOVE      *OFF          àEOF72
    šC                   IF        àMODR = 'P'
     C                   MOVE      *OFF          àBOF72
    šC                   ENDIF
    šC                   IF        WMAX72 > 0
     C     1             CHAIN     DSPDEV072                          99
    šC                   ELSE
     C     SVMAX72       CHAIN     DSPDEV072                          99
    šC                   ENDIF
     C     KDSPA1        SETLL     QDSPAJ
     C
    ˜C                   ENDIF
    ˆC                   ENDIF
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àADD72 - AJOUT ENREGISTREMENT SFL 72
     š*          WRITE NEW RECORD IN THE SUBFILE
     š**************************************************************************
     ‚*
     C     àADD72        BEGSR
     ‚*
     C                   ADD       1             WMAX72            4 0
     C                   Z-ADD     WMAX72        WREC72            4 0
     C                   WRITE     DSPDEV072
     C                   EVAL      *IN40 = *OFF
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* àCTL72 - CONTROLE SFL 72
     š*          MAKE CONTROL ON THE CHOICE
     š**************************************************************************
     ‚*
     C     CTL72         BEGSR
     ‚*
    ˆC                   SELECT
     ‚* WRKJOB
    ˆC                   WHEN      WCHX72 = '5'
     C                   CALL      'DSPDEVUD'
     C                   PARM                    QUSER
     C                   PARM                    QECRAN
     C                   PARM                    TNBJOB
     ‚* SNDBRKMSG
    ˆC                   WHEN      WCHX72 = '1'
     C                   CALL      'DSPDEVUM'
     C                   PARM                    QECRAN
    ˆC                   ENDSL
     ‚*
     C                   ENDSR
     ‚*
     š**************************************************************************
     š* *INZSR - INITIALISATION PROGRAMME
     š**************************************************************************
     ‚*
     C     *INZSR        BEGSR
     ‚*
     ‚*
     C                   ENDSR
     ‚*
  


    RPGLE  - BIF - using %lookup
Posted By: jimmy octane   Contact

C                   Eval      Idx = %LookUp( SrchArg : SomeAry )
     C                   If        Idx > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Idx = %LookUp( SrchArg : SomeAry : 4 )
     C                   If        Idx > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Idx = %LookUp( SrchArg : SomeAry : 4 : 5 )
     C                   If        Idx > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Idx = %LookUpGE( SrchArg : SomeAry )
     C                   If        Idx > *Zero
      * Process information
     C                   EndIf
     C                   Eval      *In01 = %TLookUpLT( SrchArg : TabEmp )
     C                   If        *In01
      * Process information
     C                   EndIf
     C                   If        %TLookUpLT( SrchArg : TabEmp )
      * Process information
     C                   EndIf 

  


    RPGLE  - BIF - using %check
Posted By: jimmy octane   Contact

C                   Eval      Pos = %Check( ' ' : SomeString )
     C                   If        Pos > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Pos = %Check( ' ' : SomeString : 11 )
     C                   If        Pos > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Pos = %Check( '0123456789' : SomeString )
     C                   If        Pos > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Pos = %CheckR( ' ' : SomeString )
     C                   If        Pos > *Zero
      * Process information
     C                   EndIf
     C                   Eval      Pos = %CheckR( ' ' : SomeString : 30 )
     C                   If        Pos > *Zero
      * Process information
     C                   EndIf 
  


    RPGLE  - Timing Out a Subfile
Posted By: jimmy octane   Contact

==>DDS
     A                                      DSPSIZ(24 80 *DS3)
     A                                      INVITE
     A          R S01                       SFL
     A            FLD001         3Y 0O  7  8EDTCDE(Z)
     A          R C01                       SFLCTL(S01)
     A                                      SFLSIZ(0020)
     A                                      SFLPAG(0005)
     A                                      CA03(03)
     A                                      OVERLAY
     A                                      SFLDSP
     A                                      SFLDSPCTL
     A N01                                  SFLEND(*MORE)
     A                                  2  5'Msg:'
     A                                      COLOR(WHT)
     A            CTLMSG        11A  O  2 11
     A          R K01
     A                                 13  6'F3=Exit'
     A                                      COLOR(BLU) 

==> RPG
    
 FTestD     CF   E             WorkStn Sfile(  S01: Rrn )
     F                                     MaxDev( *File    )
     F                                     InfDs(  TestdDs  )

     D RRN             S              3P 0
     D I               S              3P 0

     D TestdDs         DS
     D  Sts              *Status

      * Fill the subfile
     C                   Eval      RRN = *Zero
     C                   Do        8             I

     C                   Eval      Fld001 = I
     C                   Eval      RRN    = RRN + 1
     C                   Write     S01

     C                   EndDo

     C                   DoU       *In03 = *On

     C                   Write     K01

     C                   Write     C01
     C                   Read      TestD                                99

     C                   If        Sts = 1331
     C                   Eval      CtlMsg = 'Timed Out'
     C                   Else
     C                   If        *In03 = *On
     C                   Leave
     C                   EndIf
     C                   Eval      CtlMsg = 'No Time Out'
     C                   EndIf

     C                   EndDo

     C                   Eval      *InLR = *On 
 


    RPGLE  - Day of week/Week of year prototypes
Posted By: jimmy octane   Contact

H NoMain

      * ------------------------------------------------------------- Prototypes
     D DayOfWeek       PR             5I 0
     D                                 D   Value

     D WeekOfYear      PR             5I 0
     D                                 D   Value

      * ------------------------------------------------------------------------
      *
      * Procedure: DayOfWeek
      * Description: Retrieve day of week using ISO 8601 standard
      *              (0=Monday … 6=Sunday)
      *
     P DayOfWeek       B                   Export

     D DayOfWeek       PI             5I 0
     D  DateIn                         D   Value

     D NbrDays         S             10I 0

     D Monday          C                   D('2001-01-04')

      /Free

       NbrDays = %DIFF(DateIn:Monday:*DAYS);
       Return  = %REM( %REM(NbrDays:7) + 7 : 7);

      /End-Free

     P DayOfWeek       E

      * ------------------------------------------------------------------------
      *
      * Procedure: WeekOfYear
      * Description: Retrieve week of year using ISO 8601 standard
      *              (Year starts on Monday of week containing January 4)
      *

     P WeekOfYear      B                   Export

     D WeekOfYear      PI             5I 0
     D  DateIn                         D   Value

     D                 DS
     D Jan04Date                       D   INZ(D'0001-01-04')
     D  Jan04Year                     4  0 Overlay(Jan04)

     D FirstMonday     S               D
     D Jan04DOW        S              5I 0

      /Free

       // Change Jan04Date to target year,
       // then calculate first Monday of target year
       Jan04Year   = %SUBDT(DateIn:*Y);
       Jan04DOW    = DayOfWeek(Jan04Date);
       FirstMonday = Jan04Date - %DAYS(Jan04DOW);

       // If target date is before first Monday, switch to prior year
       If DateIn < FirstMonday;
         Jan04Year   = Jan04Year - 1;
         Jan04DOW    = DayOfWeek(Jan04Date);
         FirstMonday = Jan04Date - %DAYS(Jan04DOW);
       Endif;

       // Return week number (number of full weeks since first Monday + 1)
       Return %DIV(%DIFF(DateIn:FirstMonday:*DAYS):7) + 1;

      /End-Free

     P WeekOfYear      E 
  


    RPGLE  - Prototype to retrive calling program name
Posted By: jimmy octane   Contact

H NoMain

      * Prototype
     D CallingPgm      PR            10
     D  DummyPrm                      1    Options( *Omit )

      * Get the calling program's name
     P CallingPgm      B                   Export

     D CallingPgm      PI            10
     D  DummyPrm                      1    Options( *Omit )

      * Local variables
     D MsgId           S              7    Inz( 'CPF9898' )
     D QlMsgf          S             20    Inz( 'QCPFMSG   *LIBL' )
     D MsgDta          S              1    Inz( *Blank )
     D LenMsgDta       S             10I 0 Inz( %Size( MsgDta ) )
     D MsgType         S             10    Inz( '*INFO' )
     D ClStkEntry      S             10
     D ClStkCounter    S             10I 0
     D MsgKey          S              4

     D ApiErr          DS
     D  AeBytesPrvd                  10U 0 Inz( 272 )
     D  AeBytesAvl                   10U 0
     D  AeMsgId                       7
     D                                1
     D  AeMsgDta                    256

     D MsgInf          DS
     D  MiBytesRetd                  10U 0
     D  MiBytesAvl                   10U 0 Inz( 120 )
     D  MiPgmName            111    120

     D LenMsgInf       S             10U 0 Inz( %Size( MsgInf ) )
     D FmtName         S              8    Inz( 'RCVM0200' )
     D WaitTime        S             10U 0 Inz( *Zero )
     D MsgAction       S             10    Inz( '*REMOVE' )

      * Send a dummy message to the calling program
     C                   Eval      ClStkEntry = '*PGMBDY'
     C                   Eval      ClStkCounter = 1

     C                   Call      'QMHSNDPM'
     C                   Parm                    MsgId
     C                   Parm                    QlMsgf
     C                   Parm                    MsgDta
     C                   Parm                    LenMsgDta
     C                   Parm                    MsgType
     C                   Parm                    ClStkEntry
     C                   Parm                    ClStkCounter
     C                   Parm                    MsgKey
     C                   Parm                    ApiErr

      * Receive the message back and pick up the program name
     C                   Eval      ClStkEntry = '*'
     C                   Eval      ClStkCounter = 0

     C                   Call      'QMHRCVPM'
     C                   Parm                    MsgInf
     C                   Parm                    LenMsgInf
     C                   Parm                    FmtName
     C                   Parm                    ClStkEntry
     C                   Parm                    ClStkCounter
     C                   Parm                    MsgType
     C                   Parm                    MsgKey
     C                   Parm                    WaitTime
     C                   Parm                    MsgAction
     C                   Parm                    ApiErr

     C                   Return    MiPgmName

     P CallingPgm      E 

==========call example=============

     D CallingPgm      PR            10
     D  DummyPrm                      1    Options( *Omit )

     D PgmName         S             10

     C                   Eval      PgmName = CallingPgm( *Omit ) 


  


    RPGLE  - Retrieve deleted records from file
Posted By: jimmy octane   Contact

D TotalC          S              9S 0
     D Len             S              9B 0 Inz( 265 )
     D Fmt             S              8    Inz( 'MBRD0200' )
     D FilNam          S             20    Inz( 'LOCDTP    LOCATOR   ' )
     D MbrNam          S             10    Inz( '*FIRST' )
     D OvrPrs          S              1    Inz( '0' )
     D Error           S             30

     D Out             DS           265
     D  BytRet                 1      4B 0
     D  BytAvl                 5      8B 0
     D  MbrName               29     38
     D  PFLF                 137    137
     D  Total                141    144B 0
     D  DelRcd               145    148B 0
     D  NoMbrs               157    160B 0

     C     APIList       PList
     C                   Parm                    Out
     C                   Parm                    Len
     C                   Parm                    Fmt
     C                   Parm                    FilNam
     C                   Parm                    MbrNam
     C                   Parm                    OvrPrs
     C                   Parm                    Error
     C                   Call      'QUSRMBRD'    APIList
     C                   Z-Add     Total         TotalC
     C     BytRet        Dsply
     C     BytAvl        Dsply
     C     MbrName       Dsply
     C     PFLF          Dsply
     C     TotalC        Dsply
     C     DelRcd        Dsply
     C     NoMbrs        Dsply
     C                   Eval      *InLR = *On
 


    RPGLE  - compile time array lookup example
Posted By: jimmy octane   Contact

*====================================                                 
      *
      *====================================                                 
     d CODE            s              2    DIM(8) CTDATA PERRCD(4)
     d DESC            s             10    DIM(4) CTDATA PERRCD(1)
     d x               s              3  0
     d INCODE          s              2
     d OUTDSC          s             10
      *
     c                   eval      x = 1
     c     INCODE        LOOKUP    CODE(x)                                99
     c                   if        %Found
     c                   eval      OUTDSC = %trim(DESC(X))
     c                   endif
      *
     c     *entry        plist
     c                   parm                    INCODE
     c                   parm                    OUTDSC
      *
     C                   eval      *INLR = *on
      *====================================                                 
**
A1A2A3A4
**
Import
Local
Production
Return  


    RPGLE  - Finding a pattern in a list
Posted By: Prithiviraj.D   Contact

* --  Input Date SplitUp                                     
DInDate           DS                                          
D Month                          2    Overlay(Indate)         
D Day                            2    Overlay(Indate:*Next)   
D Year                           4    Overlay(Indate:*Next)   

 * --  List Of Months with 31 Days                                 
D W31Days         S            100A   Inz('01 03 05 07 08 10 12')  

D InvalidDate     S               N   

C     *InzSr        BegSr                                               
C                                                                       
C     *Entry        PLIST                                               
C                   PARM                    MMDDYYYY                    
C                   PARM                    InvalidDate                 
C                                                                       
C                   If        MMDDYYYY <> *Blanks                       
C                   Eval      InDate = MMDDYYYY                         
C                   Else                                                
C                   Eval      InvalidDate = *On                         
C                   Eval      *Inlr = *On                               
C                   Return                                              
C                   EndIf                                               

Main Logic
/Free                                                          
         // Check whether the Month has 31 days
                   If %Scan(%Trim(Month):W31Days) > 0;         
                     If Day >= '01' And Day <= '31';           
                       InvalidDate = *Off;                     
                     Else;                                     
                       InvalidDate = *On;                      
                     EndIf;                                    
                   Else;                                       
                     If Day >= '01' And Day <= '30';           
                       InvalidDate = *Off;                     
                     Else;                                     
                       InvalidDate = *On;                      
                     EndIf;                                    
                   EndIf;                                      
/End-Free                                                       


    RPGLE  - Centering Text on a Display Field
Posted By: Prithiviraj.D   Contact

Simulation of IBM's logic for centering text in SDA

H DFTACTGRP(*NO) BNDDIR('QC2LE')                                        
                                                                        
FSEU       CF   E             WORKSTN                                   
                                                                        
D string          S             60A   Inz                               
D len             S              8  0 Inz                               
D diff            S              8  0 Inz                               
D i               S              8  0 Inz                               
D rem             S              8F   Inz                               
                                                                        
D abs             PR             8F   Extproc('fabs')                   
D  input                         8F                                     
                                                                        
C                   ExFmt     Center                                    
                                                                        
 /Free                                                                  
                  string = %trim(Cfld);                                 
                  len   = %len(%trim(string));                          
                  diff  = (60-len);                                     

                  rem = %div(diff:2);                            
                  i = abs(rem);                                  
 /End-Free                                                       
 * CFLD is the Screen fld and is in DDS screen   
 * CENTER                                                                 
C                   Eval      Cfld = *ALL' '                     
C                   Eval      Cfld = %replace(string:Cfld:i+1:0) 
                                                                 
C                   ExFmt     Center                             
C                   Eval      *Inlr = *On                         


    RPGLE  - API - QSYGETPH (validate Password)
Posted By: Jimmy Octane   Contact

V5R3 Version

       *this api validates an as400 username and password:
     DWkUser           S             10A   inz('FLANARY')
     DWKPassword       S             10A   inz('PIZZA')
     DProfileHandle    S             12A
     DPassWordLength   S             10i 0 inz(10)
     DCCSID            S             10i 0 inz(37)
     D*
     DQUSEC            DS
     D*                                             Qus EC
     D QUSBPRV                 1      4B 0
     D*                                             Bytes Provided
     D QUSBAVL                 5      8B 0
     D*                                             Bytes Available
     D QUSEI                   9     15
     D*                                             Exception Id
     D QUSERVED               16     16
     D*                                             Reserved
     D ERRC0100               17    274    Varying

     d error           S               n

     C*
     C                   Call      'QSYGETPH'
     C                   Parm                    WKUser
     C                   Parm                    WKPassword
     C                   Parm                    ProfileHandle
     C                   Parm                    QUSEC
     C                   Parm                    PasswordLength
     C                   Parm                    CCSID
     C*
     C                   If        QUSBAVL > 0
     C                   Eval      Error = *ON
     C                   Endif
     C*
     c                   eval      *inlr = *on 


    RPGLE  - RPGLE - Batch Program
Posted By: Michael Noll   Contact

h debug(*yes) option(*nodebugio:*expdds)
     ¹*
     ¹*****************************************************************
     ¹*    Program Name: O6TRKR              Author: Michael Noll     *
     ¹*                                                               *
     ¹*    Purpose: Print all open orders for a customer that have    *
     ¹*             'TRK' in the Price Category Code, or the product  *
     ¹*             description contains any of the following:        *
     ¹*                   'TRK' - 'EXTRUS' - 'ROD-'                   *
     ¹*             Or the Part Number is either of the following:    *
     ¹*                   'CUTTING CHARGE' - 'NONSTOCKTRACK'          *
     ¹*                                                               *
     ¹*             Include any Parent Part #'s for Kit Bills.        *
     ¹*             Include any comments for selected line items, as  *
     ¹*             well as any order comments.                       *
     ¹*                                                               *
     ¹*    Copyright  (c) 2004                                        *
     ¹*    Harken Incorporated                                        *
     ¹*                                                               *
     ¹*    This unpublished material is proprietary to Harken         *
     ¹*    Incorporated  All rights reserved  The methods and         *
     ¹*    techniques described herein are considered trade secrets   *
     ¹*    and/or confidential  Reproduction or distribution, in      *
     ¹*    whole or in part, is forbidden except by express written   *
     ¹*    permission of Harken Incorporation                         *
     ¹*                                                               *
     ¹*****************************************************************
     ¹*  To compile this program use PDM option 14.                   *
     ¹*  To debug, use DBGVIEW of *SOURCE when compiling.             *
     ¹*****************************************************************
     ¹* Modifications:                                                *
     ¹*  Int     Date      Description                                *
     ¹*  ----  ----------  --------------------------------------     *
     ¹*  hrk   07/14/2004  Added '*** REPRINT ***' verbiage to        *
     ¹*                    report. Using the O4FFC1 = 'R'.            *
     ¹*                                                               *
     ¹*  hrk1   9/22/2004  Added Barcode with Order #/Suffix to       *
     ¹*                    report.                                    *
     ¹*                                                               *
     ¹*  hrk2   9/29/2004  Added verbiage of '***COD***' for COD      *
     ¹*                    orders. Add verbiage of 'Consisting of'    *
     ¹*                    for kits, in the O5Comments.               *
     ¹*                                                               *
     ¹*  hrk3  10/12/2004  Clean up of comment lines printing for     *
     ¹*                    kits, when there were no track/extrus      *
     ¹*                    kits.                                      *
     ¹*                                                               *
     ¹*  hrk4  10/13/2004  Omit Parts that have been omitted through  *
     ¹*                    O6CUST program PMUSR = 'TRKOMT'            *
     ¹*                                                               *
     ¹*****************************************************************
     ¹*
     fcm1       if   e           k disk
     ¹* CM1P by Customer #
     ¹*
     fnf        if   e           k disk
     ¹* Notes File
     ¹*
     fo2        if   e           k disk
     ¹* O2P by Ord #, Sufx & Item
     ¹*
     fo4        if   e           k disk
     ¹* Sales Order Detail, Billing Header File
     ¹*
     fo5        if   e           k disk
     ¹* O5P by Ord #, Sufx & Item
     ¹*
     fo605      if   e           k disk
     ¹* Sales Order Detail, Line Items File
     ¹*
     foh        if   e           k disk
     ¹* OHP by Ord #, Sufx & Item
     ¹*
     fpm        if   e           k disk
     ¹* Product Master File
     ¹*
     fo6trkpr   o    e             printer oflind(overflow)
     f                                     infds(printer_ds)
     ¹* O6TRK Print File - by Customer #/Order #/Date Combination
     ¹*
     ¹*---------------------------------------------------------*
     ¹* System Data Structure                                   *
     ¹*---------------------------------------------------------*
     ¹*
     d                sds
     d  program          *proc
     d  status           *status
     d  username             254    263
     ¹*
     ¹*---------------------------------------------------------*
     ¹* Data Structures                                         *
     ¹*---------------------------------------------------------*
     ¹*
     ¹* Printer Info DS (get line # for Overflow)
     d printer_ds      ds
     d  line                 367    368b 0
     ¹*
     ¹* Indicator Data Structure
     d indicator       s               *   inz(%addr(*in))
     d                 ds                  based(indicator)
     d  overflow               1      1n
     d  numeric               91     91n
     d  alpha                 92     92n
     d  null                  93     93n
hrk  d  reprint               94     94n
hrk2 d  cod                   95     95n
     d  skip                  99     99n
     ¹*
     d @msg            ds            42
     d  type                   1      1
     d  #ord#                  2      7
     d  #sufx                  8      9
     d  #filler               10     42
     ¹*
     ¹*---------------------------------------------------------*
     ¹*  Constants                                              *
     ¹*---------------------------------------------------------*
     ¹*
     d cutting         c                   const('CUTTING CHARGE')
     d extrus          c                   const('EXTRUS')
     d extrusset       c                   const('EXTRUS SET')
     d nonstock        c                   const('NONSTOCKTRACK')
hrk4 d omit            c                   const('TRKOMT')
     d rod             c                   const('ROD-')
     d rollbatt        c                   const('ROLLER BATTEN')
     d track           c                   const('TRK')
     d trk_riser       c                   const('TRK RISER')
     ¹*
     ¹* Component Comment Lines
hrk2  *consist         c                   const('CONSISTING OF')
hrk2  *consst2         c                   const('.............................+
hrk2  *                                    .....................')
     ¹*
     ¹*---------------------------------------------------------*
     ¹*  Stand-Alone Fields                                     *
     ¹*---------------------------------------------------------*
     ¹*
     d item1           s              5  2 inz(.01)
     d item2           s              5  2 inz(.02)
     d note_type       s              2
     d null_date       s               d   datfmt(*iso)
     d ordtxt          s              8s 0 inz
hrk2 d order#          s              6s 0 inz
     d single_ord      s               n   inz(*off)
hrk2 d suffix          s              2s 0 inz
     d suffix1         s              2s 0 inz(-1)
hrk3 d svcomponent     s                   like(o6item)
     d svcust          s                   like(o4stky)
hrk3 d svitem          s              3s 0
     d svitem05        s                   like(o6item)
     d svitem06        s                   like(o6item)
     d svord#          s                   like(o6ord#)
     d svparent        s                   like(odpn)
     d svsufx          s                   like(o6sufx)
     d svprod          s                   like(odpn)
     d sv_item         s                   like(o6item)
hrk2 d sv_item6        s                   like(o6item)
     ¹*
     ¹* Date Work Fields
     d mdy_date        s               d   datfmt(*mdy)
     d prtdate         s               d   datfmt(*iso)
     d reqdate         s               d   datfmt(*iso)
     d today           s               d   datfmt(*iso)
     d today_min1      s               d   datfmt(*iso)
     ¹*
     ¹*---------------------------------------------------------*
     ¹* Key Lists                                               *
     ¹*---------------------------------------------------------*
     ¹*
     ¹* NF Key List (Type, Numb)
     c     k_nf          klist
     c                   kfld                    note_type
     c                   kfld                    odcarr
     ¹*
     ¹* O2 Key List (Ord#, Sufx, Item) - Bill To Override
     c     k_o2bill      klist
     c                   kfld                    order#
     c                   kfld                    suffix1
     c                   kfld                    item2
     ¹*
     ¹* O2 Key List (Ord#, Sufx, Item) - Ship To Override
     c     k_o2          klist
     c                   kfld                    order#
     c                   kfld                    suffix1
     c                   kfld                    item1
     ¹*
     ¹* O4 Key List (Ord#, Sufx, Item)
     c     k_o4          klist
     c                   kfld                    order#
     c                   kfld                    suffix
     ¹*
     ¹* O5 Key List (Ord#, Sufx, Item)
     c     k_o5          klist
     c                   kfld                    order#
     c                   kfld                    suffix
     c                   kfld                    svitem05
     ¹*
     ¹* O605 Key List (BkyY, Ord#, Sufx, Pn)
     c     k_o6          klist
     c                   kfld                    svord#
     c                   kfld                    svsufx
     c                   kfld                    svitem06
     ¹*
     ¹* O605 Key List (BkyY, Ord#, Sufx, Pn)
     c     k_o605        klist
     c                   kfld                    o4ord#
     c                   kfld                    o4sufx
     ¹*
     ¹*---------------------------------------------------------*
     ¹* Mainline - Main Processing                              *
     ¹*---------------------------------------------------------*
     ¹*
     c                   dou       %eof(o4)
     ¹*
     c                   read      o4
     c                   if        not %eof(o4)
     c     k_o605        setll     o605
     c                   read      o605
     c     o4ord#        chain     oh
hrk  c                   if        odprtd  <> *zeros
     c                   eval      prtdate  = %date(odprtd: *mdy)
hrk  C                   else
     c                   eval      prtdate  = null_date
     c                   end
     ¹*
     c                   if        prtdate >= today
     c                             or  @msg    <> *blanks
hrk  c                   if        o4ffc1   = 'R'
hrk  c                   eval      reprint  = *on
hrk  c                   else
hrk  c                   eval      reprint  = *off
hrk  c                   end
     c                   write     rhead
     c                   if        @msg     = *blanks
     c                   eval      order#   = o4ord#
     c                   eval      suffix   = o6sufx
     c                   end
     c                   exsr      $header
     c                   exsr      $detail
hrk  c                   else
hrk  c                   iter
     c                   end
     c                   end
     ¹*
     c                   if        single_ord
     c                   leave
     c                   end
     ¹*
     c                   enddo
     ¹*
     c                   eval      *inlr     = *on
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $Header - Set Up Header Fields                          *
     ¹*---------------------------------------------------------*
     ¹*
     c     $header       begsr
     ¹*
     c                   eval      skip  = *off
     ¹* Clear Ship To Fields
     c                   clear                   sst#1
     c                   clear                   sst#2
     c                   clear                   sst#3
     c                   clear                   sst#4
     c                   clear                   sst#5
     ¹* Clear Sold To Fields
     c                   clear                   sbt#1
     c                   clear                   sbt#2
     c                   clear                   sbt#3
     c                   clear                   sbt#4
     c                   clear                   sbt#5
     ¹*
     ¹* Get Sold To Info
     c     k_o2bill      chain(e)  o2
     c                   if        %found(o2)
     c                   eval      sbt#1 = odname
     c                   if        odadr2  <> *blanks
     c                   eval      sbt#2 = odadr2
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#2 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        odadr3  <> *blanks
     c                   eval      sbt#3 = odadr3
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#3 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        odadr4  <> *blanks
     c                   eval      sbt#4 = odadr4
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#4 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        sbt#2 <> *blanks
     c                             and sbt#3 <> *blanks
     c                             and sbt#4 <> *blanks
     c                             and not skip
     c                   eval      sbt#5 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *off
     c                   else
     c                   eval      sbt#5     = *blanks
     c                   end
     c                   end
     c                   if        not %found(o2)
     c     ohbtky        chain(e)  cm1
     c                   if        %found(cm1)
     c                   eval      sbt#1    = cmname
     c                   if        cmlne1  <> *blanks
     c                   eval      sbt#2    = cmlne1
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#2 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        cmlne2  <> *blanks
     c                   eval      sbt#3    = cmlne2
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#3 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        cmlne3  <> *blanks
     c                             and not skip
     c                   eval      sbt#4    = cmlne3
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sbt#4 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        sbt#2 <> *blanks
     c                             and sbt#3 <> *blanks
     c                             and sbt#4 <> *blanks
     c                             and not skip
     c                   eval      sbt#5 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *off
     c                   else
     c                   eval      sbt#5     = *blanks
     c                   end
     c                   else
     c                   eval      sbt#1    = *blanks
     c                   eval      sbt#2    = *blanks
     c                   eval      sbt#3    = *blanks
     c                   eval      sbt#4    = *blanks
     c                   eval      sbt#5    = *blanks
     c                   end
     c                   end
     ¹*
     c                   eval      skip  = *off
     ¹* Get Ship To Info
     c     k_o2          chain(e)  o2
     c                   if        %found(o2)
     c                   eval      sst#1  = odname
     c                   if        odadr2 <> *blanks
     c                   eval      sst#2  = odadr2
     c                   eval      skip   = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#2 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        odadr3  <> *blanks
     c                   eval      sst#3 = odadr3
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#3 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        odadr4  <> *blanks
     c                   eval      sst#4 = odadr4
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#4 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        sst#2 <> *blanks
     c                             and sst#3 <> *blanks
     c                             and sst#4 <> *blanks
     c                             and not skip
     c                   eval      sst#5 = %subst(odadr5: 1: 20) + ' '         +
     c                             %subst(odadr5: 21)
     c                   eval      skip  = *off
     c                   else
     c                   eval      sst#5     = *blanks
     c                   end
     c                   end
     c                   if        not %found(o2)
     c     o4stky        chain(e)  cm1
     c                   if        %found(cm1)
     c                   eval      sst#1    = cmname
     c                   if        cmlne1  <> *blanks
     c                   eval      sst#2    = cmlne1
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#2 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        cmlne2  <> *blanks
     c                   eval      sst#3    = cmlne2
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#3 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        cmlne3  <> *blanks
     c                             and not skip
     c                   eval      sst#4    = cmlne3
     c                   eval      skip  = *off
     c                   else
     c                   if        not skip
     c                   eval      sst#4 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *on
     c                   end
     c                   end
     c                   if        sst#2 <> *blanks
     c                             and sst#3 <> *blanks
     c                             and sst#4 <> *blanks
     c                             and not skip
     c                   eval      sst#5 = cmcity + ' ' + cmst  + ' ' + cmzip
     c                   eval      skip  = *off
     c                   else
     c                   eval      sst#5     = *blanks
     c                   end
     c                   end
     c                   end
     ¹*
     c                   eval      order#   = o4ord#
     c                   eval      suffix   = o4sufx
     c                   eval      po#      = ohspo#
     c                   if        ohentd  <> *zeros
     c     *mdy          move      ohentd        mdy_date
     c                   move      mdy_date      p_ordd
     c                   end
     c                   if        o6reqd  <> *zeros
     c                   eval      mdy_date = %date(o6reqd: *mdy)
     c                   move      mdy_date      p_shpd
     c                   end
     ¹*
     c                   eval      note_type = 'CC'
     ¹* Get Carrier Name
     c     k_nf          chain(e)  nf
     c                   if        %found(nf)
     c                   eval      p_carr   = nfdesc
     c                   else
     c                   eval      p_carr   = *blanks
     c                   end
     ¹*
     ¹* Ship Via
     c                   if        odinst  <> *blanks
     c                   eval      p_via    = odinst
     c                   else
     c                   eval      p_via    = odvia
     c                   end
     ¹*
     ¹* Barcode
hrk1 c                   eval      ordertxt = %char(o4ord#)
hrk1 c                              + %editc(o6sufx: 'X')
     ¹*
     ¹* Verbiage '***COD***'
hrk2 c                   if        %scan('COD': ohnot1) > *zeros
hrk2 c                             or %scan('COD': ohnot2) > *zeros
hrk2 c                             or %scan('COD': ohnot3) > *zeros
hrk2 c                             or %scan('COD': ohnot4) > *zeros
hrk2 c                             or %scan('COD': ohnot5) > *zeros
hrk2 c                   eval      cod = *on
hrk2 c                   else
hrk2 c                   eval      cod = *off
hrk2 c                   end
     ¹*
     ¹* Write Out Headings
     c                   if        not overflow
     c                   write     rheader
     c                   write     rhead2
     c                   else
     c                   exsr      $overflow
     c                   write     rheader
     c                   write     rhead2
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $Detail - Setup Detail Fields                           *
     ¹*---------------------------------------------------------*
     ¹*
     c     $detail       begsr
     ¹*
     c                   clear                   svitem05
     c                   clear                   svitem06
hrk3 c                   clear                   svcomponent
hrk3 c                   clear                   sv_item6
     ¹*
     ¹* Write any comments
     c                   eval      sv_item  = item1
     c                   exsr      $o5comment
     ¹*
     c                   dou       o6ord# <> order#
     c                             or o6sufx <> suffix
     c                             or %eof(o605)
     ¹*
     c                   exsr      $desc
     ¹*
     c                   if        %scan(track: odpcc)      > *zeros
     c                             or %scan(track: pmdesc)  > *zeros
     c                             or %scan(extrus: pmdesc) > *zeros
     c                             or %scan(rod: pmdesc)    > *zeros
     c                             or %scan(nonstock: odpn) > *zeros
     c                             or %scan(cutting: odpn)  > *zeros
     c                             or %scan(rollbatt: pmdesc) > *zeros
     ¹*
     ¹* Skip and Extrus Set or TRK Riser Parts
     c                   if        %scan(extrusset: p_desc) = *zeros
     c                             and %scan(trk_riser: p_desc) = *zeros
hrk4 c                             and pmusr3 <> omit
     ¹*
     c                   if        odxtrf = 'P'
     c                   read      o605
     c                   iter
     c                   end
     ¹*
     ¹* If Component Part, Get Parent #/Description/Comments
     c                   if        odxtrf = 'C'
     c                   eval      svcust = o4stky
     c                   eval      svord# = o4ord#
     c                   eval      svsufx = o4sufx
     c                   eval      svprod = odpn
hrk2 c                   eval      svitem06 = sv_item
hrk2 c                   eval      sv_item6 = o6item
     ¹*
     ¹* Find last component in kit
     c                   dou       odxtrf <> 'C'
     c                   read      o605
     c                   if        odxtrf <> 'C'
     c                   readp     o605
     c                   eval      svcomponent = o6item
     c                   if        o6item   > sv_item6
     c                   dou       o6item   = sv_item6
     c                   readp     o605
     c                   enddo
     c                   endif
     c                   leave
     c                   endif
     c                   end
     ¹*
     c                   exsr      $parent
hrk2 c                   eval      svitem06 = sv_item6
     c     k_o6          setll     o605
     c                   read      o605
     c                   exsr      $desc
     c                   end
     ¹*
     c                   eval      svitem06 = o6item
     c                   eval      sv_item6 = o6item
     c                   eval      p_wh     = odloc#
     c                   eval      p_ordq   = odbalq
     c                   eval      p_ords   = odrelq
     c                   eval      p_ordb   = odbalq - odrelq
     c                   eval      p_part#  = odpn
     c                   if        odprmd  <> *zeros
     c                   eval      mdy_date = %date(odprmd: *mdy)
     c                   move      mdy_date      p_reqd
     c                   end
     ¹*
     ¹* Write O6 Record
     c                   exsr      $o6write
     ¹*
     ¹* Write any line item comments
hrk3 c                   if        o6item  <> svcomponent
hrk3 c                   eval      svitem05 = o6item
hrk3 c                   exsr      $o5comment
hrk3 c                   end
     ¹*
     c                   end
     c                   end
     ¹*
     c                   read      o605
     ¹*
     ¹* Write any missed line item comments
hrk3 c                   if        o6item  > svcomponent
hrk3 c                             and svcomponent <> *zeros
hrk3 c                   readp     o605
hrk3 c                   eval      svitem05 = o6item
hrk3 c                   exsr      $o5comment
hrk3 c                   read      o605
hrk3 c                   end
     ¹*
     c                   enddo
     ¹*
     ¹* Write any comments after all O6 Records
hrk3 c                   if        svcomponent <> *zeros
hrk3 c                   readp     o605
hrk3 c                   eval      svitem05 = o6item
     c                   exsr      $o5comment
hrk3 c                   end
     ¹*
     c                   if        not %eof(o605)
     c                   exsr      $overflow
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $Desc - Get Part Description                            *
     ¹*---------------------------------------------------------*
     ¹*
     c     $desc         begsr
     ¹*
     ¹* Get Part # Description
     c     odpn          chain(e)  pm
     c                   if        %found(pm)
     c                   eval      p_desc = pmdesc
     c                   else
     c                   eval      p_desc = *blanks
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $Parent - Get Parent Part #                             *
     ¹*---------------------------------------------------------*
     ¹*
     c     $parent       begsr
     ¹*
     c                   dou       odxtrf   = 'P'
     ¹*
     c                   readp     o605
     ¹*
     c                   if        odxtrf   = 'P'
     c                             and svparent <> odpn
     c                   eval      p_wh     = odloc#
     c                   eval      p_ordq   = odorgq
     c                   eval      p_ords   = odshpq
     c                   eval      p_ordb   = odbalq
     c                   eval      p_part#  = odpn
     c                   if        odprmd  <> *zeros
     c                   eval      mdy_date = %date(odprmd: *mdy)
     c                   move      mdy_date      p_reqd
     c                   end
     c                   exsr      $desc
     c                   eval      svparent = odpn
     c                   exsr      $o6write
     c                   eval      svitem05 = o6item
     c                   eval      sv_item  = o6item
     c                   exsr      $o5comment
     c                   end
     ¹*
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $O6Write - Print o6 Detail Line(s) per Product          *
     ¹*---------------------------------------------------------*
     ¹*
     c     $o6write      begsr
     ¹*
     c                   if        not overflow
     c                   write     ro6p
     c                   else
     c                   write     roflwp
     c                   exsr      $overflow
     c                   write     rheader
     c                   write     rhead2
     c                   write     ro6p
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $O5Comment - Print O5 Comment Line(s) (Per product)     *
     ¹*---------------------------------------------------------*
     ¹*
     c     $o5comment    begsr
     ¹*
hrk3 c                   eval      svitem = o6item + 1
     c     k_o5          setll(e)  o5
     ¹*
     c                   dou       o5ord# <> order#
     c                             or o5sufx <> suffix
     ¹*
     ¹* Get Product Comment Lines
     c                   read(e)   o5
     ¹*
     c                   if        not %eof(o5)
     c                             and o5ord#  = order#
     c                             and o5sufx  = suffix
     ¹*
hrk3 c                   if        (o5item    > o6item
hrk3 c                             and o5item < sv_item6)
     ¹*
hrk3 c                             or (odxtrf = 'C'
hrk3 c                             and o5item > o6item
hrk3 c                             and o6item = svcomponent
hrk3 c                             and o5item = svcomponent + .5
hrk3 c                             and o5item < svitem)
     ¹*
hrk3 c                             or (odxtrf = *blanks
hrk3 c                             and o5item >= o6item + .5
hrk3 c                             and o5item < svitem
hrk3 c                             and sv_item6 <> *zeros)
     ¹*
hrk3 c                             or (o5item < 1)
     ¹*
     c                   if        not overflow
     c                   write     ro5p
     c                   eval      sv_item  = o5item
     c                   else
     c                   write     roflwp
     c                   exsr      $overflow
     c                   write     rheader
     c                   write     rhead2
     c                   write     ro5p
     c                   eval      sv_item  = o5item
     c                   end
     ¹*
     c                   else
     ¹*
     c                   eval      sv_item  = o5item
     c                   leave
     ¹*
     c                   end
     ¹*
     c                   else
     ¹*
hrk2 c                   eval      o5item   = sv_item
     c                   leave
     ¹*
     c                   end
     ¹*
     c                   end
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* $Overflow - Overflow                                    *
     ¹*---------------------------------------------------------*
     ¹*
     c     $overflow     begsr
     ¹*
     c                   dou       line = 66 or overflow
     c                   write     blank
     c                   end
     ¹*
     c                   write     blank
     c                   eval      overflow  = *off
     ¹*
     c                   endsr
     ¹*
     ¹*---------------------------------------------------------*
     ¹* *InzSr - Initialization                                 *
     ¹*---------------------------------------------------------*
     ¹*
     c     *inzsr        begsr
     ¹*
     c     *entry        plist
     c                   parm                    @msg
     ¹*
     c                   eval      today  = %date()
     c                   clear                   svcust
     c                   clear                   svitem05
     c                   clear                   svitem06
     c                   clear                   svord#
     c                   clear                   svsufx
     c                   clear                   svprod
     ¹*
     c                   if        #ord#      <> *blanks
     c                   testn                   #ord#                919293
     c                   if        numeric
     c                   move      #ord#         order#
     c                   else
     c                   clear                   order#
     c                   end
     c                   testn                   #sufx                919293
     c                   if        numeric
     c                   move      #sufx         suffix
     c                   else
     c                   clear                   #sufx
     c                   end
     c                   eval      single_ord  = *on
     c     k_o4          setll     o4
     c                   else
     c                   eval      single_ord  = *off
     c                   end
     ¹*
     c                   endsr
     ¹*
  


    RPGLE  - Example For Copy Book
Posted By: Sam400   Contact

Copy Book Illustartion.

/* Main Program CBR1 */

FEMPCB     UF A E             DISK                
C                   IF        *IN55 = *ON         
C*                  EVAL      *INLR = *ON         
C                   ENDIF                         
C                   IF        *IN55 = *OFF        
C                   EXSR      T8                  
C                   ENDIF                         
C                   EXSR      T9                  
C/COPY $CB1                                       
C/COPY $CB2                                       
C     T8            BEGSR                         
C                   move      'X1'          EMPID 
C                   move      'X'           EMPFN 
C                   move      'XY'          EMPLN 
C                   WRITE     RECCB               
C                   EVAL      *IN55 = *ON         
C                   ENDSR

=======================================================

/* Copy Book CB$1 */

C**************************************************
c     T9            begsr                                 
c                   call      'CBR2'                      
c                   exsr      T7                          
c                   endsr                                 
C**************************************************

=======================================================

/* Copy Book CB$2 */

C**************************************************
c     T7            begsr                                 
c                   call      'CBR3'                      
C                   EVAL      *INLR = *ON                 
c                   endsr                                 
C**************************************************

=======================================================

/* Program CBR2 */

FEMPCB     UF A E             DISK                                     
                                                                       
C                   DOW       *IN45 = *OFF                             
C                   read      EMPCB                                  45
C                   IF        *IN45 = *ON                              
C                   EVAL      *INLR = *ON                              
C                   ENDIF                                              
C                   ENDDO                                              

=======================================================

/* Program CBR2 */

FEMPCB     UF A E             DISK                  
                                                    
C                   IF        *IN65 = *OFF          
C                   move      'X2'          EMPID   
C                   move      'A'           EMPFN   
C                   move      'AB'          EMPLN   
C                   WRITE     RECCB                 
C                   EVAL      *IN65 = *ON           
C                   ENDIF                           
C                   EVAL      *INLR = *ON           

=======================================================

/* Physical File - EMPCB */

                R RECCB              
                  EMPID         10A  
                  EMPFN         50A  
                  EMPLN         50A  

======================================================= 


    RPGLE  - Random
Posted By: Jaime López Patiño   Contact

dCOSEED           s              5i 0                             
dCORNDNBR         s              8f                               
dNUMGEN           s             10i 0                             
dNUMERO           s              3  0                             
 *                                                                
c                   callb     'CEERAN0'                           
c                   parm                    COSEED                
c                   parm                    CORNDNBR              
c                   parm                    *omit                 
 *                                                                
c                   eval      NUMERO = CORNDNBR * 1000            
c                   exsr      F3EXIT                              
 *                                                                
 *================================================================
 * Terminar programa                                              
 *================================================================
 *                                                                
c     F3EXIT        begsr                                         
 *                                                                   
 *%.. terminate program                                              
c                   eval      *inlr = *on                            
 *                                                                   
c                   endsr                                            
 *                                                                    


    RPGLE  - the trigger for file
Posted By: xichun Wang   Contact

1,create file in dds
[code]
     A          R CUSREC                    TEXT('CLIENT')           
     A            CUSNUM         6S 0       TEXT('CUST#')            
     A            CUSIDX         6S 0       TEXT('INDEX')            
     A                                      DFT(10)                  
     A            CUSNAM        30O         TEXT('CUST NAME')        
     A            CUSPHN        10O         TEXT('CUST PHONE#')      
     A            CUSSLS         4S 0       TEXT('CUSTS SALESPERSON')
     A          K CUSNUM                                             
[/code]

2,create dtaara clientda:
CRTDTAARA DTAARA(WXC999/CLIENTDA) TYPE(*CHAR) LEN(6) VALUE('000006')

3,create rpgle:
[code]
DCLIENTDA         DS                  Dtaara(CLIENTDA)            
D  Last#                         6S 0                            
*                                                                
DpBefore          S               *                              
DpAfter           S               *                              
*                                                                
DBefore         E DS                  ExtName(CLIENT) Prefix(B_) 
D                                     Based(pBefore)              
DAfter          E DS                  ExtName(CLIENT) Prefix(A_) 
D                                     Based(pAfter)              
*--------------------------------------------------------------- 
*  Trigger Buffer and Trigger Buffer Length Declarations        
*--------------------------------------------------------------- 
DBufferLen        S             10I 0         
 *
 *                   
DTrigBuff         DS                  
D  TrigFile                     10A   
D  TrigLib                      10A   
D  TrigMbr                      10A   
D  TrigEvent                     1A   
D  TrigTime                      1A   
D  TrigCommit                    1A   
D  TrigRes1                      3A   
D  TrigCCSID                    10I 0 
D  TrigRRN                      10I 0 
D  TrigRes2                      4A   
D  TrigB4OS                     10I 0 
D  TrigB4Len                    10I 0 
D  TrigB4NBM                    10I 0 
D  TrigB4NBL                    10I 0 
D  TrigAftOS                    10I 0 
D  TrigAftLen                   10I 0 
D  TrigAfNBM                    10I 0 
D  TrigAfNBL                    10I 0                        
*----------------------------------------------------------------- 
*   Trigger Constants                                              
*----------------------------------------------------------------- 
D@Insert          C                   '1'                          
D@Delete          C                   '2'                          
D@Update          C                   '3'                          
D@Before          C                   '2'                          
D@After           C                   '1'                          
*----------------------------------------------------------------- 
*  Input parameters are passed automatically when the trigger      
*  fires. Passed are the trigger buffer and trigger buffer length. 
*----------------------------------------------------------------- 
C     *Entry        PList                                          
C                   Parm                    TrigBuff                
C                   Parm                    BufferLen              
*----------------------------------------------------------------- 
*  Map the data structures for the before and after images to      
*  the offset location in the trigger buffer using pointers.      
*----------------------------------------------------------------- 
C                   Eval      pBefore = %Addr(TrigBuff) + TrigB4OS 
C                   Eval      pAfter = %Addr(TrigBuff) + TrigAftOS 
*                                                                  
*----------------------------------------------------------------- 
*  Only assign employee number on inserts.                        
*----------------------------------------------------------------- 
C                   If        TrigEvent = @Insert                  
*----------------------------------------------------------------- 
C     *Lock         In        CLIENTDA                              
C                   Eval      LAST# = LAST# + 1                    
C                   Out       CLIENTDA                              
C                   Eval      A_CUSIDX = LAST#                      
C                   Endif                                          
*                                                                  
C                   Return                                          
[/code]

4,create trigger for file
[code]ADDPFTRG FILE(EMPLOYEE) TRGTIME(*BEFORE)+ 
TRGEVENT(*INSERT) PGM(DB006R) ALWREPCHG(*YES) 
[/code] 


    RPGLE  - To write the record count to the PF
Posted By: Nanda Kishore Perisetla   Contact

FRECCNT  IF  E                    DISK
     FCOUNTF  O   E                    DISK
     C*          *ENTRY    PLIST
     C*                    PARM           TFILE  10
     C*                    PARM           TCOUNT 10
     C                     READ QWHFDMBR                 40
     C           *IN40     DOWEQ*OFF
     C                     MOVELMBFILE    FILE
     C                     MOVE MBNRCD    COUNT
     C                     WRITECOUNTFR
     C                     READ QWHFDMBR                 40
     C                     ENDDO
     C*                    MOVE TCOUNT    TEMP   100
     C*                    MOVELTFILE     FILE
     C*                    MOVE TEMP      COUNT
     C*                    WRITECOUNTFR
     C                     SETON                     LR 


    RPGLE  - Free check for numberic in char field (FREE)
Posted By: bob cozzi   Contact

If  %Check('0123456789': myField) > 0
// you have non-numeric data in the fields
Else
// the field is all numeric. It is okay!
Endif
  


    RPGLE  - thank for you help
Posted By: WENGZHANGLIN   Contact

I am a beginner 


    RPGLE  - RPGLE Free format bit operation
Posted By: Tho Phan   Contact

¹*---------------------------------------------------------------------
     ¹*
     ¹*       |0|1|2|3|4|5|6|7|      One byte in OS400
     ¹*
     ¹*    |0|1|2|3|     |4|5|6|7|   Divide into two for hex presenstation
      *    High order    Low order
      *       bit           bit
     ¹*
     ¹*    |8|4|2|1|     |8|4|2|1|   Hex numerical number per bit
     ¹*
     ¹*
     ¹*    | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |
     ¹*                                         Decimal number per bit
     ¹*      1   6   3   1   8   4   2   1
     ¹*      2   4   2   6
     ¹*      8
     ¹*---------------------------------------------------------------------
     ¹*
     ¹*    |1|0|0|0|     |0|0|0|0|   Bit 0 = x'80'
     ¹*                               or Bit 0 = 128

     ¹*    |0|1|0|0|     |0|0|0|0|   Bit 1 = x'40'
     ¹*                               or Bit 1 = 64

     ¹*    |0|0|1|0|     |0|0|0|0|   Bit 2 = x'20'
     ¹*                               or Bit 2 = 32

     ¹*    |0|0|0|1|     |0|0|0|0|   Bit 3 = x'10'
     ¹*                               or Bit 3 = 16

     ¹*    |0|0|0|0|     |1|0|0|0|   Bit 4 = x'08'
     ¹*                               or Bit 4 = 8

     ¹*    |0|0|0|0|     |0|1|0|0|   Bit 5 = x'04'
     ¹*                               or Bit 5 = 4

     ¹*    |0|0|0|0|     |0|0|1|0|   Bit 6 = x'02'
     ¹*                               or Bit 6 = 2

     ¹*    |0|0|0|0|     |0|0|0|1|   Bit 7 = x'01'
     ¹*                               or Bit 7 = 1


     ¹*    On & Off fields are defined as:
     ¹*
     ¹*     Off             s              1    Inz(x'00')
     ¹*     On              s              1    Inz(x'FF')
     ¹*     Alpha           s              1    Inz(x'F0')
     ¹*     Pack            s              1    inz(x'40')
     ¹*
     ¹*
     ¹*
     ¹*               Test Bit 0 of Pack field for On
     ¹*                  If %BitAnd(Pack:x'80')=x'80'
     ¹*               Or
     ¹*                  IF %BitAnd(Pack:128)=128     Numeric field
     ¹*
     ¹*               Set bit 4 of field Alpha to On
     ¹*                  Alpha = %BitOr(Alpha:%BitAnd(On:x'08'))
     ¹*                  Alpha = %BitOr(Alpha:%BitAnd(x'FF':x'08'))
     ¹*               Or
     ¹*                  Alpha = %BitOr(Alpha:%BitAnd(On:8)=8))
     ¹*
     ¹*
     ¹*               If bit 0 of Pack field is On
     ¹*                    then set bit 4 of field Alpha to On
     ¹*                  If %BitAnd(Pack:x'80')=x'80'
     ¹*                     Alpha = %BitOr(Alpha:%BitAnd(On:x'08'))
     ¹*                  Endif
     ¹*
     ¹*               Test Bit 1 for on
     ¹*                  *In01 = %BitAnd(Pack:x'40')=x'40'
     ¹*                  *In01 = %BitAnd(Pack:64)=64
     ¹*               Or If bit 1 of pack field is On
     ¹*                  then set bit 5 of field Alpha to On
     ¹*               Alpha = %BitOr(Alpha:%BitAnd(On:x'04'))
     ¹*               Alpha = %BitOr(Alpha:%BitAnd(On:4)=4))
     ¹*
     ¹*               Test Bit 2 for on
     ¹*                  *In01 = %BitAnd(Pack:x'20')=x'20'
     ¹*                  *In01 = %BitAnd(Pack:32)=32
     ¹*               Or If bit 2 of pack field is On
     ¹*                  then set bit 6 of field Alpha to On
     ¹*               Alpha = %BitOr(Alpha:%BitAnd(On:x'02'))
     ¹*               Alpha = %BitOr(Alpha:%BitAnd(On:2)=2))
     ¹*
     ¹*               Test Bit 3 for on
     ¹*                  IF %BitAnd(Pack:x'10')=x'10'
     ¹*                  IF %BitAnd(PacK:16)=16
     ¹*               If bit 3 of pack field is On
     ¹*                then set bit 7 of field Alpha to On
     ¹*                   Alpha = %BitOr(Alpha:%BitAnd(On:x'01'))
     ¹*                   Alpha = %BitOr(Alpha:%BitAnd(On:1)=1))
     ¹*
     ¹* Summary:
     ¹*   Bit Off operation
     ¹*     Off defined as x'00'
     ¹*
     ¹*            Bit Off bit 4 of Alpha field
     ¹*               Alpha = %BitAnd(Alpha:8=(%BitAnd(Off:x'01')=x'01'))
     ¹*               Alpha = %BitAnd(Alpha:8=(%BitAnd(x'00':x'01')=x'01'))
     ¹*            Or
     ¹*               Alpha = %BitOr(Alpha:8=(%BitOr(Off:1)=1))
     ¹*               Alpha = %BitOr(Alpha:8=(%BitOr(x'00':1)=1))
     ¹*
     ¹*
     ¹*   Bit On operation
     ¹*     On defined as x'FF'
     ¹*
     ¹*            Bit On bit 4 of Alpha field
     ¹*               Alpha = %BitAnd(Alpha:8=(%BitAnd(On:x'01')=x'01'))
     ¹*               Alpha = %BitAnd(Alpha:8=(%BitAnd(x'FF:x'01')=x'01'))
     ¹*            Or
     ¹*               Alpha = %BitOr(Alpha:8=(%BitOr(On:1)=1))
     ¹*               Alpha = %BitOr(Alpha:8=(%BitOr(x'FF':1)=1))
     ¹*
     ¹*   Test Bit operation
     ¹*               Test Bit 0 of Pack field for On
     ¹*                  If %BitAnd(Pack:x'80')=x'80'
     ¹*               Or
     ¹*                  IF %BitAnd(Pack:128)=128
     ¹*

     d A               s              1    Inz(x'F0')
     d Off             s              1    Inz(x'00')
     d On              s              1    Inz(x'FF')
     d Pack            s              1    inz(x'40')
     ¹*
      /Free
         If %Bitand(Pack:x'80')=x'80';
       //    If bit 0 of Pack is On
           A = %BitOr(A:%bitand(On:x'08'));
       //    Then set bit 4 of Alpha to On
         EndIf;


         If %Bitand(Pack:x'40')=x'40';
       //    If bit 1 of Pack is On
           A = %BitOr(A:%bitand(On:x'04'));
       //    Then set bit 5 of Alpha to On
         EndIf;


         If %Bitand(Pack:x'20')=x'20';
       //    If bit 2 of Pack is On
           A = %BitOr(A:%bitand(On:x'02'));
       //    Then set bit 6 of Alpha to On
         EndIf;


         If %Bitand(Pack:x'10')=x'10';
       //    If bit 3 of Pack is On
           A = %BitOr(A:%bitand(On:x'01'));
       //    Then set bit 7 of Alpha to On
         EndIf;

         Return;

      /End-Free
     ¹******************************************
 


    RPGLE  - Update dataarea from within RPG program
Posted By: jimmy octane - dataarea update   Contact

*=================================================================
      * data area somespace is created in QTEMP for the example
      * This program takes in a 256 char string of data from a dataarea
      * then it breaks the fields up using a data-structure and then
      * updates info in the dataarea usind the data-structure and the
      * OUT opcode.
      *==================================================================
      *
     d                SDS
     d  @PGM                 001    010
     d  @PARMS               037    039  0
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0
      *
      * Variable Definition
      *
     d AreaName        s             10    inz('SomeSpace')
     d CmdString       s            256
     d CmdLength       s             15  5
     d Q               s              1    inz('''')
     d TodayIso        s               D
      *
      * you may also use a physical file to define the
      * fields rather than defining them in
      * the program.
      *
     d**>somespace     e ds                  extname(DTAAPF)
      *
      * else it would look like this
      *
     d someSpaceDS     ds           256     dtaara(SomeSpace)inz
     d  PgmUser                      10
     d  PgmDate                       8  0
     d  PgmTime                       6  0
     d  PgmSeq                        7  0
     d  Therest                     225

      *
      * ================================================
      *            M A I N   L I N E
      * ================================================
      *
      * Create the data area in qtemp
      * CRTDTAARA DTAARA(QTEMP/DATAAREA) TYPE(*CHAR) LEN(256) TEXT('test data area')
      *
     c                   eval      CmdString = 'CRTDTAARA DTAARA(QTEMP/'+
     c                             %trim(AreaName) + ' ) TYPE(*CHAR) LEN(256)' +
     c                             ' TEXT(' + Q + 'test data area' + Q + ')'
     c                   eval      CmdLength = %len(%trim(CmdString))
     c                   call(e)   'QCMDEXC'
     c                   parm                    CmdString
     c                   parm                    CmdLength
      *
      * get the info from the data area - we lock it cause we are going to
      * update
      *
     c     *lock         in        somespaceDs
      *
      *  populate the data structure
      *
     c                   if        PgmUser = *blanks
     c                   clear                   PgmSeq
     c                   endif
      *
     c                   eval      PgmUser = @User
     c                   eval      TodayIso = %date()
     c                   clear                   PgmDate
     c                   eval      PgmDate =
     c                             %uns(%char(%Date():*Iso0))
      *
     c                   clear                   PgmTime
     c                   time                    PgmTime
      *
      * Increment the counter
      *
     c                   eval      PgmSeq += 1
      *
     c                   out       somespaceDs
      *
     c                   eval      *INLR = *on  


    RPGLE  - Blok
Posted By: mykotaksurat@yahoo.com   Contact

‚***---------------------------------------------------------------------------------------***€
     ‚***€   Program Name  : CHKBLO                                                            ‚***€
     ‚***€   Description   : CHECK BLOCK PROCESSING                                            ‚***€
     ‚***€   Date created  : 12/03/2005€                                                       ‚***€
     ‚***€   Created by    : Puji     €                                                        ‚***€
     ‚***---------------------------------------------------------------------------------------***€
     ‚***€                                                                                     ‚***€
     ‚***€   Modification logs :€                                                              ‚***€
     ‚***€                                                                                     ‚***€
     ‚***€   Init€ Ref.#€ Date€      Description                                    €          ‚***€
     ‚***---------------------------------------------------------------------------------------***€
     FSSPARO    IF   E           K DISK
     F
     C
     C     BLOKEY        KLIST
     C                   KFLD                    NWPROG
     C                   KFLD                    WHFNAM
     C
     C     *ENTRY        PLIST
     C                   PARM                    NWPROG           10
     C                   PARM                    WHFNAM           10
     C                   PARM                    FLAG              1
     C
     C     BLOKEY        CHAIN     RSSPARO                            88
     C                   IF        *IN88 = *OFF
     C                   MOVE      'Y'           FLAG
     C                   ELSE
     C                   MOVE      *BLANKS       FLAG
     C                   ENDIF
     C
     C                   MOVE      '1'           *INLR
     C                   RETURN
 


    RPGLE  - Generate random number
Posted By: Scott Klement   Contact

Q: I need the simplest code possible for selecting a random 
   number between 2 given numbers. It should be ILE RPG code, 
   if possible. National security is NOT involved, so it doesn't 
   have to be fool-proof... just easy enough for a fool to 
   understand, and use!

A: RPG does not have built-in support for random numbers, but 
   there are several ways to generate them with APIs. The one 
   that's probably the easiest is the CEERAN0 API. 
  (Note that the API name ends with the number zero, not the letter O!)

This API generates a random number between 0 and 1, exclusive. 
That may sound strange at first, but if you stop to think 
about it, it's actually quite convenient. Think about this: 
If you multiply any number by 0, it'll result in 0. If 
you multiply any number by 1, it'll result in the 
number that you started with. Therefore, if you multiply 
by a random number in-between, the result will be a random 
number between and the number you started with. 
See? It's convenient.

For example, let's say that you wanted to simulate rolling dice. 
Typical dice have six sides, each side containing a number 
from one to six.

To do that, calculate a random number using CEERAN0. 
Multiply the result by 6. The result will be a number 
between 0 and 6, exclusive. "Exclusive" means that 0 and 6 
will never occur... you'll get a number 
between 0.000000001 and 5.99999999. Next, use the %int() 
BIF to chop off the fraction, so that you'll have a random 
number between 0 and 5. Finally, add 1 and the random number 
will be between 1 and 6.

In RPG, you'd code this as follows:

     H DFTACTGRP(*NO) ACTGRP('QILE')

     D CEERAN0         PR
     D   seed                        10I 0
     D   ranno                        8F
     D   fc                          12A   options(*omit)

     D seed            s             10I 0 inz(0)
     D rand            s              8F
     D result          s              5P 0

      /free
          CEERAN0( seed : rand : *omit );
          result = %int(rand * 6) + 1;
          // "result" now contains a number between 1 and 6.
          return;

      /end-free
That same algorithm can be used to calculate a number between two 
arbitrary numbers. Just use variables for the upper and lower ends 
of the range. The following code demonstrates this by receiving 
parameters called LOWNO and HIGHNO. It returns the result in a 
third parameter called RESULT:

     H DFTACTGRP(*NO) ACTGRP('QILE')

     D RANDOM          PR                  extpgm('RANDOM')
     D   lowno                        5P 0 const
     D   highno                       5P 0 const
     D   result                       5P 0

     D RANDOM          PI
     D   lowno                        5P 0 const
     D   highno                       5P 0 const
     D   result                       5P 0

     D CEERAN0         PR
     D   seed                        10I 0
     D   ranno                        8F
     D   fc                          12A   options(*omit)

     D seed            s             10I 0 inz(0)
     D rand            s              8F
     D range           s              5P 0

      /free
          range = (highno - lowno) + 1;
          CEERAN0( seed : rand : *omit );
          result = %int(rand * range) + lowno;
          return;
      /end-free
Random numbers on computers are generated by an equation. 
When the equation has the same input value, it'll always give 
the same results. To make them seem random, we use a seed value. 
Therefore it's important that the seed value is different every 
time you call this API.

For CEERAN0, if you pass a seed of 0, the API will generate a 
seed from the current time. That way, it will be different each 
time the program is called. CEERAN0 will output a new seed that 
can be used to help randomize subsequent calls.

If you look closely at the examples above, you'll see that they 
don't set on *INLR. The reason for this is that the program will 
remain in memory and it will retain the seed value. That way, if 
you call it again, it'll use the seed value that was retained 
from the previous call.

  


    RPGLE  - Generate a Random Rumber
Posted By: Randy Weber   Contact

ˆˆ /Title  Generate a "Random" NumberŠ...€

    ˆH Debug NoMain

      // *----------------------------------------------------------------*
      // *‚                   Precision Sytems, Inc.                    € *
      // *----------------------------------------------------------------*
      // *                                                                *
      // *  System name. . :‚ *Any                                      € *
      // *  Module/Program :‚ GETRANDNUM                                € *
      // *  Text . . . . . :‚ Generate a "Random" Number                € *
      // *  Author . . . . :‚ Randy Weber                               € *
      // *                  ‚ PrecisionSystems@comcast.net              € *
      // *                                                                *
      // *  Remarks  . . . :  This module uses SQL to retrieve a          *
      // *                    random number using the Microseconds        *
      // *                    portion of the current timestamp to         *
      // *                    seed the SQL RAND routine.                  *
      // *                                                                *
      // *                  €„Parameters:€                                *
      // *                    1. Random - Packed 9,8                      *
      // *                                                                *
      // *                  €„Sample Create Command€                      *
      // *                                                                *
      // *                    CRTSQLRPGI                                  *
      // *                        OBJ(MyLib/GETRANDNUM)                   *
      // *                         SRCFILE(MyLib/QRPGLESRC)               *
      // *                         SRCMBR(GETRANDNUM)                     *
      // *                         COMMIT(*NONE)                          *
      // *                         OBJTYPE(*MODULE)                       *
      // *                         REPLACE(*YES)                          *
      // *                         DBGVIEW(*SOURCE)                       *
      // *                                                                *
      // *                  €„Sample GETRANDNUM Usage€                    *
      // *                                                                *
      // *                     // ‚Random number interface€               *
      // *                    D GetRandNum      PR             9P 8       *
      // *                                                                *
      // *                    D Random          S              9P 8       *
      // *                                                                *
      // *                     // ‚Free-form calc specs€                  *
      // *                             Random = GetRandNum() ;            *
      // *                                                                *
      // *                                                                *
      // *----------------------------------------------------------------*

      //‚Module interface
     D GetRandNum      PR             9P 8


    ˆ /Title  Use SQL to Get a Random NumberŠ...€
      // ‚***********************************************************
     P GetRandNum      B                   Export
      // ‚***********************************************************

     D GetRandNum      PI             9P 8

      // ‚Stand Alone Fields
     D Random          S              9P 8

     C                   Eval      Random = *Zeros

       // ‚Run the SQL statement
     C/EXEC SQL
     C+
     C+   SELECT Dec(
     C+              Rand(
     C+                   Int(
     C+                       Substr(
     C+                              Char(Current_TimeStamp),21,6
     C+                             )
     C+                       )
     C+                  ),9,8
     C+             ) Into :Random
     C+     FROM QsqpTabl With NC
     C+
     C/END-EXEC

     C                   Eval      Random = %Abs(Random)
     C                   Return    Random

     P GetRandNum      E


   ˆˆ /Title  Generate a "Random" NumberŠ...€

 


    RPGLE  - what is opnqry?where we can use it in real time
Posted By: jagadesh   Contact



    RPGLE  - Use Data Structures to change the date format
Posted By: Les   Contact

I know not many shops still have legacy dates stored in numeric fields
in stead of true dates (I wish.) But I have always hated to use
C           ADATE     MULT 10000.01  FIELD1            FIELD2
to change the format.  So I do this instead.

D date_fmt        ds                  
D  ymd                    1      8  0 
D  yr1                    1      4  0 
D  mm                     5      6  0 
D  dd                     7      8  0 
D  yr2                    9     12  0 
D  mdy                    5     12  0 

 *********************************************    
 * Date Format Change Subroutine - MDY > YMD *
 *********************************************    
C     mdy2ymd       begsr                   
 *                                          
C                   eval      mdy = my_mdy_field
C                   eval      yr1 = yr2     
C                   eval      my_ymd_field = ymd  
 *                                          
C                   endsr 

empty data structure
,--YMD--,
    ,--MDY--,
YR1 MMDDYR2
00000000000            


MDY loaded with date

    ,--MDY--,
YR1 MMDDYR2
000007132005            

yr1 set to yr2
 
YR1 MMDDYR2
200507132005

YMD now loaded

,--YMD--,
YR1 MMDDYR2
200507132005

I hope some one finds this useful.
                  


    RPGLE  - Using API QWDLSJBQ to list job queue entries for a subsystem
Posted By: Pieter Henrico   Contact

The following RPGLE source code uses API QWDLSJBQ to retrieve the job queue entries for a subsystem.  The 
source code does not do anything with the info yet (like writing it out to a file), but just export all the 
information to a userspace, and then run in a loop through the user space.

      *                                                                                         
      * Program Name: RTVJOBQE#R                                                                
      * Author      : Pieter Henrico                                                            
      * Date        : 2005/7/14                                                                 
      * Description : Retrieve Job Queue Entries from a Subsystem description                   
      *                                                                                         
      *                                                                                         
      *                                                                                         
      * API generic Header                                                                      
      *                                                                                         
     DJobQEInfo        DS                                                                       
     D JQInitStart                   10i 0 inz(113)                                             
     D JQInitLength                  10i 0 inz(28)                                              
     D JQReserved1                   10i 0 inz(0)                                               
     D JQRecStart                    10i 0 inz(0)                                               
     D JQReserved2                   10i 0 inz(0)                                               
     D JQTotalNbr                    10i 0 inz(0)                                               
     D JQRecLength                   10i 0 inz(0)                                               
      *                                                                                         
      * API Error Structure                                                                     
      *                                                                                         
     DApiError         DS                                                                       
     D apierrprv               1      4b 0 INZ(67)                                              
     D apierrrcv               5      8b 0                        
     D apierrid                9     15                           
     D apierrpdt              16     67                           
      *                                                           
      * Data structure to use with retrieved JOBQ Entries         
      *                                                           
     D JobQEntryList   ds                                         
     D   JobQName              1     10                           
     D   JobQLib              11     20                           
     D   JobSeqNbr            21     24B 0                        
     D   JobAlcNbr            25     34                           
     D   Reserved1            35     36                           
     D   JobMaxAct            37     40B 0                        
     D   JobPrio1             41     44B 0                        
     D   JobPrio2             45     48B 0                        
     D   JobPrio3             49     52B 0                        
     D   JobPrio4             53     56B 0                        
     D   JobPrio5             57     60B 0                        
     D   JobPrio6             61     64B 0                        
     D   JobPrio7             65     68B 0                        
     D   JobPrio8             69     72B 0                        
     D   JobPrio9             73     76B 0                        
      *
      * User space parameters                                                 
      *                                                                       
     D USpaceName      s             20    inz('LSTJOBQE  QTEMP     ')        
     D USpaceDesc      s             50    inz('Job queue Entries   ')        
     D USpaceEnt       s             10    inz('*ALL')                        
     D USpaceFmt       s             10    inz('SJQL0100')                    
     D USpaceHDL       s             16    inz('    ')                        
     D USpaceInf       s             10i 0 inz(0) dim(7)                      
     D USpaceINI       s              1                                       
     D USpaceAttr      s             10                                       
     D USpaceAut       s             10                                       
     D USpaceRPL       s             10                                       
     D USpaceISize     s              9b 0 inz(65536)                         
                                                                              
     C     *Entry        PList                                                
     C                   Parm      SBSName       SBSName          20          
      *                                                                       
      * Delete user space                                                     
      *                                                                                   
     C                   call      'QUSDLTUS'                                   DLTUSRSPC 
     C                   parm                    USpaceName                               
     C                   parm                    ApiError                                 
      *                                                                                   
      * Create user space                                                                 
      *                                                                                   
     C                   call      'QUSCRTUS'                                   CRTUSRSPC 
     C                   parm                    USpaceName                               
     C                   parm      'RTVJOBQ'     USpaceAttr                               
     C                   parm                    USpaceISize                              
     C                   parm      ' '           USpaceINI                                
     C                   parm      '*ALL'        USpaceAut                                
     C                   parm                    USpaceDesc                               
     C                   parm      '*YES'        USpaceRpl                                
     C                   parm                    ApiError                                 
      *                                                                                   
      * List Job Queue Entries                                                            
      *                                                                                   
     C                   call      'QWDLSJBQ'                                   Entries   
     C                   parm                    USpaceName                               
     C                   parm                    USpaceFmt                                
     C                   parm                    SbsName                                  
     C                   parm                    ApiError                                 
      *                                                                                   
      * Get user space properties
      *                                                                                   
     C                   call      'QUSRTVUS'                                             
     C                   parm                    USpaceName                               
     C                   parm                    JQINitStart                              
     C                   parm                    JQInitLength                             
     C                   parm                    JobQEInfo                      Basic info
      *                                                                                   
     C                   eval      JQRecStart = JQRecStart + 1                  First entr
      *                                                                                   
      * Loop over the user space entries                                                  
      *                                                                                   
     C     1             do        JQTotalNbr                                             
      *                                                                                   
     C                   call      'QUSRTVUS'                                             
     C                   parm                    USpaceName                               
     C                   parm                    JQRecStart                      Position 
     C                   parm                    JQRecLength                     Length   
     C                   parm                    JobQEntryList                            
      *                                                                                   
     C                   eval      JQRecStart = JQRecStart + JQRecLength                  
      *                                                                                   
     C                   enddo                                                            
      *                                                                                   
     C                   eval      *inlr = *on                                            
      * 
                                                                                                                


    RPGLE  - rpgle programs
Posted By: nitin gupta   Contact



    RPGLE  - find and replace
Posted By: jimmy octane   Contact

We submit jobs from within RPG programs, so finding an easier way to insert the parameters in the submit 
string would help, which lead to creating FindReplace. The procedure finds the specified value and replaces it 
with the supplied string. Only the first occurrence is changed and capitalization is ignored. This procedure 
eliminated the need to worry about array locations, concatenating strings, changes to the string messing up 
substitutions, etc. (the target, " ((Content component not found.)) ", could be any sequence of characters). 
We're finding new uses for this every day. 

 
D CM              S             80    ctdata
perrcd(1) dim(1)  

 * Change all occurrences of FIND to REPLACE in SOURCE 
d FindReplace     pr          1024                     
d  Source                     1024    varying value    
d  Find                        255    varying value    
d  Replace                     255    varying value    
c                   eval      target=findreplace(  
c                               cm(1)              
c                               :' ((Content component not found.)) '              
c                               :'January'             
c                               )                  
c                   eval      *inlr=*on            

 * Change 1st occurrence of FIND to REPLACE in SOURCE   
p FindReplace     b                                     
d                 pi          1024                      
d  Source                     1024    varying value     
d  Find                        255    varying value     
d  Replace                     255    varying value     
d Work            s                   like(Source)      
c                   eval      Work = Source             
c                   if        %scan(Find:Work) > 0      
c                   eval      Work = %replace(Replace   
c                                      :Work            
c                                      :%scan(Find:Work)
c                                      :%len(Find)      
c                                       )               
c                   endif                               
c                   return    Work                      
p                 e                                     
** SUBMIT COMMAND  ARRAY CM                          
SBMJOB CCCHECKSOK CDAJOBD CMD(CALL CC0012 PARM(' ((Content component not found.)) '))
  


    RPGLE  - RPG/RPGLE
Posted By: pbj   Contact



    RPGLE  - Calculate date of yesterday
Posted By: Josef Kindl   Contact

DYESTR            S               D   DATFMT(*ISO)                         
C     *ENTRY        PLIST                                                  
C     YESTR         PARM                    YESTR                          
C                   MOVEL     *DATE         YESTR                          
C     YESTR         ADDDUR    -1:*DAYS      YESTR                          
C                   RETURN                                                   


    RPGLE  - types of array
Posted By: srinivasareddy   Contact

complile time array,run time array and pre run time array programming examples  


    RPGLE  - Display file field attributes without indicators
Posted By: Stuart Payne   Contact

* A snap shot of the screen file.
     A                                      DSPSIZ(24 80 *DS3)
     A                                      CA03
     A                                      CA06
     A          R I5541081                  TEXT('Header Record 1')
 *
     A                                      OVERLAY
     A                                  1 28'Enter Branch'
     A                                  3  2'Branch'
     A            BRANCH        12   B  3  9DSPATR(&BRANCHATTR)
     A            BRANCHATTR     1   P    
 *
     A          R I5541082                  TEXT('Bottom Line')
     A                                      OVERLAY
     A            MSGLINE       78   O 24  2DSPATR(&MSGLINEATT)
     A            MSGLINEATT     1   P          

      // Copy book of display attributes

 // Will not work for MDT (Set changed data tag when displayed), 
  //                   OID (Operator identification), 
 //                   PC (Position Cursor) or 
 //                   SP (Select by light pen)

      // Valid P-field values Non-protected for display files
      // Ledgend: Bl - Blink, Cs - Column separator, HI - High intensity,
      //          RI - Revers image, and Un - Underscore

      // Colors: B - Blue, G - Green, R - Red, P - Pink, T - Turquoise,
      //         W - White, and Y - Yellow

 // Non protected fields.

     D NP_Normal       c                   x'20'                                Green
     D NP_RI           c                   x'21'                                Green
     D NP_HI           c                   x'22'                                White
     D NP_HI_RI        c                   x'23'                                White
     D NP_Un           c                   x'24'                                Green
     D NP_Un_RI        c                   x'25'                                Green
     D NP_Un_HI        c                   x'26'                                White
     D NP_Nondisplay1  c                   x'27'                                Nondisplay
     D NP_Bl           c                   x'28'                                Red
     D NP_Bl_RI        c                   x'29'                                Red
     D NP_Bl_HI        c                   x'2A'                                Red
     D NP_Bl_HI_RI     c                   x'2B'                                Red
     D NP_Bl_Un        c                   x'2C'                                Red
     D NP_Bl_Un_RI     c                   x'2D'                                Red
     D NP_Bl_Un_HI     c                   x'2E'                                Red
     D NP_Nondisplay2  c                   x'2F'                                Non display
     D NP_Cs           c                   x'30'                                Turquoise
     D NP_RI_Cs        c                   x'31'                                Turquoise
     D NP_HI_Cs        c                   x'32'                                Turquoise
     D NP_HI_RI_Cs     c                   x'33'                                Turquoise
     D NP_Un_Cs        c                   x'34'                                Turquoise
     D NP_Un_RI_Cs     c                   x'35'                                Turquoise
     D NP_Un_HI_Cs     c                   x'36'                                Turquoise
     D NP_Nondisplay3  c                   x'37'                                Nondisplay
     D NP_Bl_Cs        c                   x'38'                                Pink
     D NP_Bl_RI_Cs     c                   x'39'                                Pink
     D NP_Bl_HI_Cs     c                   x'3A'                                Blue
     D NP_Bl_HI_RI_Cs  c                   x'3B'                                Blue
     D NP_Bl_Un_Cs     c                   x'3C'                                Pink
     D NP_Bl_Un_RI_Cs  c                   x'3D'                                Pink
     D NP_Bl_Un_HI_Cs  c                   x'3E'                                Pink
     D NP_Nondisplay4  c                   x'3F'                                Nondisplay


      // Valid P-field values for Protected display files
     D P_Normal        c                   x'A0'                                Green
     D P_RI            c                   x'A1'                                Green
     D P_HI            c                   x'A2'                                White
     D P_HI_RI         c                   x'A3'                                White
     D P_Un            c                   x'A4'                                Green
     D P_Un_RI         c                   x'A5'                                Green
     D P_Un_HI         c                   x'A6'                                White
     D P_Nondisplay1   c                   x'A7'                                Nondisplay
     D P_Bl            c                   x'A8'                                Red
     D P_Bl_RI         c                   x'A9'                                Red
     D P_Bl_HI         c                   x'AA'                                Red
     D P_Bl_HI_RI      c                   x'AB'                                Red
     D P_Bl_Un         c                   x'AC'                                Red
     D P_Bl_Un_RI      c                   x'AD'                                Red
     D P_Bl_Un_HI      c                   x'AE'                                Red
     D P_Nondisplay2   c                   x'AF'                                Non display
     D P_Cs            c                   x'B0'                                Turquoise
     D P_RI_Cs         c                   x'B1'                                Turquoise
     D P_HI_Cs         c                   x'B2'                                Turquoise
     D P_HI_RI_Cs      c                   x'B3'                                Turquoise
     D P_Un_Cs         c                   x'B4'                                Turquoise
     D P_Un_RI_Cs      c                   x'B5'                                Turquoise
     D P_Un_HI_Cs      c                   x'B6'                                Turquoise
     D P_Nondisplay3   c                   x'B7'                                Nondisplay
     D P_Bl_Cs         c                   x'B8'                                Pink
     D P_Bl_RI_Cs      c                   x'B9'                                Pink
     D P_Bl_HI_Cs      c                   x'BA'                                Blue
     D P_Bl_HI_RI_Cs   c                   x'BB'                                Blue
     D P_Bl_Un_Cs      c                   x'BC'                                Pink
     D P_Bl_Un_RI_Cs   c                   x'BD'                                Pink
     D P_Bl_Un_HI_Cs   c                   x'BE'                                Pink
     D P_Nondisplay4   c                   x'BF'                                Nondisplay    

  // Basic Code
     FV5541080  cf   E             workstn InfDS(Ws_Ds) 
        
     D error           s               n   inz('0')       
     D msgBranch       c                   'Enter the Branch Plant  F3 = Exit'
     D msgBranchInv    c                   'The branch is invalid.  Please re-
     D                                     enter.  F3 = Exit'
     D msgF3Exit       c                   'F3 = Exit'                                

       // if the default branch doesn't exist then have the user enter it on
       msgLine = msgBranch;
       msgLineAtt = P_HI;
       branchAttr = Np_Un;
       dou dfltBranch <> *blanks and error = *off;

         error = *off;

         write I5541082;
         exfmt I5541081;

         if cmd_Key = F3;
           *inlr = *on;
           return;
         endIf;

         evalR branch = %trim(branch);
         evalr dfltBranch = branch;

         if dfltBranch = *blanks;
           iter;
         endIf;

         // verify that the branch entered is valid
         error = verifyBranch(dfltBranch);

         if error;
           msgLine = msgBranchInv;
           msgLineAtt = P_Hi;
           branchAttr = Np_Un_RI;
         endIf;

       endDo;                                       


    RPGLE  - commit
Posted By: deepa.v   Contact

pgm for 2phase commit , ddmf under commit  


    RPGLE  - Digital clock
Posted By: Pavan Kumar Pokala   Contact

DIGITAL CLOCK

********************************************************************8
main cl program to show clock NAME---CLKCL
*********************************************************************



 PGM                                                  
            DCLF       FILE(CLK) RCDFMT(*ALL)                
                                                             
            DCL        VAR(&HR) TYPE(*CHAR) LEN(2)           
            DCL        VAR(&MIN) TYPE(*CHAR) LEN(2)          
            DCL        VAR(&SEC) TYPE(*CHAR) LEN(2)          
            DCL        VAR(&COL1) TYPE(*CHAR) LEN(1)         
            DCL        VAR(&COL2) TYPE(*CHAR) LEN(1)         
            DCL        VAR(&COL3) TYPE(*CHAR) LEN(1)         
            DCL        VAR(&COL4) TYPE(*CHAR) LEN(1)         
            DCL        VAR(&COL5) TYPE(*CHAR) LEN(1)         
            DCL        VAR(&COL6) TYPE(*CHAR) LEN(1)         
                                                             
AGAIN:                                                       
           RTVSYSVAL  SYSVAL(QHOUR) RTNVAR(&HR)             
           RTVSYSVAL  SYSVAL(QMINUTE) RTNVAR(&MIN)          
           RTVSYSVAL  SYSVAL(QHOUR) RTNVAR(&HR)                       
           RTVSYSVAL  SYSVAL(QMINUTE) RTNVAR(&MIN)                    
           RTVSYSVAL  SYSVAL(QSECOND) RTNVAR(&SEC)                    
           CHGVAR     VAR(&COL1) VALUE(%SST(&HR 1 1))                 
           CHGVAR     VAR(&COL2) VALUE(%SST(&HR 2 1))                 
           CHGVAR     VAR(&COL3) VALUE(%SST(&MIN 1 1))                
           CHGVAR     VAR(&COL4) VALUE(%SST(&MIN 2 1))                
           CHGVAR     VAR(&COL5) VALUE(%SST(&SEC 1 1))                
           CHGVAR     VAR(&COL6) VALUE(%SST(&SEC 2 1))                
           CALL       PGM(NARESH/CLKLE) PARM(&COL1 &COL2 &COL3 +      
                        &COL4 &COL5 &COL6 &IN50 &IN51 &IN52 &IN53 +   
                        &IN54 &IN55 &IN56 &IN57 &IN58 &IN59 &IN60 +   
                        &IN61 &IN62 &IN63 &IN64 &IN65 &IN66 &IN67 +   
                        &IN68 &IN69 &IN70 &IN71 &IN72 &IN73 &IN74 +   
                        &IN75 &IN76 &IN77 &IN78 &IN79 &IN80 &IN81 +   
                        &IN82 &IN83 &IN84 &IN85 &IN86 &IN87 &IN88 +   
                        &IN89 &IN90 &IN91)                            
                         SNDRCVF    RCDFMT(DIG) WAIT(*NO)                         
             MONMSG     MSGID(CPF0887) EXEC(GOTO CMDLBL(ENDJOB))      
             DLYJOB     DLY(1)                                        
             IF         COND(&IN03 *EQ '1') THEN(GOTO CMDLBL(ENDJOB)) 
             GOTO       CMDLBL(AGAIN)                                 
                                                                      
ENDJOB:      ENDPGM                                                          





***********************************************************************************8
rpg le program   name -- CLKLE
************************************************************************************


FCLKPF     IF   E           K DISK                                
C     *ENTRY        PLIST                                         
C                   PARM                    I1                1   
C                   PARM                    I2                1   
C                   PARM                    I3                1   
C                   PARM                    I4                1   
C                   PARM                    I5                1   
C                   PARM                    I6                1   
C                   PARM                    J50               1   
C                   PARM                    J51               1   
C                   PARM                    J52               1   
C                   PARM                    J53               1   
C                   PARM                    J54               1   
C                   PARM                    J55               1   
C                   PARM                    J56               1   
C                   PARM                    J57               1   
C                   PARM                    J58               1  
C                   PARM                    J59               1  
C                   PARM                    J60               1  
C                   PARM                    J61               1  
C                   PARM                    J62               1  
C                   PARM                    J63               1  
C                   PARM                    J64               1  
C                   PARM                    J65               1  
C                   PARM                    J66               1  
C                   PARM                    J67               1  
C                   PARM                    J68               1  
C                   PARM                    J69               1  
C                   PARM                    J70               1  
C                   PARM                    J71               1  
C                   PARM                    J72               1  
C                   PARM                    J73               1  
C                   PARM                    J74               1  
C                   PARM                    J75               1 
C                   PARM                    J76               1 
C                   PARM                    J77               1 
C                   PARM                    J78               1 
C                   PARM                    J79               1 
C                   PARM                    J80               1 
C                   PARM                    J81               1 
C                   PARM                    J82               1 
C                   PARM                    J83               1 
C                   PARM                    J84               1 
C                   PARM                    J85               1 
C                   PARM                    J86               1 
C                   PARM                    J87               1 
C                   PARM                    J88               1 
C                   PARM                    J89               1 
C                   PARM                    J90               1 
C                   PARM                    J91               1 
C     KEY1          KLIST                                       
C                   KFLD                    TST               1 
C                   MOVEL     I1            TST                 
C     KEY1          CHAIN     CLKPF                             
C                   MOVE      A1            J50                 
C                   MOVE      A2            J51                 
C                   MOVE      A3            J52                 
C                   MOVE      A4            J53                 
C                   MOVE      A5            J54                 
C                   MOVE      A6            J55                 
C                   MOVE      A7            J56                 
C                   MOVEL     I2            TST                 
C     KEY1          CHAIN     CLKPF                             
C                   MOVE      A1            J57                 
C                   MOVE      A2            J58                 
C                   MOVE      A3            J59                 
C                   MOVE      A4            J60                 
C                   MOVE      A5            J61          
C                   MOVE      A6            J62          
C                   MOVE      A7            J63          
C                   MOVEL     I3            TST          
C     KEY1          CHAIN     CLKPF                      
C                   MOVE      A1            J64          
C                   MOVE      A2            J65          
C                   MOVE      A3            J66          
C                   MOVE      A4            J67          
C                   MOVE      A5            J68          
C                   MOVE      A6            J69          
C                   MOVE      A7            J70          
C                   MOVEL     I4            TST          
C     KEY1          CHAIN     CLKPF                      
C                   MOVE      A1            J71          
C                   MOVE      A2            J72          
C                   MOVE      A3            J73          
C                   MOVE      A4            J74  
C                   MOVE      A5            J75  
C                   MOVE      A6            J76  
C                   MOVE      A7            J77  
C                   MOVEL     I5            TST  
C     KEY1          CHAIN     CLKPF              
C                   MOVE      A1            J78  
C                   MOVE      A2            J79  
C                   MOVE      A3            J80  
C                   MOVE      A4            J81  
C                   MOVE      A5            J82  
C                   MOVE      A6            J83  
C                   MOVE      A7            J84  
C                   MOVEL     I6            TST  
C     KEY1          CHAIN     CLKPF              
C                   MOVE      A1            J85  
C                   MOVE      A2            J86  
C                   MOVE      A3            J87         
C                   MOVE      A4            J88         
C                   MOVE      A5            J89         
C                   MOVE      A6            J90         
C                   MOVE      A7            J91         
c                   RETURN                              

**********************************************************************************
physical file required  NAME---CLKPF
***********************************************************************************

     A          R REC1                          
     A            A11            1A             
     A            A1             1A             
     A            A2             1A             
     A            A3             1A             
     A            A4             1A             
     A            A5             1A             
     A            A6             1A             
     A            A7             1A             
     A          K A11                           

****************************************************************************
RECORDS IN ABOVE PF 
****************************************************************************
 A11  A1  A2  A3  A4  A5  A6  A7   
  0   1   1   1   1   1   1   0    
  1   0   0   1   0   0   1   0    
  2   0   1   1   1   1   0   1    
  3   0   1   1   0   1   1   1    
  4   1   0   0   0   0   1   1    
  5   1   1   0   0   1   1   1    
  6   1   1   0   1   1   1   1    
  7   0   1   1   0   0   1   0    
  8   1   1   1   1   1   1   1    
  9   1   1   1   0   1   1   1    
******************************************************************************
DISPLAY FILE --- NAME --CLK
****************************************************************************

   A*%%TS  SD  20051117  135547  MUMTRG      REL-V5R2M0  5722-WDS 
   A*%%EC                                                         
   A                                      DSPSIZ(24 80 *DS3)      
   A          R DIG                                               
   A*%%TS  SD  20051117  135547  MUMTRG      REL-V5R2M0  5722-WDS 
   A                                      CA03(03 'exit')         
   A  50                              4 10'|'                     
   A  51                              3 11'___'                   
   A  52                              4 14'|'                     
   A  53                              6 10'|'                     
   A  54                              7 11'___'                   
   A  55                              6 14'|'                     
   A  56                              5 11'___'                   
   A  57                              4 16'|'                     
   A  58                              3 17'___'                   
   A  59                              4 20'|'                     
   A  60                              6 16'|'  
   A  60                              6 16'|'     
   A  61                              7 17'___'   
   A  62                              6 20'|'     
   A  63                              5 17'___'   
   A  64                              4 22'|'     
   A  65                              3 23'___'   
   A  66                              4 26'|'     
   A  67                              6 22'|'     
   A  68                              7 23'___'   
   A  69                              6 26'|'     
   A  70                              5 23'___'   
   A  71                              4 28'|'     
   A  72                              3 29'___'   
   A  73                              4 32'|'     
   A  74                              6 28'|'     
   A  75                              7 29'___'   
   A  76                              6 32'|'     
   A  77                              5 29'___'     
   A  78                              4 34'|'       
   A  79                              3 35'___'     
   A  80                              4 38'|'       
   A  81                              6 34'|'       
   A  82                              7 35'___'     
   A  83                              6 38'|'       
   A  84                              5 35'___'     
   A  85                              4 40'|'       
   A  86                              3 41'___'     
   A  87                              4 44'|'       
   A  88                              6 40'|'       
   A  89                              7 41'___'     
   A  90                              6 44'|'       
   A  91                              5 41'___'     

*********************************************************************************************8







                                                    


    RPGLE  - Retrieving SFLPAG with QDFRTVFD API
Posted By: Sander P   Contact

********************************************************************
      *     APPLICATION DESCRIPTION :
      *     -------------------------
      *     This program retrieves the display file information with help of
      *     API QDFRTVFD
      *
      ********************************************************************
      * Compiler options: Default
      *
      ********************************************************************
     H NOMAIN
      ********************************************************************
      *  Data structures belonging to used API's                         *
      ********************************************************************
     D/COPY QSYSINC/QRPGLESRC,QDFRTVFD
     D/COPY QSYSINC/QRPGLESRC,QUSEC
      *****************************************************************
      * Prototype for Call to API QDFRTVFD
      *****************************************************************
     D QDFRTVFDx       PR                  ExtPgm('QDFRTVFD')                   Named QDFRTVFDx 'cuz
     D pRcvVar                    32767A                                        QDFRTVFD already is
     D pRcvLen                       10I 0                                      used as copymember
     D pFormat                        8A
     D pQDspFil                      20A
     D pApiErrDs                      7A
      *
     D pRcvVar         S          32767A
     D pRcvLen         S             10I 0 Inz(%Size(pRcvVar))
     D pFormat         S              8A   Inz('DSPF0100')
     D pQDspFil        S             20A
     D pApiErrDs       S              7A
     P*================================================================
     P* Procedure    : GetSflPag
     P* Purpose      : Retrieves SFLPAG of diplay file
     P* Conditions   : Call with all parameters :
     P* Parameter 1  : Dsiplay file (10A) and library name (10A)
     P*================================================================
     D GetSflPag       PR             3P 0
     D pDspFil                       20A
     P GetSflPag       B                   EXPORT
     D GetSflPag       PI             3P 0
     D pDspFil                       20A
      *****************************************************************
      * Single fields
      *****************************************************************
     D hCount          S              3S 0 Inz(1)
     D hAlpha1         S              1A
     D hSflPag         S              3P 0
     D hDFARFTE        S             10I 0
     D hDFFRINF        S             10I 0
     D hDFFSFCR        S             10I 0
      **************************************************************************
      /Free

       // Fill parameter
          pQdspFil = pDspFil ;

       // Retrieve display file description ( QDFRTVFD ) API
          Callp     QDFRTVFDx(pRcvVar:pRcvLen:pFormat:pQdspFil:QUsec) ;

       // No Errors
          If QUsbAvl  = *Zeros ;

          // Base file section
             QDFFBASE = %SubSt(pRcvVar:1:%Size(QDFFBASE)) ;

          // File header section
             QDFFINFO = %SubSt(pRcvVar:QDFFINOF+1:%Size(QDFFINFO)) ;
             hDFARFTE = QDFFINOF + 1 + QDFFDFLO ;

          // Find SFLCTL record - Begin For Loop
             For hCount = 1 to QDFFFRCS ;

             // Record format table
                QDFARFTE = %SubSt(pRcvVar:hDFARFTE:%Size(QDFARFTE)) ;

             // Record header section
                hDFFRINF = QDFFINOF + 1 + QDFARFOF ;
                QDFFRINF = %SubSt(pRcvVar:hDFFRINF:%Size(QDFFRINF)) ;


             // Check if SFLCTL record. If so, leave do loop.
                If %BitAnd(%SubSt(QDFBITS09:1:1):x'20') = x'20' ;
                  Leave ;
                EndIf ;

             // Next record
                hDFARFTE = hDFARFTE + 16 ;

             EndFor ;

             // Subfile control record start position
             If %BitAnd(%SubSt(QDFBITS09:1:1):x'20') = x'20' ;
               hDFFSFCR = hDFFRINF + QDFFRAOF ;

               // Subfile control entry - SFLPAG !!
               QDFFSFHR=%SubSt(pRcvVar
                              :hDFFSFCR+%Size(QDFFSFCR)
                              :%Size(QDFFSFHR));
               hSflPag  = QDFFSFPG ;
               Return     hSflPag ;

             EndIf ;

          EndIf ;

          Return 0 ;

      /End-free

     P GetSflPag       E 


    RPGLE  - Clear the field
Posted By: M.S.Sridhar   Contact

Clear CHLPRC prior to creating ‘-888’ part number in OELDETAL.   


    RPGLE  - SEU Line Commands
Posted By: Chamara Withanachchi   Contact

*----------------------------------------------------------------------  
 *  SEULNCMDS - Program to process user-defined SEU line commands         
 *------------------------------------------------------------------------
 *  Author: Chamara Withanachchi                                          
 *  Written: Dec. 02, 2005                                                
 *------------------------------------------------------------------------
 *  Currently supported line commands:                                    
 *  LC - "L"ower"c"ase command will change all characters on selected line
 *         to lowercase.                                                  
 *  UC - "U"pper"c"ase command will change all characters on selected line
 *         to uppercase.                                                  
 *------------------------------------------------------------------------
                                                                          
 * Variable definitions                                                   
 * pointers to user space                                                 
D pHeader         s               *                                       
D pHeader2        s               *                                       
D pRtn            s               *                                       
D pLine1          s               *                                       
D pLine           s               *                                       
D pData           s               *                                       
                                                                          
 * data structures for accessing user space                               
 * line command header info                          
D dsHeader        ds                  based(pHeader2)
D  hdRecLen               1      4b 0                
D  hdCsrRrn               5      8b 0                
D  hdCsrCol               9     12b 0                
D  hdNbrRecs             17     20b 0                
D  hdFuncKey             61     61a                  
D  hdMode                62     62a                  
D  hdSplit               63     63a                  
D  hdRtnCd               65     65a                  
D  hdRecsOut             69     72b 0                
D  hdSeqUpd              73     79a                  
                                                     
 * source code header info                           
D srcHdr          ds                  Based(pLine)   
D  srcCmd                 1      7a                  
D  srcRtnCd               8      8a                  
D  srcSeq                 9     14a                  
D  srcChgDt              15     20a                  
                                                     
 * actual souce code                                 
D srcDta          ds                  Based(pData)   
D  srcCode                1    999a                  
                                                                          
                                                                          
 * Lowercase and uppercase strings                                        
D lo              c                   const('abcdefghijklmnopqrstuvwxyz') 
D up              c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') 
                                                                          
 * comparison flags                                                       
D Yes             c                   const('Y')                          
D No              c                   const('N')                          
                                                                          
 * work fields                                                            
D rec#            s             10i 0                                     
D wkCode          s            999a                                       
D hldCmd          s              3a                                       
D lastRec         s              1    inz('N')                            
                                                                          
 *------------------------------------------------------------------------
 *-  Mainline                                                             
 *------------------------------------------------------------------------
C     *entry        plist                                                 
C                   parm                    pHeader                       
C                   parm                    pRtn                          
C                   parm                    pLine1                        
                                                                         
C                   eval      pHeader2 = pHeader                         
                                                                         
 *  if F7 or F8 then do nothing                                          
C                   if        hdFuncKey = '7' or                         
C                             hdFuncKey = '8'                            
C                   eval      *inlr = *on                                
C                   return                                               
C                   endif                                                
                                                                         
 * otherwise process all records in workspace                            
C                   do        hdNbrRecs     rec#                         
C                   eval      pLine = pLine1 + ((hdRecLen + %len(srchdr))
C                             * (rec# - 1))                              
C                   eval      pData = pLine + %len(srcHdr)               
 * save multi-line command when it is encountered                        
C                   if        hldCmd = *blanks                           
                                                                         
C                   select                                               
                                                                         
C                   when      srcCmd = 'UCC'                             
C                   eval      hldCmd = 'UCC'                             
                                                                         
                                                                          
C                   when      srcCmd = 'LCC'                              
C                   eval      hldCmd = 'LCC'                              
                                                                          
C                   endsl                                                 
                                                                          
C                   else                                                  
 * if this is the second occurrence of the multi-line command then this is
 *   the last line to apply the multi-line command to.                    
C                   if        hldCmd = srcCmd                             
C                   eval      lastRec = Yes                               
C                   endif                                                 
                                                                          
C                   endif                                                 
                                                                          
 * check which command is being used                                      
C                   select                                                
 * uppercase - UC                                                         
C                   when      srcCmd = 'UC'                               
C                             or hldCmd = 'UCC'                           
C                   eval      wkCode = %subst(srcCode:1:hdRecLen)         
C     lo:up         xlate     wkCode        wkCode                        
C                   eval      %subst(srcCode:1:hdRecLen) =                
C                             %subst(wkCode:1:hdRecLen)                   
C                   eval      srcRtnCd = '0'                       
C                   eval      srcCmd = *blanks                     
                                                                   
 * lowercase - LC                                                  
C                   when      srcCmd = 'LC'                        
C                             or hldCmd = 'LCC'                    
C                   eval      wkCode = %subst(srcCode:1:hdRecLen)  
C     up:lo         xlate     wkCode        wkCode                 
C                   eval      %subst(srcCode:1:hdRecLen) =         
C                             %subst(wkCode:1:hdRecLen)            
C                   eval      srcRtnCd = '0'                       
C                   eval      srcCmd = *blanks                     
                                                                   
C                   endsl                                          
                                                                   
 * clear multi-line command after encountering second line command 
C                   if        lastRec = Yes                        
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  - RPG Developer
Posted By: Khawaja Latif   Contact

I need RPG/RPGLE, CL, SQLRPGLE, DDS 


    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  - Xml pArsing
Posted By: Anant   Contact

Xml File Processsing 


    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  * * * *
 


2 comments:

  1. This is Jamie from Code400.com
    Why are you listing my site content here on your page?

    thanks
    Jamie

    ReplyDelete
  2. You stole SEULNCMDS from Jeff Olen (https://www.mcpressonline.com/programming/rpg/techtip-userdefined-seu-line-commands)

    ReplyDelete