RpgleDBG201R4 < DBG400

<verbatim>
      **********************************************************************************************
      * DBG201R4: Copy to field delimited format (.csv)
      * Copyright (C) 2001  Martin Rowe   <martin@dbg400.net>
      *
      * This program is free software; you can redistribute it and/or modify
      * it under the terms of the GNU General Public License as published by
      * the Free Software Foundation; either version 2 of the License, or
      * (at your option) any later version.
      *
      * This program is distributed in the hope that it will be useful,
      * but WITHOUT ANY WARRANTY; without even the implied warranty of
      * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      * GNU General Public License for more details.
      *
      * You should have received a copy of the GNU General Public License
      * along with this program; if not, write to the Free Software
      * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
      **********************************************************************************************
     H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
      **********************************************************************************************
      * FILES:
      **********************************************************************************************
      * Input file
     FINFILE    IF   F 5000        DISK    InfDS(InFileDS)
      * Output file
     FDBGCSV00  O    F 5000        DISK
      * Field mapping table
     FDBGFMT00  IF   E           K DISK
      **********************************************************************************************
      * ARRAYS:
      **********************************************************************************************
     D FldDta          S            281    Dim(999)
     D FldEdt          S             70    Dim(999)
      **********************************************************************************************
      * DATA STRUCTURES:
      **********************************************************************************************
      * Program Name
     D                SDS
     D SDS_PGM                       10
      *
     D MapRules      E DS                  ExtName(DBGFMT00)
      *
      * Information Data Structure
     D InFileDS        DS
     D NbrOfRcds                      9B 0 Overlay(InFileDS:156)
      *
     D Screen_DS       DS
     D  KeyPress                      1    Overlay(Screen_DS:369)
      * ==List API structures==
      * Standard error code DS for API error handling
     D Error_Code      DS
     D  BytesProvd             1      4B 0 Inz(0)
     D  BytesAvail             5      8B 0 Inz(0)
     D  Except_ID              9     15
     D  Reserved              16     16
     D  Exception             17    272
      * Receiver value DS for user space header info (used in first call to QUSRTVUS)
     D GenRcvrDS       DS
     D  UserArea               1     64
     D  GenHdrSize            65     68B 0
     D  StrucLevel            69     72
     D  FormatName            73     80
     D  APIused               81     90
     D  CreateStamp           91    103
     D  InfoStatus           104    104
     D  SizeUSused           105    108B 0
     D  InpParmOff           109    112B 0
     D  InpParmSiz           113    116B 0
     D  HeadOffset           117    120B 0
     D  HeaderSize           121    124B 0
     D  ListOffset           125    128B 0
     D  ListSize             129    132B 0
     D  ListNumber           133    136B 0
     D  EntrySize            137    140B 0
      * QUSLFLD format FLDL0100 structure
     D FldL0100DS      DS
     D  FldL0100
     D   L_FieldName                 10A   Overlay( FldL0100 : 1 )
     D   L_DataType                   1A   Overlay( FldL0100 : 11 )
     D   L_Use                        1A   Overlay( FldL0100 : 12 )
     D   L_OutBuffer                  9B 0 Overlay( FldL0100 : 13 )
     D   L_InBuffer                   9B 0 Overlay( FldL0100 : 17 )
     D   L_Length                     9B 0 Overlay( FldL0100 : 21 )
     D   L_Digits                     9B 0 Overlay( FldL0100 : 25 )
     D   L_DecimalPos                 9B 0 Overlay( FldL0100 : 29 )
     D   L_FieldText                 50A   Overlay( FldL0100 : 33 )
     D   L_EditCode                   2A   Overlay( FldL0100 : 83 )
     D   L_EditWordLn                 9B 0 Overlay( FldL0100 : 85 )
     D   L_EditWord                  64A   Overlay( FldL0100 : 89 )
     D   L_ColHead1                  20A   Overlay( FldL0100 : 153 )
     D   L_ColHead2                  20A   Overlay( FldL0100 : 173 )
     D   L_ColHead3                  20A   Overlay( FldL0100 : 193 )
     D   L_IntFldName                10A   Overlay( FldL0100 : 213 )
     D   L_AltFldName                30A   Overlay( FldL0100 : 223 )
     D   L_AltFldLen                  9B 0 Overlay( FldL0100 : 253 )
     D   L_NbrDBCS                    9B 0 Overlay( FldL0100 : 257 )
     D   L_AllowNull                  1A   Overlay( FldL0100 : 261 )
     D   L_HostVryInd                 1A   Overlay( FldL0100 : 262 )
     D   L_DatTimFmt                  4A   Overlay( FldL0100 : 263 )
     D   L_DatTimSep                  1A   Overlay( FldL0100 : 267 )
     D   L_VaryLenInd                 1A   Overlay( FldL0100 : 268 )
     D   L_FldTxtCSID                 1A   Overlay( FldL0100 : 269 )
     D   L_FldDtaCSID                 1A   Overlay( FldL0100 : 273 )
     D   L_ColHedCSID                 1A   Overlay( FldL0100 : 277 )
     D   L_EdtWrdCSID                 1A   Overlay( FldL0100 : 281 )
      * QUSLRCD format RCDL0100 structure
     D RcdL0100DS      DS
     D  RcdL0100                     10
     D   L_FormatName                10A   Overlay( RcdL0100 : 1 )
      *
     D                 DS
     D CharField16                   16A
     D PackField30                   30P 0 Overlay( CharField16 : 1 )
      *
     D                 DS
     D CharField30                   30A
     D ZoneField30                   30S 0 Overlay( CharField30 : 1 )
      *
     D                 DS
     D CharDate                      10A
     D DateField                       D   Overlay( CharDate )
      *
     D                 DS
     D CharTime                       8A
     D TimeField                       T   Overlay( CharTime )
      *
     D                 DS
     D CharFloat
     D FloatField                     8F   Overlay( CharFloat )
     D SmallFloat                     4F   Overlay( CharFloat )
      *
     D                 DS
     D CharBin                        4A
     D BinField                       9B 0 Overlay( CharBin )
     D SmallBin                       4B 0 Overlay( CharBin )
      *  DD/MM/YY date breakdown.
     D                 DS
     D Dmy                            6  0
     D  D_Dmy                         2  0 Overlay(Dmy)
     D  M_Dmy                         2  0 Overlay(Dmy:3)
     D  Y_Dmy                         2  0 Overlay(Dmy:5)
      *  DD/MM/YYYY date breakdown.
     D                 DS
     D Dmcy                           8  0
     D  D_Dmcy                        2  0 Overlay(Dmcy)
     D  M_Dmcy                        2  0 Overlay(Dmcy:3)
     D  C_Dmcy                        2  0 Overlay(Dmcy:5)
     D  Y_Dmcy                        2  0 Overlay(Dmcy:7)
      *  YYYY/MM/DD date breakdown.
     D                 DS
     D Cymd                           8  0
     D  C_Cymd                        2  0 Overlay(Cymd)
     D  Y_Cymd                        2  0 Overlay(Cymd:3)
     D  M_Cymd                        2  0 Overlay(Cymd:5)
     D  D_Cymd                        2  0 Overlay(Cymd:7)
      *  MM/DD/YY date breakdown.
     D                 DS
     D Mdy                            6  0
     D  M_Mdy                         2  0 Overlay(Mdy)
     D  D_Mdy                         2  0 Overlay(Mdy:3)
     D  Y_Mdy                         2  0 Overlay(Mdy:5)
      *  MM/DD/YYYY date breakdown.
     D                 DS
     D Mdcy                           8  0
     D  M_Mdcy                        2  0 Overlay(Mdcy)
     D  D_Mdcy                        2  0 Overlay(Mdcy:3)
     D  C_Mdcy                        2  0 Overlay(Mdcy:5)
     D  Y_Mdcy                        2  0 Overlay(Mdcy:7)
      *  YYYY/MM date breakdown.
     D                 DS
     D Cym                            6  0
     D  C_Cym                         2  0 Overlay(Cym)
     D  Y_Cym                         2  0 Overlay(Cym:3)
     D  M_Cym                         2  0 Overlay(Cym:5)
      **********************************************************************************************
      * WORK FIELDS:
      **********************************************************************************************
 ??? D LilianStart     S               D
     D WorkDate        S               D
     D Centry          S              2  0
     D Day             S              2  0
     D Month           S              2  0
     D DateCvt         S              8  0
     D Bad             S              2
 ??? D Cmdlength       S             15  5
 ??? D Cmdstring       S            256
     D ColHdgs         S             62    Varying
     D CurrentEnt      S              5P 0 Inz(1)
     D DataLength      S              9B 0 Inz(140)
     D DecSide         S             30    Varying
     D DecSym          S              1    Inz('.') Varying
     D EditField       S             40    Varying
     D ExtendAttr      S             10    Inz('USRSPC    ')
     D FileFormat      S             10
     D Good            S              2
     D Idx1            S              5  0
     D Idx2            S              3  0
     D InitialSiz      S              9B 0 Inz(1024)
     D InitialVal      S              1    Inz(X'00')
     D IntSide         S             30    Varying
     D IntLen          S              3  0
 ??? D K_fld           S             10
     D ListFormat      S              8
     D LoopTotal       S              5  0
     D OnePercent      S             11  2
     D OverrideProc    S              1    Inz('0')
     D P_File          S             10
     D P_ColHdg        S              7
     D P_FldDel        S              1
     D P_Library       S             10
     D P_Marker        S              1    Inz(X'33')                           Yellow
     D P_Percent       S              3  0
 ??? D P_Pgm           S             10
     D P_RplFldDel     S              1
     D P_RplStrDel     S              1
     D P_StrDel        S              1
     D P_Text          S             20    Inz('Records processed')
     D PosNeg          S              1    Varying
     D PublicAut       S             10    Inz('*ALL      ')
     D QualifyFile     S             20
 ??? D ReturnCode      S              7
     D RcdsRead        S              9  0
     D Record          S           5000    Varying
     D Remainder       S              9  0
     D ReplaceSpc      S             10    Inz('*YES      ')
     D StartPos        S              9B 0 Inz(1)
     D StrDel          S              1    Varying
     D Type_A          S            999    Varying
     D TextDescrp      S             50    Inz('QUSLRCD/QUSLFLD List APIs')
     D UserSpace       S             20    Inz('DBG201US  QTEMP     ')
     D Year            S              2  0
      **********************************************************************************************
      * CONSTANTS:
      **********************************************************************************************
      **********************************************************************************************
     IINFILE    NS  01
     I                                  1 5000  RCDDTA
      **********************************************************************************************
      * ENTRY PARAMETERS:
      **********************************************************************************************
     C     *ENTRY        PList
     C                   Parm                    P_File
     C                   Parm                    P_Library
     C                   Parm                    P_ColHdg
     C                   Parm                    P_FldDel
     C                   Parm                    P_RplFldDel
     C                   Parm                    P_StrDel
     C                   Parm                    P_RplStrDel
      **********************************************************************************************
      * KEY LISTS:
      **********************************************************************************************
     C     DBGFMT00KEY   KList
     C                   KFld                    P_Library
     C                   KFld                    P_File
     C                   KFld                    L_FieldName
      **********************************************************************************************
      * MAINLINE:
      **********************************************************************************************
      * Initialisation
     C                   ExSr      Inits
      * Get the field details for this file
     C                   ExSr      GetFldDtls
      * If column headings required in first record
B001 C                   If        P_ColHdg <> '*NONE'
     C                   ExSr      SetColHdgs
E001 C                   EndIf
      * Loop through the file, and create our flat file according to the field mapping rules
     C     1             SetLL     INFILE
     C                   Read      INFILE
B001 C                   DoW       Not %Eof(INFILE)
      * Keep track of how far the takeon has got
     C                   Eval      RcdsRead = RcdsRead + 1
     C     RcdsRead      Div       OnePercent    P_Percent
     C                   MvR                     Remainder
B002 C                   If        Remainder = 0
     C                   Call      'DBG202R4'
     C                   Parm                    P_Percent
     C                   Parm                    P_Text
     C                   Parm                    P_Marker
E002 C                   EndIf
     C                   ExSr      ParseLine
     C                   Read      INFILE
E001 C                   EndDo
      * Time to go...
     C                   Eval      *INLR = *On
     C                   Return
      **********************************************************************************************
      * GetFldDtls: Get field details
      **********************************************************************************************
     C     GetFldDtls    BegSr
      * Process returned entries
B001 C                   If        ListNumber > 0
      * Set the initial offset for the start of the list entries
     C                   Eval      ListOffset = ListOffset + 1
      * Loop through the entries held in the list section of the user space
B002 C                   DoW       CurrentEnt <= ListNumber
      * Get the header info for this space
     C                   Call      'QUSRTVUS'
     C                   Parm                    UserSpace
     C                   Parm                    ListOffset
     C                   Parm                    EntrySize
     C                   Parm                    FldL0100DS
     C                   Parm                    Error_Code
     C                   Eval      Idx1 = Idx1 + 1
     C                   Eval      FldDta(Idx1) = FldL0100
      * Get mapping rules for this field (if present)
     C     DBGFMT00KEY   Chain (N) DBGFMT00
B003 C                   If        %Found(DBGFMT00)
     C                   Eval      FldEdt(Idx1) = MapRules
X003 C                   Else
     C                   Eval      FldEdt(Idx1) = *blanks
E003 C                   EndIf
      * Bump up the counter & offset for the next entry
     C                   Eval      ListOffset = ListOffset + EntrySize
     C                   Eval      CurrentEnt = CurrentEnt + 1
E002 C                   EndDo
E001 C                   EndIf
      * Set total number of fields in the record
     C                   Eval      LoopTotal = Idx1
      * Set XLATE from/to values for field & string delimiter conversions
     C                   Eval      Bad = P_FldDel + P_StrDel
     C                   Eval      Good = P_RplFldDel + P_RplStrDel
      * If no string delimiter required, set it to zero length (varying field)
B001 C                   If        P_StrDel = *blanks
     C                   Eval      StrDel = ''
X001 C                   Else
     C                   Eval      StrDel = P_StrDel
E001 C                   EndIf
      *
     C                   EndSr
      **********************************************************************************************
      * SetColHdgs: Add column headings to first line of file
      **********************************************************************************************
     C     SetColHdgs    BegSr
      * Loop through each field entry and process in turn
B001 C                   Do        LoopTotal     Idx1
     C                   Eval      FldL0100 = FldDta(Idx1)
      * Process according to column heading type
B002 C                   Select
S002 C                   When      P_ColHdg = '*COLHDG'
     C                   Eval      ColHdgs = StrDel + %Trim(%Trim(L_ColHead1) +
     C                             ' ' + %Trim(L_ColHead2) + ' ' +
     C                             %Trim(L_ColHead3)) + StrDel
S002 C                   When      P_ColHdg = '*TEXT'
     C                   Eval      ColHdgs = StrDel + %Trim(L_FieldText) +
     C                                       StrDel
S002 C                   When      P_ColHdg = '*FIELD'
     C                   Eval      ColHdgs = StrDel + %Trim(L_FieldName) +
     C                                       StrDel
E002 C                   EndSl
      * First entry resets the field - no leading delimiter
B002 C                   If        Idx1 = 1
     C                   Eval      Record = ColHdgs
X002 C                   Else
     C                   Eval      Record = Record + P_FldDel + ColHdgs
E002 C                   EndIf
E001 C                   EndDo
      * Write out the current line
     C                   Except    TFRFORMAT
      *
     C                   EndSr
      **********************************************************************************************
      * ParseLine: Parse input file line to create flat file in .csv format
      **********************************************************************************************
     C     ParseLine     BegSr
      * Loop through each field entry and process in turn
B001 C                   Do        LoopTotal     Idx1
     C                   Eval      FldL0100 = FldDta(Idx1)
      * Pick up appropriate mapping rules if set for current field
B002 C                   If        FldEdt(Idx1) <> *blanks
     C                   Eval      MapRules = FldEdt(Idx1)
      * Otherwise don't use rules, just defaults
X002 C                   Else
     C                   Eval      FMRULE = *blanks
E002 C                   EndIf
      * Process according to data type
B002 C                   Select

      * Character data type
S002 C                   When      L_DataType = 'A'
      * Varying fields store the actual length used in the first two bytes so don't include them
B003 C                   If        L_VaryLenInd = *On
     C                   Eval      Type_A =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer + 2 : +
     C                                            L_Length - 2 ) )
X003 C                   Else
     C                   Eval      Type_A =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
E003 C                   EndIf
      * Strings might contain characters that conflict with the requested string & field delimiters
      * so replace them with the substitutes provided.
     C     Bad:Good      Xlate     Type_A        Type_A
      * Add character field prefix if required (so Excel doesn't treat is as a number on import)
B003 C                   If        FMRULE = 'Y'
B003 C                             and FMPFIX <> *blanks
     C                   Eval      Type_A = StrDel + FMPFIX + Type_A + StrDel
X003 C                   Else
     C                   Eval      Type_A = StrDel + Type_A + StrDel
E003 C                   EndIf
      * First entry resets the field - no leading delimiter
B003 C                   If        Idx1 = 1
     C                   Eval      Record = Type_A
X003 C                   Else
     C                   Eval      Record = Record + P_FldDel + Type_A
E003 C                   EndIf

      * Zoned numeric data type
S002 C                   When      L_DataType = 'S'
     C                   Eval      ZoneField30 = *Zero
     C                   EvalR     %SubSt(CharField30 : +
     C                                    31 - L_Length : +
     C                                    L_Length) =
     C                             %SubSt(RCDDTA : +
     C                                    L_OutBuffer : +
     C                                    L_Length )
      * Detect negative number, set sign & reverse sign of actual value (reapplied later)
B003 C                   If        ZoneField30 < 0
     C                   Eval      PosNeg = '-'
     C                   Eval      ZoneField30 = -ZoneField30
X003 C                   Else
     C                   Eval      PosNeg = ''
E003 C                   EndIf
      * Format & add to current record
     C                   ExSr      ProcNbr

      * Packed numeric data type
S002 C                   When      L_DataType = 'P'
     C                   Eval      PackField30 = *Zero
     C                   EvalR     %SubSt(CharField16 : +
     C                                    17 - L_Length : +
     C                                    L_Length) =
     C                             %SubSt(RCDDTA : +
     C                                    L_OutBuffer : +
     C                                    L_Length )
      * Detect negative number, set sign & reverse sign of actual value (reapplied later)
B003 C                   If        PackField30 < 0
     C                   Eval      PosNeg = '-'
     C                   Eval      PackField30 = 0 - PackField30
X003 C                   Else
     C                   Eval      PosNeg = ''
E003 C                   EndIf
     C                   Move      PackField30   CharField30
      * Format & add to current record
     C                   ExSr      ProcNbr

      * Date data type
S002 C                   When      L_DataType = 'L'
     C                   Eval      CharDate =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
      * If rules required
B003 C                   If        FMRULE = 'Y'
     C     *ISO          Move      DateField     DateCvt
      * If change of date format required
B004 C                   If        FMINTF <> FMEXPF
     C                   ExSr      DateFmt
E004 C                   EndIf
     C                   Eval      ZoneField30 = DateCvt
     C                   Eval      IntSide = %SubSt(CharField30 : 23 : 8)
     C                   Eval      IntLen = 8
      * If date editing required
B004 C                   If        FMEDTD = 'Y'
     C                   ExSr      DateTimeEdit
E004 C                   EndIf
      * If zero fill not required
B004 C                   If        FMZFIL = ' '
     C                   ExSr      EditZ
E004 C                   EndIf
     C                   Eval      EditField = IntSide
      * Otherwise leave as-is
X003 C                   Else
     C                   Eval      EditField = CharDate
E003 C                   EndIf
      * First entry resets the field - no leading delimiter
B003 C                   If        Idx1 = 1
     C                   Eval      Record = EditField
X003 C                   Else
     C                   Eval      Record = Record + P_FldDel + EditField
E003 C                   EndIf

      * Time data type
S002 C                   When      L_DataType = 'T'
     C                   Eval      CharTime =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
      * If rules required
B003 C                   If        FMRULE = 'Y'
     C     *HMS          Move      TimeField     DateCvt
     C                   Eval      ZoneField30 = DateCvt
     C                   Eval      IntSide = %SubSt(CharField30 : 23 : 8)
     C                   Eval      IntLen = 8
      * If date editing required
B004 C                   If        FMEDTD = 'Y'
     C                   ExSr      DateTimeEdit
E004 C                   EndIf
      * If zero fill not required
B004 C                   If        FMZFIL = ' '
     C                   ExSr      EditZ
E004 C                   EndIf
     C                   Eval      EditField = IntSide
      * Otherwise leave as-is
X003 C                   Else
     C                   Eval      EditField = CharTime
E003 C                   EndIf
      * First entry resets the field - no leading delimiter
B003 C                   If        Idx1 = 1
     C                   Eval      Record = EditField
X003 C                   Else
     C                   Eval      Record = Record + P_FldDel + EditField
E003 C                   EndIf
      * Timestamp data type
S002 C                   When      L_DataType = 'Z'
     C                   Eval      Type_A =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
      * First entry resets the field - no leading delimiter
B003 C                   If        Idx1 = 1
     C                   Eval      Record = Type_A
X003 C                   Else
     C                   Eval      Record = Record + P_FldDel + Type_A
E003 C                   EndIf

      * Floating point data type (never seen any of these, so expect 'strange results')
S002 C                   When      L_DataType = 'F'
     C                   Eval      CharFloat =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
B003 C                   If        L_Digits <= 8
     C                   Eval      EditField = %EDITFLT(SmallFloat)
X003 C                   Else
     C                   Eval      EditField = %EDITFLT(FloatField)
E003 C                   EndIf
      * First entry resets the field - no leading delimiter
B003 C                   If        Idx1 = 1
     C                   Eval      Record = EditField
X003 C                   Else
     C                   Eval      Record = Record + P_FldDel + EditField
E003 C                   EndIf
      * Binary point data type (rarely use these, so don't expect much more than for floating point)
S002 C                   When      L_DataType = 'B'
     C                   Eval      CharBin =
     C                             %TrimR( %SubSt(RCDDTA : +
     C                                            L_OutBuffer : +
     C                                            L_Length ) )
B003 C                   If        L_Digits <= 4
     C                   Eval      ZoneField30 = SmallBin
X003 C                   Else
     C                   Eval      ZoneField30 = BinField
E003 C                   EndIf
      * Detect negative number, set sign & reverse sign of actual value (reapplied later)
B003 C                   If        ZoneField30 < 0
     C                   Eval      PosNeg = '-'
     C                   Eval      ZoneField30 = -ZoneField30
X003 C                   Else
     C                   Eval      PosNeg = ''
E003 C                   EndIf
      * Format & add to current record
     C                   ExSr      ProcNbr
E002 C                   EndSl
E001 C                   EndDo
      * Write out the current line
     C                   Except    TFRFORMAT
      *
     C                   EndSr
      **********************************************************************************************
      * ProcNbr: Process number field (Zoned, Packed & Binary)
      **********************************************************************************************
     C     ProcNbr       BegSr
      *
     C                   Eval      DecSym = '.'
      * If not using edit rules, or rules set but number isn't a date
B001 C                   If        FMRULE = ' '
     C                             Or FMRULE = 'Y' And FMDATE = ' '
      * Split up field into decimal & interger portions if present
B002 C                   If        L_DecimalPos > 0
     C                   Eval      DecSide = %SubSt(CharField30 : +
     C                                              31 - L_DecimalPos : +
     C                                              L_DecimalPos)
     C                   Eval      IntSide = %SubSt(CharField30 : +
     C                                              31 - L_Digits : +
     C                                              L_Digits - L_DecimalPos)
X002 C                   Else
     C                   Eval      DecSide = ''
     C                   Eval      DecSym = ''
     C                   Eval      IntSide = %SubSt(CharField30 : +
     C                                              31 - L_Digits : +
     C                                              L_Digits)
E002 C                   EndIf
      * Zero suppression (unless explicitly not required)
B002 C                   If        FMRULE = ' '
     C                             Or FMRULE = 'Y' And FMZFIL = ' '
     C                   Eval      IntLen = L_Digits - L_DecimalPos
     C                   ExSr      EditZ
E002 C                   EndIf
      * Set format of negative values
B002 C                   Select
      * Negatives as -123.45 (default)
S002 C                   When      FMRULE = ' '
     C                             Or FMRULE = 'Y' And FMNEGF = '*FLOAT'
     C                   Eval      EditField = PosNeg + IntSide + DecSym +
     C                             DecSide
      * Negatives as 123.45-
S002 C                   When      FMRULE = 'Y' And FMNEGF = '*MINUS'
     C                   Eval      EditField = IntSide + DecSym + DecSide +
     C                             PosNeg
      * Negatives as 123.45CR
S002 C                   When      FMRULE = 'Y' And FMNEGF = '*CR'
     C                   Eval      EditField = IntSide + DecSym + DecSide
B003 C                   If        PosNeg = '-'
     C                   Eval      EditField = EditField + 'CR'
E003 C                   EndIf
      * Negatives as (123.45)
S002 C                   When      FMRULE = 'Y' And FMNEGF = '*BRKTS'
     C                   Eval      EditField = IntSide + DecSym + DecSide
B003 C                   If        PosNeg = '-'
     C                   Eval      EditField = '(' + EditField + ')'
E003 C                   EndIf
E002 C                   EndSl
E001 C                   EndIf
      * If date formatting required
B001 C                   If        FMRULE = 'Y' And FMDATE = 'Y'
      * If change of date format required
B002 C                   If        FMINTF <> FMEXPF
     C                   Eval      DateCvt = ZoneField30
     C                   ExSr      DateFmt
     C                   Eval      ZoneField30 = DateCvt
E002 C                   EndIf
     C                   Eval      IntSide = %SubSt(CharField30 : 23 : 8)
     C                   Eval      IntLen = 8
      * If date editing required
B002 C                   If        FMEDTD = 'Y'
     C                   ExSr      DateTimeEdit
E002 C                   EndIf
      * If zero fill not required
B002 C                   If        FMZFIL = ' '
     C                   ExSr      EditZ
E002 C                   EndIf
     C                   Eval      EditField = IntSide
E001 C                   EndIf
      * First entry resets the field - no leading delimiter
B001 C                   If        Idx1 = 1
     C                   Eval      Record = EditField
X001 C                   Else
     C                   Eval      Record = Record + P_FldDel + EditField
E001 C                   EndIf
      *
     C                   EndSr
      **********************************************************************************************
      * EditZ: Trim leading zeros (always leave one)
      **********************************************************************************************
     C     EditZ         BegSr
      * Leading zero suppression
     C     '0'           Check     IntSide       Idx2                     70
      * If non-zero value found, strip all leading zeros
B001 C                   If        *IN70
     C                   Eval      IntSide = %SubSt(IntSide : +
     C                                              Idx2 : +
     C                                              ((IntLen + 1) - Idx2))
      * If processing a date/time and the separator is the first character, add a leading zero
B002 C                   If        FMRULE = 'Y' And FMEDTD = 'Y'
     C                             And %SubSt(IntSide : 1 : 1) = FMDSEP
     C                   Eval      IntSide = '0' + IntSide
E002 C                   EndIf
X001 C                   Else
      * Include a single leading zero if no integer portion
     C                   Eval      IntSide = '0'
E001 C                   EndIf
      *
     C                   EndSr
      **********************************************************************************************
      * DateFmt: Date formatting
      **********************************************************************************************
     C     DateFmt       BegSr
      *
     C                   Eval      Day = 0
     C                   Eval      Month = 0
     C                   Eval      Year = 0
     C                   Eval      Centry = 0
B001 C                   If        DateCvt <> 0
      *  Split out date subsections ready for reformatting
B002 C                   Select
      *
S002 C                   When      FMINTF = '*CYMD'
     C                   Eval      Cymd = DateCvt
     C                   Eval      Day = D_Cymd
     C                   Eval      Month = M_Cymd
     C                   Eval      Year = Y_Cymd
     C                   Eval      Centry = C_Cymd
      *
S002 C                   When      FMINTF = '*SYMD'
     C                   Eval      Cymd = DateCvt
     C                   Eval      Day = D_Cymd
     C                   Eval      Month = M_Cymd
     C                   Eval      Year = Y_Cymd
      *  Set century from Synon century digit
     C                   Eval      Centry = 19 + C_Cymd
      *
S002 C                   When      FMINTF = '*YMD'
     C                   Eval      Cymd = DateCvt
     C                   Eval      Day = D_Cymd
     C                   Eval      Month = M_Cymd
     C                   Eval      Year = Y_Cymd
     C                   Eval      Centry = C_Cymd
      *  Assume century
B003 C                   If        Year < FMWINY
     C                   Eval      Centry = 20
X003 C                   Else
     C                   Eval      Centry = 19
E003 C                   EndIf
      *
S002 C                   When      FMINTF = '*MDY'
     C                   Eval      Mdy = DateCvt
     C                   Eval      Day = D_Mdy
     C                   Eval      Month = M_Mdy
     C                   Eval      Year = Y_Mdy
      *  Assume century
B003 C                   If        Year < FMWINY
     C                   Eval      Centry = 20
X003 C                   Else
     C                   Eval      Centry = 19
E003 C                   EndIf
      *
S002 C                   When      FMINTF = '*MDCY'
     C                   Eval      Mdcy = DateCvt
     C                   Eval      Day = D_Mdcy
     C                   Eval      Month = M_Mdcy
     C                   Eval      Year = Y_Mdcy
     C                   Eval      Centry = C_Mdcy
      *
S002 C                   When      FMINTF = '*DMCY'
     C                   Eval      Dmcy = DateCvt
     C                   Eval      Day = D_Dmcy
     C                   Eval      Month = M_Dmcy
     C                   Eval      Year = Y_Dmcy
     C                   Eval      Centry = C_Dmcy
      *
S002 C                   When      FMINTF = '*LILIAN'
     C     FMLILS        AddDur    DateCvt:*DAYS WorkDate
     C                   SubDur    1:*DAYS       WorkDate
     C     *ISO          Move      WorkDate      Cymd
     C                   Eval      Day = D_Cymd
     C                   Eval      Month = M_Cymd
     C                   Eval      Year = Y_Cymd
     C                   Eval      Centry = C_Cymd
      *
S002 C                   When      FMINTF = '*DMY'
     C                   Eval      Dmy = DateCvt
     C                   Eval      Day = D_Dmy
     C                   Eval      Month = M_Dmy
     C                   Eval      Year = Y_Dmy
      *  Assume century
B003 C                   If        Year < FMWINY
     C                   Eval      Centry = 20
X003 C                   Else
     C                   Eval      Centry = 19
E003 C                   EndIf
      *
S002 C                   When      FMINTF = '*CYM'
     C                   Eval      Cym = DateCvt
     C                   Eval      Month = M_Cym
     C                   Eval      Year = Y_Cym
     C                   Eval      Centry = C_Cym
      *
S002 C                   When      FMINTF = '*YM'
     C                   Eval      Cym = DateCvt
     C                   Eval      Month = M_Cym
     C                   Eval      Year = Y_Cym
      *  Assume century
B003 C                   If        Year < FMWINY
     C                   Eval      Centry = 20
X003 C                   Else
     C                   Eval      Centry = 19
E003 C                   EndIf
      *
S002 C                   When      FMINTF = '*MY'
     C                   Eval      Dmy = DateCvt
     C                   Eval      Day = D_Dmy
     C                   Eval      Month = M_Dmy
     C                   Eval      Year = Y_Dmy
      *  Assume century
B003 C                   If        Year < FMWINY
     C                   Eval      Centry = 20
X003 C                   Else
     C                   Eval      Centry = 19
E003 C                   EndIf
E002 C                   EndSl
      *
      *  Now move the date subsections to the required format
      *
B002 C                   Select
      *
S002 C                   When      FMEXPF = '*CYMD'
     C                   Eval      D_Cymd = Day
     C                   Eval      M_Cymd = Month
     C                   Eval      Y_Cymd = Year
     C                   Eval      C_Cymd = Centry
     C                   Eval      DateCvt= Cymd
      *
S002 C                   When      FMEXPF = '*LILIAN'
     C     *ISO          Move      Cymd          WorkDate
     C     WorkDate      SubDur    FMLILS        DateCvt:*DAYS
     C                   Eval      DateCvt = DateCvt + 1
     C                   Eval      DateCvt= Cymd
      *
S002 C                   When      FMEXPF = '*SYMD'
     C                   Eval      D_Cymd = Day
     C                   Eval      M_Cymd = Month
     C                   Eval      Y_Cymd = Year
      *  Set Synon century digit
     C                   Eval      C_Cymd = Centry - 19
     C                   Eval      DateCvt= Cymd
      *
S002 C                   When      FMEXPF = '*YMD'
     C                   Eval      D_Cymd = Day
     C                   Eval      M_Cymd = Month
     C                   Eval      Y_Cymd = Year
     C                   Eval      C_Cymd = 0
     C                   Eval      DateCvt= Cymd
      *
S002 C                   When      FMEXPF = '*MDY'
     C                   Eval      D_Mdy = Day
     C                   Eval      M_Mdy = Month
     C                   Eval      Y_Mdy = Year
     C                   Eval      DateCvt= Mdy
      *
S002 C                   When      FMEXPF = '*MDCY'
     C                   Eval      D_Mdcy = Day
     C                   Eval      M_Mdcy = Month
     C                   Eval      Y_Mdcy = Year
     C                   Eval      C_Mdcy = Centry
     C                   Eval      DateCvt= Mdcy
      *
S002 C                   When      FMEXPF = '*DMY '
     C                   Eval      D_Dmy = Day
     C                   Eval      M_Dmy = Month
     C                   Eval      Y_Dmy = Year
     C                   Eval      DateCvt= Dmy
      *
S002 C                   When      FMEXPF = '*DMCY'
     C                   Eval      D_Dmcy = Day
     C                   Eval      M_Dmcy = Month
     C                   Eval      Y_Dmcy = Year
     C                   Eval      C_Dmcy = Centry
     C                   Eval      DateCvt= Dmcy
      *
S002 C                   When      FMEXPF = '*CYM'
     C                   Eval      M_Cym = Month
     C                   Eval      Y_Cym = Year
     C                   Eval      C_Cym = Centry
     C                   Eval      DateCvt= Cym
      *
S002 C                   When      FMEXPF = '*YM'
     C                   Eval      M_Cym = Month
     C                   Eval      Y_Cym = Year
     C                   Eval      C_Cym = 0
     C                   Eval      DateCvt= Cym
      *
S002 C                   When      FMEXPF = '*MY'
     C                   Eval      M_Dmy = Month
     C                   Eval      Y_Dmy = Year
     C                   Eval      D_Dmy = 0
     C                   Eval      C_Cym = 0
     C                   Eval      DateCvt= Dmy
E002 C                   EndSl
E001 C                   EndIf
      *
     C                   EndSr
      **********************************************************************************************
      * DateTimeEdit: Date/Time Editing
      **********************************************************************************************
     C     DateTimeEdit  BegSr
      *
B001 C                   Select
      * nnnn/nn/nn format
S001 C                   When      FMEXPF = '*CYMD'
     C                   Eval      IntSide = %SubSt(IntSide : 1 : 4) +
     C                             FMDSEP + %SubSt(IntSide : 5 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 7 : 2)
     C                   Eval      IntLen = 10
      * nnn/nn/nn format
S001 C                   When      FMEXPF = '*SYMD'
     C                   Eval      IntSide = %SubSt(IntSide : 2 : 3) +
     C                             FMDSEP + %SubSt(IntSide : 5 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 7 : 2)
     C                   Eval      IntLen = 9
      * nn/nn/nn format
S001 C                   When      FMEXPF = '*YMD' Or FMEXPF = '*MDY'
     C                             Or FMEXPF = '*DMY' Or FMEXPF = '*HMS'
     C                   Eval      IntSide = %SubSt(IntSide : 3 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 5 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 7 : 2)
     C                   Eval      IntLen = 8
      *
S001 C                   When      FMEXPF = '*MDCY' Or FMEXPF = '*DMCY'
     C                   Eval      IntSide = %SubSt(IntSide : 1 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 3 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 5 : 4)
     C                   Eval      IntLen = 10
      *
S001 C                   When      FMEXPF = '*CYM'
     C                   Eval      IntSide = %SubSt(IntSide : 3 : 4) +
     C                             FMDSEP + %SubSt(IntSide : 7 : 2)
     C                   Eval      IntLen = 7
      *
S001 C                   When      FMEXPF = '*YM' Or FMEXPF = '*MY'
     C                             Or FMEXPF = '*HM'
     C                   Eval      IntSide = %SubSt(IntSide : 5 : 2) +
     C                             FMDSEP + %SubSt(IntSide : 7 : 2)
     C                   Eval      IntLen = 5
E001 C                   EndSl
      *
     C                   EndSr
      **********************************************************************************************
      * Inits: Program initialisation
      **********************************************************************************************
     C     Inits         BegSr
      * Use the QUSLRCD (List Record Formats) and QUSLFLD (List Fields) APIs to get the fields
      * for the input file.
     C                   Eval      QualifyFile = P_File + P_Library
      * Create a user space to hold the format list entries
     C                   Call      'QUSCRTUS'
     C                   Parm                    UserSpace
     C                   Parm                    ExtendAttr
     C                   Parm                    InitialSiz
     C                   Parm                    InitialVal
     C                   Parm                    PublicAut
     C                   Parm                    TextDescrp
     C                   Parm                    ReplaceSpc
     C                   Parm                    Error_Code
      * List the formats in the file
     C                   Call      'QUSLRCD'
     C                   Parm                    UserSpace
     C                   Parm      'RCDL0100'    ListFormat
     C                   Parm                    QualifyFile
     C                   Parm                    OverrideProc
     C                   Parm                    Error_Code
      * Get the header info for this space
     C                   Call      'QUSRTVUS'
     C                   Parm                    UserSpace
     C                   Parm                    StartPos
     C                   Parm                    DataLength
     C                   Parm                    GenRcvrDS
     C                   Parm                    Error_Code
      * Process returned entries
B001 C                   If        ListNumber > 0
      * Set the initial offset for the start of the list entries
     C                   Eval      ListOffset = ListOffset + 1
      * Get the header info for this space
     C                   Call      'QUSRTVUS'
     C                   Parm                    UserSpace
     C                   Parm                    ListOffset
     C                   Parm                    EntrySize
     C                   Parm                    RcdL0100DS
     C                   Parm                    Error_Code
      * Only interested in the first format - there should only be one for a physical file.
     C                   Eval      FileFormat = L_FormatName
E001 C                   EndIf
      * Now the format name is known, the fields for the file can be retrieved
      * Create a user space to hold the field list entries
     C                   Call      'QUSCRTUS'
     C                   Parm                    UserSpace
     C                   Parm                    ExtendAttr
     C                   Parm                    InitialSiz
     C                   Parm                    InitialVal
     C                   Parm                    PublicAut
     C                   Parm                    TextDescrp
     C                   Parm                    ReplaceSpc
     C                   Parm                    Error_Code
      * List the fields in the file using the format just obtained
     C                   Call      'QUSLFLD'
     C                   Parm                    UserSpace
     C                   Parm      'FLDL0100'    ListFormat
     C                   Parm                    QualifyFile
     C                   Parm                    FileFormat
     C                   Parm                    OverrideProc
     C                   Parm                    Error_Code
      * Get the header info for this space
     C                   Call      'QUSRTVUS'
     C                   Parm                    UserSpace
     C                   Parm                    StartPos
     C                   Parm                    DataLength
     C                   Parm                    GenRcvrDS
     C                   Parm                    Error_Code
      *
     C                   Eval      OnePercent = NbrOfRcds / 100
      *
     C                   EndSr
      **********************************************************************************************
     ODBGCSV00  E            TFRFORMAT
     O                       Record            5000
</verbatim>
This topic: DBG400 > SourceCodeList > RpgleSource > RpgleDBG201R4
Topic revision: r1 - 26 May 2005 - 19:55:06 - MartinRowe
Copyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors.
Ideas, requests, problems regarding DBG/400? Send feedback