      /TITLE UPDRPG2: UPDRPGSRC: Create New Expanded Member
      *--------------------------------------------------------------*
      *  Programmers Group & Management Resource    Copyright  1997  *
      *                                                              *
      *                           \\\\\\\                            *
      *                          ( o   o )                           *
      *----------------------oOO----(_)----OOo-----------------------*
      *                                                              *
      *  System name. . :  PGMR Tool                                 *
      *  Program name . :  UPDRPG2                                   *
      *  Text . . . . . :  Create new expanded member                *
      *                                                              *
      *  Author . . . . :  Alexander Nubla                           *
      *  Creation date. :  11/25/97                                  *
      *                                                              *
      *                   ooooO              Ooooo                   *
      *                   (    )             (    )                  *
      *--------------------(   )-------------(   )-------------------*
      *                     (_)               (_)                    *
      *                                                              *
      * MODIFICATION LOG :                                           *
      *            Task   Programmer/                                *
      *   Date      No.   Description                                *
      * --------  ------  ------------------------------------------ *
      * 11/25/97          Alex Nubla                                 *
      *                   Creation Date                              *
      *                   This program is called from the module     *
      *                   UPDRPG1. This program adds new records to  *
      *                   the member being updated by the Update     *
      *                   RPG ILE Source (UPDRPGSRC) command.        *
      *                                                              *
      *--------------------------------------------------------------*
      /EJECT
      ****************************************************************
      *  F I L E   D E S C R I P T I O N   S P E C I F I C A T I O N *
      ****************************************************************
     FQDDSSRC   IF   F  112        DISK
      *
      *  Input source file
      *
      *--------------------------------------------------------------*
     FQRPGLESRC UF A F  112        DISK    UsrOpn
      *
      *  Expanded member being created
      *
      *--------------------------------------------------------------*
      *
      ****************************************************************
      *       D E F I N I T I O N     S P E C I F I C A T I O N      *
      ****************************************************************
      *
      *  Program status data structure
      *
     D PGMDS          SDS
     D  Pgmq##           *PROC
     D  ErrorSts         *STATUS
     D  PrvStatus             16     20S 0
     D  SrcLinNum             21     28
     D  Routine          *ROUTINE
     D  NumParms         *PARMS
     D  ExcpType              40     42
     D  ExcpNum               43     46
     D  MsgId                 40     46
      *
     D  PgmLib                81     90
     D  ExcpData              91    170
     D  ExcpId               171    174
     D  LastFile             201    208
     D  FileErr              209    243
     D  JobName              244    253
     D  User                 254    263
     D  JobNumA              264    269
     D  JobNum               264    269S 0
     D  JobDate              270    275S 0
     D  RunDate              276    281S 0
     D  RunTime              282    287S 0
     D  PgmCrtDt             288    293
     D  PgmCrtTm             294    299
     D  CmplrLvl             300    303
     D  SrcFile              304    313
     D  SrcLib               314    323
     D  SrcMbr               324    333
     D  ProcPgm              334    343
     D  ProcMod              344    353
      *--------------------------------------------------------------*
      *
      *  New source date
      *
     D                 DS
     D DateRtn                       32A
     D  NewDat                        6S 0 overlay(DateRtn:  1)
      *--------------------------------------------------------------*
      *
      *  Test operation code
      *
      *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+.....
      *    Factor1.......OpCode....Factor2.......Result........
      *
      *    to
      *
      *    Factor1.......OpCode....Extended_Factor2.............................
      *
     D                 DS
     D TestDta                             Like(INDTA) Inz
     D  TestTag                       3    overlay(TestDta:  1)
     D  Factor1                      14    overlay(TestDta: 12)
     D  OpCode                       10    overlay(TestDta: 26)
     D  Test2                         2    overlay(TestDta: 26)
     D  Test3                         3    overlay(TestDta: 26)
     D  Test4                         4    overlay(TestDta: 26)
     D  Test6                         6    overlay(TestDta: 26)
     D  Factor2                      14    overlay(TestDta: 36)
     D  Extend2                      45    overlay(TestDta: 36)
      *--------------------------------------------------------------*
      *
      *  Constants
      *
     D @UP             C                   CONST('ABCDEFGHIJKLMNOPQRST-
     D                                     UVWXYZ')
     D @LO             C                   CONST('abcdefghijklmnopqrst-
     D                                     uvwxyz')
     D @EQ             C                   CONST(' = ')
     D @NE             C                   CONST('<> ')
     D @GT             C                   CONST(' > ')
     D @LT             C                   CONST(' < ')
     D @GE             C                   CONST('>= ')
     D @LE             C                   CONST('<= ')
     D @MULT           C                   CONST(' * ')
     D @DIV            C                   CONST(' / ')
      *--------------------------------------------------------------*
      *
      *  Standalone fields
      *
     D Lilian          S              9B 0 Inz
     D Second          S              8A   Inz
     D GregDt          S             17A   Inz
     D Picture         S             32A   Inz
     D Recno           S             10  0 Inz
     D Prevno          S             10  0 Inz
     D Tag             S              3A   Inz
     D End#            S              5  0 Inz
     D Cas#            S              5  0 Inz
     D End             S             10    Dim(500)
     D CheckOp         S              2A   Inz
     D F1              S             11A   Inz
     D Op              S              3A   Inz
     D F2              S             11A   Inz
     D SaveDta         S                   Like(INDTA) Inz
      *--------------------------------------------------------------*

      /EJECT
      ****************************************************************
      *           I N P U T     S P E C I F I C A T I O N            *
      ****************************************************************
     IQDDSSRC   NS
     I                             S    1    6 2INSEQ
     I                             S    7   12 0INDAT
     I                                  7   12  INDATE
     I                                 13  112  INDTA
     I                                  1  112  INSRC
     IQRPGLESRC NS
     I                             S    1    6 2SRCSEQ
     I                             S    7   12 0SRCDAT
     I                                 13  112  SRCDTA
      /EJECT
      ****************************************************************
      *     C A L C U L A T I O N     S P E C I F I C A T I O N      *
      ****************************************************************

      *----------------------------------------------------*
      *  Get the local date                                *
      *----------------------------------------------------*
     C                   Callb(d)  'CEELOCT'
     C                   Parm                    Lilian
     C                   Parm                    Second
     C                   Parm                    GregDt
     C                   Parm                    *Omit
      *
     C                   Callb(d)  'CEEDATE'
     C                   Parm                    Lilian
     C                   Parm      'YYMMDD'      Picture
     C                   Parm                    DateRtn
     C                   Parm                    *Omit
      *
      *----------------------------------------------------*
      *  Read the input source                             *
      *----------------------------------------------------*
     C                   Open      QRPGLESRC

     C                   Dow       Not *In99
     C                   Eval      Recno       = Recno + 1
     C     Recno         Chain     QDDSSRC                            99
     C                   If        Not *In99
     C                   Eval      SRCSEQ      = INSEQ
     C                   Eval      SRCDAT      = INDAT
     C                   Eval      TestDta     = INDTA
      *
     C                   Select
      *         *------------------------------------------*
      *         *  bypass blanks                           *
      *         *------------------------------------------*
     C                   When      INDTA       = *Blanks
     C                   Exsr      $WRTSRC
      *         *------------------------------------------*
      *         *  bypass constants                        *
      *         *------------------------------------------*
     C                   When      '*'         = %Subst(INDTA:  7:  1)
     C                   Exsr      $WRTSRC
      *         *------------------------------------------*
      *         *  bypass SQL continuation lines           *
      *         *------------------------------------------*
     C                   When      '/'         = %Subst(INDTA:  7:  1)
     C                   Exsr      $WRTSRC
     C                   When      '+'         = %Subst(INDTA:  7:  1)
     C                   Exsr      $WRTSRC
      *         *------------------------------------------*
      *         *  Check for C specifications              *
      *         *------------------------------------------*
     C                   When      'C'         = %Subst(INDTA:  6:  1)
     C     @LO:@UP       Xlate     OpCode        OpCode
     C                   Eval      Tag         = *Blanks
     C     'IF'          Caseq     Test2         $CheckIf
     C     'DO'          Caseq     Test2         $CheckDo
     C     'SELECT'      Caseq     Test6         $CheckSL
     C     'CAS'         Caseq     Test3         $CheckCs
     C     'ELSE'        Caseq     Test4         $CheckElse
     C     'END'         Caseq     Test3         $CheckEnd
     C     'OR'          Caseq     Test2         $CheckOr
     C     'AND'         Caseq     Test3         $CheckAnd
     C     'WHEN'        Caseq     Test4         $CheckWhen
     C                   Cas                     $CheckOthr
     C                   EndCs
     C                   Other
      *         *------------------------------------------*
      *         *  Move other specifications               *
      *         *------------------------------------------*
     C                   Exsr      $WRTSRC
     C                   EndSl
      *
     C                   EndIf
     C                   Enddo
     C                   Eval      *InLr       = *On
     C                   Return

      /EJECT
      ****************************************************************
      *                    S U B R O U T I N E S                     *
      ****************************************************************
      /SPACE
      *==============================================================*
      *                                                              *
      *  IF Operation Code                                           *
      *                                                              *
     C     $CheckIf      BEGSR                                                            *
      *==============================================================*
     C                   Eval      CheckOp     = %Subst(OpCode:  3:  2)
      *----------------------------------------------------*
      *  Parse out the operation code from the IF          *
      *----------------------------------------------------*
     C                   If        CheckOp    <> *Blanks
     C                   Select
     C                   When      CheckOp     = 'EQ'
     C                   Eval      Op          = @EQ
     C                   When      CheckOp     = 'NE'
     C                   Eval      Op          = @NE
     C                   When      CheckOp     = 'GT'
     C                   Eval      Op          = @GT
     C                   When      CheckOp     = 'LT'
     C                   Eval      Op          = @LT
     C                   When      CheckOp     = 'GE'
     C                   Eval      Op          = @GE
     C                   When      CheckOp     = 'LE'
     C                   Eval      Op          = @LE
     C                   EndSl
     C                   Eval      F1          = Factor1
     C                   Eval      F2          = Factor2
     C                   Eval      Factor1     = *Blanks
     C                   Eval      Factor2     = *Blanks
     C                   Eval      Extend2     = F1 + Op + F2
     C                   EndIf
      *
     C                   Eval      OpCode      = 'If'
     C                   Eval      End#        = End# + 1
     C                   Eval      End(End#)   = 'EndIf'
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'B'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckIf      Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  OR Operation Code                                           *
      *                                                              *
     C     $CheckOr      BEGSR                                                            *
      *==============================================================*
     C                   Eval      SaveDta     = TestDta
      *----------------------------------------------------*
      *  Update the previous record with OR statement      *
      *----------------------------------------------------*
     C                   Eval      Prevno      = Recno - 1
     C     Prevno        Chain     QRPGLESRC                          98
     C                   If        Not *In98
     C                   Eval      TestDta     = SRCDTA
     C                   Eval      Extend2     = %Trim(Extend2) + ' or'
     C                   Eval      SRCDTA      = TestDta
     C                   Except    UpdDta
     C                   EndIf
     C                   Eval      TestDta     = SaveDta
      *
     C                   Eval      CheckOp     = %Subst(OpCode:  3:  2)
      *----------------------------------------------------*
      *  Parse out the operation code from the OR          *
      *----------------------------------------------------*
     C                   Select
     C                   When      CheckOp     = 'EQ'
     C                   Eval      Op          = @EQ
     C                   When      CheckOp     = 'NE'
     C                   Eval      Op          = @NE
     C                   When      CheckOp     = 'GT'
     C                   Eval      Op          = @GT
     C                   When      CheckOp     = 'LT'
     C                   Eval      Op          = @LT
     C                   When      CheckOp     = 'GE'
     C                   Eval      Op          = @GE
     C                   When      CheckOp     = 'LE'
     C                   Eval      Op          = @LE
     C                   EndSl
     C                   Eval      F1          = Factor1
     C                   Eval      F2          = Factor2
     C                   Eval      Factor1     = *Blanks
     C                   Eval      Factor2     = *Blanks
     C                   Eval      Extend2     = F1 + Op + F2
      *
     C                   Eval      OpCode      = *Blanks
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckOr      Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  AND Operation Code                                          *
      *                                                              *
     C     $CheckAnd     BEGSR                                                            *
      *==============================================================*
     C                   Eval      SaveDta     = TestDta
      *----------------------------------------------------*
      *  Update the previous record with AND statement     *
      *----------------------------------------------------*
     C                   Eval      Prevno      = Recno - 1
     C     Prevno        Chain     QRPGLESRC                          98
     C                   If        Not *In98
     C                   Eval      TestDta     = SRCDTA
     C                   Eval      Extend2     = %Trim(Extend2) + ' and'
     C                   Eval      SRCDTA      = TestDta
     C                   Except    UpdDta
     C                   EndIf
     C                   Eval      TestDta     = SaveDta
      *
      *
     C                   Eval      CheckOp     = %Subst(OpCode:  4:  2)
      *----------------------------------------------------*
      *  Parse out the operation code from the AND         *
      *----------------------------------------------------*
     C                   Select
     C                   When      CheckOp     = 'EQ'
     C                   Eval      Op          = @EQ
     C                   When      CheckOp     = 'NE'
     C                   Eval      Op          = @NE
     C                   When      CheckOp     = 'GT'
     C                   Eval      Op          = @GT
     C                   When      CheckOp     = 'LT'
     C                   Eval      Op          = @LT
     C                   When      CheckOp     = 'GE'
     C                   Eval      Op          = @GE
     C                   When      CheckOp     = 'LE'
     C                   Eval      Op          = @LE
     C                   EndSl
     C                   Eval      F1          = Factor1
     C                   Eval      F2          = Factor2
     C                   Eval      Factor1     = *Blanks
     C                   Eval      Factor2     = *Blanks
     C                   Eval      Extend2     = F1 + Op + F2
      *
     C                   Eval      OpCode      = *Blanks
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckAnd     Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  DO Operation Code                                           *
      *                                                              *
     C     $CheckDo      BEGSR                                                            *
      *==============================================================*
     C                   Eval      CheckOp     = %Subst(OpCode:  4:  2)
      *----------------------------------------------------*
      *  Parse out the operation code from the IF          *
      *----------------------------------------------------*
     C                   If        CheckOp    <> *Blanks
     C                   Select
     C                   When      CheckOp     = 'EQ'
     C                   Eval      Op          = @EQ
     C                   When      CheckOp     = 'NE'
     C                   Eval      Op          = @NE
     C                   When      CheckOp     = 'GT'
     C                   Eval      Op          = @GT
     C                   When      CheckOp     = 'LT'
     C                   Eval      Op          = @LT
     C                   When      CheckOp     = 'GE'
     C                   Eval      Op          = @GE
     C                   When      CheckOp     = 'LE'
     C                   Eval      Op          = @LE
     C                   EndSl
     C                   Eval      F1          = Factor1
     C                   Eval      F2          = Factor2
     C                   Eval      Factor1     = *Blanks
     C                   Eval      Factor2     = *Blanks
     C                   Eval      Extend2     = F1 + Op + F2
     C                   Eval      %Subst(OpCode:  4:  2) = *Blanks
     C     @UP:@LO       Xlate     OpCode:2      OpCode
     C                   Else
     C                   Eval      OpCode      = 'Do'
     C                   EndIf
      *
     C                   Eval      End#        = End# + 1
     C                   Eval      End(End#)   = 'EndDo'
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'B'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckDo      Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  SELECT Operation Code                                       *
      *                                                              *
     C     $CheckSl      BEGSR                                                            *
      *==============================================================*
     C                   Eval      OpCode      = 'Select'
     C                   Eval      End#        = End# + 1
     C                   Eval      End(End#)   = 'EndSl'
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'B'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckSl      Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  WHEN Operation Code                                         *
      *                                                              *
     C     $CheckWhen    BEGSR                                                            *
      *==============================================================*
     C                   Eval      CheckOp     = %Subst(OpCode:  5:  2)
      *----------------------------------------------------*
      *  Parse out the operation code from the WHEN        *
      *----------------------------------------------------*
     C                   Select
     C                   When      CheckOp     = 'EQ'
     C                   Eval      Op          = @EQ
     C                   When      CheckOp     = 'NE'
     C                   Eval      Op          = @NE
     C                   When      CheckOp     = 'GT'
     C                   Eval      Op          = @GT
     C                   When      CheckOp     = 'LT'
     C                   Eval      Op          = @LT
     C                   When      CheckOp     = 'GE'
     C                   Eval      Op          = @GE
     C                   When      CheckOp     = 'LE'
     C                   Eval      Op          = @LE
     C                   EndSl
     C                   Eval      F1          = Factor1
     C                   Eval      F2          = Factor2
     C                   Eval      Factor1     = *Blanks
     C                   Eval      Factor2     = *Blanks
     C                   Eval      Extend2     = F1 + Op + F2
      *
     C                   Eval      OpCode      = 'When'
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckWhen    Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  CAS Operation Code                                          *
      *                                                              *
     C     $CheckCs      BEGSR                                                            *
      *==============================================================*
     C                   Eval      %subst(Opcode: 1: 3)  = 'Cas'
     C     @UP:@LO       Xlate     OpCode:5      OpCode
     C                   If        Cas#        = *Zeros
     C                   Eval      End#        = End# + 1
     C                   Eval      End(End#)   = 'EndCs'
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'B'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   EndIf
     C                   Eval      Cas#        = Cas# + 1
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckCs      Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  ELSE Operation Code                                         *
      *                                                              *
     C     $CheckElse    BEGSR                                                            *
      *==============================================================*
     C                   Eval      OpCode      = 'Else'
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'X'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckElse    Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  END Operation Code                                          *
      *                                                              *
     C     $CheckEnd     BEGSR                                                            *
      *==============================================================*
     C                   Eval      Cas#        = *Zeros
      *----------------------------------------------------*
      *  ENDSR encountered or unbalanced END statements    *
      *----------------------------------------------------*
     C                   If        End#       <= *Zeros
     C                   Eval      End#        = *Zeros
     C     @UP:@LO       Xlate     OpCode:2      OpCode
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
     C                   Goto      #CheckEnd
     C                   EndIf

      *----------------------------------------------------*
      *  Only END keyed in by user                         *
      *----------------------------------------------------*
     C                   If        *Blanks     = %Subst(OpCode: 4: 1)
     C                   Eval      OpCode      = End(End#)
     C                   Else
      *         *------------------------------------------*
      *         *  user keyed in ENDxx                     *
      *         *------------------------------------------*
     C                   Eval      %subst(Opcode: 1: 3)  = 'End'
     C     @UP:@LO       Xlate     OpCode:5      OpCode
     C                   EndIf
     C                   If        TestTag     = *Blanks
     C                   Move      End#          Tag
     C                   Eval      %subst(Tag: 1: 1)  = 'E'
     C                   Eval      TestTag     = Tag
     C                   EndIf
     C                   Eval      End#        = End# - 1
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckEnd     Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  All other C Spec Operation Codes                            *
      *                                                              *
     C     $CheckOthr    BEGSR                                                            *
      *==============================================================*
     C     @UP:@LO       Xlate     OpCode:2      OpCode
     C                   Eval      INDTA       = TestDta
     C                   Exsr      $WRTSRC
      *
     C     #CheckOthr    Endsr
      /EJECT
      *==============================================================*
      *                                                              *
      *  Write new source record                                     *
      *                                                              *
     C     $WRTSRC       BEGSR                                                            *
      *==============================================================*
     C                   Eval      SRCDTA      = INDTA
     C                   Except    WrtSrc
      *
     C     #WRTSRC       ENDSR
      ****************************************************************
      *          O U T P U T     S P E C I F I C A T I O N           *
      ****************************************************************
     OQRPGLESRC EADD         WRTSRC
     O                       SRCSEQ
     O                       SRCDAT
     O                       SRCDTA
     O          E            UPDDTA
     O                       SRCSEQ
     O                       SRCDAT
     O                       SRCDTA
