You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG200R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG200R4: Field Mapping selection
* 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:
**********************************************************************************************
* Field mapping screen
FDBG200DF CF E WORKSTN INFDS(SCREEN_DS)
F SFILE(SFL:RRN)
* Field mapping table
FDBGFMT00 UF A E K DISK
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* Program Name
D SDS
D SDS_PGM 10
*
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_VaryField 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
D L_FormatName 10A OVERLAY( RcdL0100 : 1 )
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D Cmdlength S 15 5
D Cmdstring S 256
D CurrentEnt S 5P 0 INZ(1)
D DataLength S 9B 0 INZ(140)
D DefaultNegF S 6 INZ('*FLOAT')
D DefaultEdtD S 6 INZ('Y')
D DefaultExpF S 8 INZ('*CYMD')
D DefaultDSep S 6 INZ('/')
D DefaultLils S D INZ(D'1978-01-01') True date 1578-10-15
D DefaultWinY S 2 0 INZ(40)
D DefaultPFix S 1 INZ(' ')
D ExtendAttr S 10 INZ('USRSPC ')
D FileFormat S 10
D InitialSiz S 9B 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D ListFormat S 8
D Number4 S 4 0
D Number1 S 1 0
D OverrideProc S 1 INZ('0')
D P_ErrorID S 7
D P_Library S 10
D P_MsgData S 512
D P_MsgDtaLn S 5 0
D P_MsgFile S 10
D P_MsgfLib S 10
D P_MsgID S 7
D P_MsgType S 10
D P_Pgm S 10
D P_PgmQueue S 10
D P_PgmStack S 5 0
D PublicAut S 10 INZ('*ALL ')
D QualifyFile S 20
D ReturnCode S 7
D ReplaceSpc S 10 INZ('*YES ')
D Rrn S 4 0
D StartPos S 9B 0 INZ(1)
D TextDescrp S 50 INZ('QUSLRCD/QUSLFLD List APIs')
D UserSpace S 20 INZ('DBG105US QTEMP ')
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
D F3 C CONST(X'33')
D F12 C CONST(X'3C')
D HELP C CONST(X'F3')
* Nomenclature: suffix(s) added in alphabetical order to main colour name.
* Colours are, Blue, Green, Pink, Red, Turq(uoise), White & Yellow.
* Bl=Blink, Cs=Column seperators, Hi=High intensity, Rv=Reverse image, Ul=Underline,
D Green C CONST(X'20')
D GreenRv C CONST(X'21')
D White C CONST(X'22')
D WhiteRv C CONST(X'23')
D GreenUL C CONST(X'24')
D GreenRvUl C CONST(X'25')
D WhiteUL C CONST(X'26')
D NonDisplay C CONST(X'27')
D Red C CONST(X'28')
D RedRv C CONST(X'29')
D RedHi C CONST(X'2A')
D RedHiRv C CONST(X'2B')
D RedUl C CONST(X'2C')
D RedRvUl C CONST(X'2D')
D RedBlUl C CONST(X'2E')
D TurqCs C CONST(X'30')
D TurqCsRv C CONST(X'31')
D YellowCs C CONST(X'32')
D WhiteCsRv C CONST(X'33')
D TurqCsUl C CONST(X'34')
D TurqCsRvUl C CONST(X'35')
D YellowCsUl C CONST(X'36')
D Pink C CONST(X'38')
D PinkRv C CONST(X'39')
D Blue C CONST(X'3A')
D BlueRv C CONST(X'3B')
D PinkUl C CONST(X'3C')
D PinkRvUl C CONST(X'3D')
D BlueUl C CONST(X'3E')
* Protected field attributes
D ProGreen C CONST(X'A0')
D ProGreenRv C CONST(X'A1')
D ProWhite C CONST(X'A2')
D ProWhiteRv C CONST(X'A3')
D ProGreenUL C CONST(X'A4')
D ProGreenRvUl C CONST(X'A5')
D ProWhiteUL C CONST(X'A6')
D ProNonDisplay C CONST(X'A7')
D ProRed C CONST(X'A8')
D ProRedRv C CONST(X'A9')
D ProRedHi C CONST(X'AA')
D ProRedHiRv C CONST(X'AB')
D ProRedUl C CONST(X'AC')
D ProRedRvUl C CONST(X'AD')
D ProRedBlUl C CONST(X'AE')
D ProTurqCs C CONST(X'B0')
D ProTurqCsRv C CONST(X'B1')
D ProYellowCs C CONST(X'B2')
D ProWhiteCsRv C CONST(X'B3')
D ProTurqCsUl C CONST(X'B4')
D ProTurqCsRvUl C CONST(X'B5')
D ProYellowCsUl C CONST(X'B6')
D ProPink C CONST(X'B8')
D ProPinkRv C CONST(X'B9')
D ProBlue C CONST(X'BA')
D ProBlueRv C CONST(X'BB')
D ProPinkUl C CONST(X'BC')
D ProPinkRvUl C CONST(X'BD')
D ProBlueUl C CONST(X'BE')
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P_FILE
C PARM P_Library
C PARM P_TEXT
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
C DBGFMT00KEY KLIST
C KFLD P_Library
C KFLD P_FILE
C KFLD S_IFLD
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
* Initialisation
C EXSR Inits
* Repeat display until exit requested
B001 C DOW KeyPress <> F3
*
C EVAL *IN36 = Rrn > 0
C WRITE FOOTER
C WRITE MSFLC MSG SUBFILE
C EXFMT SFLCTL DISPLAY SCREEN
* Remove messages from queue after display
C CALL 'DBG045CL' 90
* Process response
B002 C SELECT
* F1/Help pressed
S002 C WHEN KeyPress = HELP
C CALL (E) 'DBG010R4'
C PARM SDS_PGM P_Pgm
* F3=Exit
S002 C WHEN KeyPress = F3
C LEAVE
* F12=Previous
S002 C WHEN KeyPress = F12
C LEAVE
* Field selected
S002 C OTHER
B003 C IF Rrn > 0
C READC SFL
B004 C DOW NOT %EOF(DBG200DF)
B005 C IF S_EDIT = '2'
C EXSR ProcSFL
B006 C IF KeyPress = F3
C LEAVE
E006 C ENDIF
C EVAL S_EDIT = ' '
C UPDATE SFL
E005 C ENDIF
C READC SFL
E004 C ENDDO
B004 C IF KeyPress = F3
C LEAVE
E004 C ENDIF
E003 C ENDIF
E002 C ENDSL
*
E001 C ENDDO
* EXIT PROGRAM
C EVAL *INLR = *on
C RETURN
**********************************************************************************************
* BUILD: Build subfile for input file
**********************************************************************************************
C BUILD BEGSR
* Clear subfile prior to build
C EVAL Rrn = 0
C EVAL *IN36 = *off
C EVAL *IN35 = *on
C EVAL SFPAGE = 1
C WRITE SFLCTL
* Set up subfile field from file text
* 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
* Load the subfile record from the retrieved entry (in FldL0100DS)
C EVAL Rrn = Rrn + 1
C EVAL S_IFLD = L_FieldName
C EVAL S_ITXT = L_FieldText
C EVAL S_IITP = L_DataType
* If numeric, set size & decimal places
B003 C IF L_Digits > 0
C EVAL Number4 = L_Digits
C EVAL S_INLN = %EDITC(Number4 : 'Z')
C EVAL Number1 = L_DecimalPos
C MOVE Number1 S_INSC
* Otherwise just set the size
X003 C ELSE
C EVAL Number4 = L_Length
C EVAL S_INLN = %EDITC(Number4 : 'Z')
C EVAL S_INSC = *blanks
E003 C ENDIF
* Dump the record to screen
C DBGFMT00KEY CHAIN (N) DBGFMT00
B003 C IF %FOUND(DBGFMT00)
C AND FMRULE = 'Y'
C EVAL DA_IFLD = White
X003 C ELSE
C EVAL DA_IFLD = Green
E003 C ENDIF
C WRITE SFL
* 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
*
C ENDSR
**********************************************************************************************
* ProcSFL: Process subfile
**********************************************************************************************
C ProcSFL BEGSR
*
C DBGFMT00KEY CHAIN (N) DBGFMT00
B001 C IF %FOUND(DBGFMT00)
C EVAL S_RULE = FMRULE
C EVAL S_ZFIL = FMZFIL
C EVAL S_NEGF = FMNEGF
C EVAL S_DATE = FMDATE
C EVAL S_INTF = FMINTF
C EVAL S_EXPF = FMEXPF
C EVAL S_EDTD = FMEDTD
C EVAL S_DSEP = FMDSEP
C EVAL S_WINY = FMWINY
C EVAL S_LILS = FMLILS
C EVAL S_PFIX = FMPFIX
* Otherwise set default values
X001 C ELSE
C EVAL S_RULE = *blanks
C EVAL S_ZFIL = *blanks
C EVAL S_DATE = *blanks
C EVAL S_INTF = *blanks
C EVAL S_EXPF = DefaultExpF
C EVAL S_NEGF = DefaultNegF
C EVAL S_EDTD = DefaultEdtD
C EVAL S_DSEP = DefaultDSep
C EVAL S_WINY = DefaultWinY
C EVAL S_LILS = DefaultLils
C EVAL S_PFIX = DefaultPFix
E001 C ENDIF
*
B001 C DOW KeyPress <> F3
C WRITE FOOTER2
C WRITE MSFLCWIN MSG SUBFILE
C EXFMT WINDOW1
* Remove messages from queue after display
C CALL 'DBG045CL' 90
* Process response
B002 C SELECT
* F1/Help pressed
S002 C WHEN KeyPress = HELP
C CALL (E) 'DBG010R4'
C PARM SDS_PGM P_Pgm
* F3=Exit
S002 C WHEN KeyPress = F3
C LEAVE
* F12=Previous
S002 C WHEN KeyPress = F12
C LEAVE
* Validate field mapping
S002 C OTHER
C EVAL DA_INTF = GreenRvUl
C EVAL DA_EXPF = GreenRvUl
B003 C SELECT
* *HMS values can only be converted to *HMS or *HM
S003 C WHEN S_INTF = '*HMS' AND (S_EXPF <> '*HMS'
C OR S_EXPF = '*HM')
C EVAL P_MsgID = 'GSM9999'
C EVAL P_MsgData = '*HMS can only be converted to -
C *HM or *HMS'
C EVAL P_MsgDtaLn = 512
C EVAL P_PgmStack = 0
C EVAL P_MsgType = '*INFO'
C EXSR SndMsg
* *HM values can only go to *HM
S003 C WHEN S_INTF = '*HM' AND S_EXPF <> '*HM'
C EVAL P_MsgID = 'GSM9999'
C EVAL P_MsgData = '*HM can only be converted to -
C *HM'
C EVAL P_MsgDtaLn = 512
C EVAL P_PgmStack = 0
C EVAL P_MsgType = '*INFO'
C EXSR SndMsg
* *MY, *YM & *CYM cannot be exported to a format with a day value
S003 C WHEN (S_INTF = '*MY' OR S_INTF = '*YM' OR
C S_INTF = '*CYM') AND S_EXPF <> '*MY' AND
C S_EXPF <> '*YM' AND S_EXPF <> '*CYM'
C EVAL P_MsgID = 'GSM9999'
C EVAL P_MsgData = 'No day value in internal format'
C EVAL P_MsgDtaLn = 512
C EVAL P_PgmStack = 0
C EVAL P_MsgType = '*INFO'
C EXSR SndMsg
S003 C OTHER
C EVAL DA_INTF = GreenUL
C EVAL DA_EXPF = GreenUL
C DBGFMT00KEY CHAIN DBGFMT00
C EVAL FMRULE = S_RULE
C EVAL FMZFIL = S_ZFIL
C EVAL FMNEGF = S_NEGF
C EVAL FMDATE = S_DATE
C EVAL FMINTF = S_INTF
C EVAL FMEXPF = S_EXPF
C EVAL FMEDTD = S_EDTD
C EVAL FMDSEP = S_DSEP
C EVAL FMWINY = S_WINY
C EVAL FMLILS = S_LILS
C EVAL FMPFIX = S_PFIX
B004 C IF %FOUND(DBGFMT00)
C UPDATE DBGFMT0
X004 C ELSE
C EVAL FMFILE = P_FILE
C EVAL FMLIB = P_Library
C EVAL FMFLD = S_IFLD
C WRITE DBGFMT0
E004 C ENDIF
B004 C IF S_RULE = 'Y'
C EVAL DA_IFLD = White
X004 C ELSE
C EVAL DA_IFLD = Green
E004 C ENDIF
C LEAVE
E003 C ENDSL
E002 C ENDSL
E001 C ENDDO
*
C ENDSR
**********************************************************************************************
* Inits: Program initialisation
**********************************************************************************************
C Inits BEGSR
* Get company name
C *DTAARA DEFINE DBGCOMP COMPNY
C IN COMPNY
* 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
* Build subfile for display
C EXSR BUILD
*
C ENDSR
**********************************************************************************************
* SndMsg: SEND PROGRAM MESSAGE
**********************************************************************************************
C SndMsg BEGSR
* Use in-house utility (via system API 'QMHSNDPM')
C CALL 'DBG044R3'
C PARM P_MsgID
C PARM 'DBGMSGF ' P_MsgFile
C PARM '*LIBL ' P_MsgfLib
C PARM P_MsgData
C PARM P_MsgDtaLn
C PARM P_MsgType
C PARM SDS_PGM P_PgmQueue
C PARM P_PgmStack
C PARM ' ' P_ErrorID
*
C ENDSR
**********************************************************************************************
Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 19:54:22 - MartinRowe
Site Map
DBG400
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