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