|
midrange.com
Here's the complete source. It works on my V5R1 machine.
Fnfiled CF E WORKSTN
F SFILE(SFL01:RRN)
F SFILE(SFL02:RRN2)
F SFILE(SFL03:RRN3)
F INFDS(WDSUBF)
Fffd001PF IF F 120 DISK USROPN
FFFD002PF IF F 86 DISK USROPN
Fnfilep O E PRINTER USROPN
,****************************************************************
D SpacePtr S *
D HeaderPtr S *
D DBRPtr S *
,**
D Userspace DS BASED(Spaceptr)
D Data 1 DIM(32767)
D OffsetHdr 117 120B 0
D OffsetDBR 125 128B 0
D NumLstEnt 133 136B 0
D EntrySize 137 140B 0
,**
D Header DS BASED(HeaderPtr)
D FileName 10
D LibName 10
D FileType 10
D RcdFmtName 10
D RecLength 9B 0
D RecFmtID 13
D RecTxtD 50
D Reserved1 1
D RTDesCCDID 9B 0
D VLFFmtID 1
D GrphFID 1
D DatTimFID 1
D NullCapFID 1
,**
D List DS
D FldName 10
D DataType 1
D Use 1
D OutBuffPos 9B 0
D InBuffPos 9B 0
D FldLength 9B 0
D Digits 9B 0
D DecPos 9B 0
D FldTextD 50
D EditCode 2
D EditWordL 9B 0
D EditWord 64
D ColHdg1 20
D ColHdg2 20
D ColHdg3 20
D IntFldName 10
D AltFldName 30
D AltFldNL 9B 0
D #DBCSChars 9B 0
D NullAllow 1
D VarFldInd 1
D DatTimFmt 4
D DatTimSep 1
D VarLFLDInd 1
D FTDCCSID 9B 0
D FDCCSID 9B 0
D FCHCCSID 9B 0
D FEWCCSID 9B 0
D New1 9B 0
D New2 9B 0
D New3 9B 0
D New4 9B 0
D New5 9B 0
D New6 128
D New7 10
D New8 1
D New9 1
D New10 1
D New11 1
D New12 1
D New13 1
,**
D DBRFormat DS BASED(DBRPtr)
D DBFName 10
D DBLName 10
D DBDFName 10
D DBDLName 10
D DBDType 1
D Reserved2 3
D DBJoinRef# 9B 0
D DBCNmLen 9B 0
D DBCCName 258
D DBCLib 10
,**
D WDSUBF DS
D W$KEY 369 369
D SFLPG# 378 379B 0
,**
D @enter C CONST(X'F1')
D @f3 C CONST(X'33')
D @f5 C CONST(X'35')
D @f6 C CONST(X'36')
D @f7 C CONST(X'37')
D @f8 C CONST(X'38')
D @f9 C CONST(X'39')
D @f10 C CONST(X'3A')
D @f12 C CONST(X'3C')
D @f13 C CONST(X'B1')
D @f14 C CONST(X'B2')
D @f15 C CONST(X'B3')
D @f17 C CONST(X'B5')
D @f18 C CONST(X'B6')
D @f24 C CONST(X'BC')
,**
D LstSpcName C CONST('FFD001US QTEMP ')
D DBRSpcName C CONST('FFD002US QTEMP ')
D KeySize C CONST(99)
,**
D Up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D Low C 'abcdefghijklmnopqrstuvwxyz'
,**
D SpaceName S 20
D SpaceAtr S 10
D SpaceSiz S 9B 0 INZ(32767)
D SpaceStart S 9B 0
D DataSize S 9B 0 INZ(%size(List))
D SpaceInv S 1
D SpaceAut S 10 INZ('*ALL')
D SpaceDes S 50 INZ('User Space For LSTFFD')
D FmtName S 8 INZ('FLDL0100')
,**
D Keys S 10 DIM(KeySize)
D Pos S 2 DIM(KeySize)
,**
D WPQFName S 20
D WPMember S 10 INZ('*FIRST')
D WPOverRide S 1 INZ('0')
D WPError S 9B 0
,**
D SFld S Like(WWFLD)
D SDsc S Like(WWDSC)
D Text1 S Like(WWDSC)
D Text2 S Like(WWDSC)
,**
D Desc2 S Like(WFDESC)
,**
D QCmdCmd S 256
D QCmdLength S 15 5 INZ(256)
D LibFile S 20
D RRN S 4 0
D RRN2 S 4 0
D RRN3 S 4 0
D #Fields S 4 0
D #Triggers S 4 0
D i S 4 0
D j S 4 0
D ssStart S 4 0
D Decimals S 2 0
D OvrCnt S 2 0 INZ(1)
D FirstSrch S 1 INZ('Y')
,****************************************************************
IFFD001PF NS
I 63 63 APUNIQ
I 69 78 APBOF
I 79 88 APBOL
I 101 110 APKEYF
I P 115 116 0APKEYN
IFFD002PF NS
I 62 62 TRTRTM
I 63 63 TRTREV
I 64 64 TRTRCN
I 65 74 TRTRIG
I 75 84 TRTRLB
,****************************************************************
c If WpPrint = '*YES'
C EXSR $PRINT
c Eval *InLr = *On
c Return
c EndIf
,**
C EXSR $DISPLAY
,**
C SETON LR
,****************************************************************
,**Display the Subfile *
,****************************************************************
C $DISPLAY BEGSR
,**
C dow (W$KEY <> @f3)
,**
C select
C when (OvrCnt = 1)
C WRITE OVR01
C when (OvrCnt = 2)
C WRITE OVR02
C other
C WRITE OVR01
C endsl
,**
C EXFMT CTL01
C eval RECNBR = SFLPG#
C eval WSMSG = ' '
,**
C select
C when (W$KEY = @f5)
C EXSR $SEARCH
C when (W$KEY = @f6)
C EXSR $PRINT
C when (W$KEY = @f7)
C EXSR $SEARCHFLD
C when (W$KEY = @f8)
C EXSR $SEARCHDSC
C when (W$KEY = @f9)
C EXSR $DSPDBR
C when (W$KEY = @f10)
C EXSR $TRIGGERS
C when (W$KEY = @f13) or (W$KEY = @f14)
C EXSR $QUERY
C when (W$KEY = @f15)
C EXSR $DSPSRC
C when (W$KEY = @f17)
C eval RECNBR = 1
C when (W$KEY = @f18)
C eval RECNBR = #Fields
C when (W$KEY = @f24)
C eval OvrCnt = (OvrCnt + 1)
,**
C if (OvrCnt > 2)
C eval OvrCnt = 1
C endif
,**
C endsl
,**
C enddo
,**
C ENDSR
,****************************************************************
,**Display Datebase Realations Window *
,****************************************************************
C $DSPDBR BEGSR
c Eval FileLib = WpFile + WpLib
c Call 'EXPDBR'
c Parm FileLib 20
c Parm '*' Display 6
,**
C*******************EXFMT CTL02
,**
C if (*IN41)
C EXSR $PROCES2
C endif
,**
C ENDSR
,****************************************************************
,**List Triggers For The File *
,****************************************************************
C $TRIGGERS BEGSR
,**
C dow (W$KEY <> @f3) and (W$KEY <> @f12)
C WRITE OVR03
C EXFMT CTL03
,**
C if (W$KEY = @f6)
C EXSR $PRINTTRG
C endif
,**
C enddo
,**
C ENDSR
,****************************************************************
,**Print The File Field Descriptions *
,****************************************************************
C $PRINT BEGSR
,**
C OPEN nfilep
C WRITE HDG
C WRITE FILEHDG
,**
C 1 do #Fields i
C i CHAIN SFL01 99
,**
C if (not *IN99)
,**
C if (*INOF)
C WRITE HDG
C WRITE FILEHDG
C endif
,**
C WRITE FILEDET OF
C endif
,**
C enddo
,**
C CLOSE nfilep
C eval WSMSG = 'File has been printed.'
,**
C ENDSR
,****************************************************************
,**Print The File Trigger Information *
,****************************************************************
C $PRINTTRG BEGSR
,**
C OPEN nfilep
C WRITE HDG
C WRITE TRIGHDG
,**
C 1 do #Triggers i
C i CHAIN SFL03 99
,**
C if (not *IN99)
,**
C if (*INOF)
C WRITE HDG
C WRITE TRIGHDG
C endif
,**
C WRITE TRIGDET OF
C endif
,**
C enddo
,**
C CLOSE nfilep
,**
C ENDSR
,****************************************************************
,**Display Data with Query *
,****************************************************************
C $QUERY BEGSR
,**
C eval LibFile = %trim(WSLIB) + '/' + WSFILE
C eval QCmdCmd = 'RUNQRY *NONE ' + LibFile
,**
C if (W$KEY = @f14)
C eval QCmdCmd = %trim(QCmdCmd) + ' RCDSLT(*YES)'
C endif
,**
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
,**
C if (*IN99)
C eval WSMSG = 'Error running query command.'
C endif
,**
C ENDSR
,****************************************************************
,**Display Source *
,****************************************************************
C $DSPSRC BEGSR
,**
C eval LibFile = %trim(WSLIB) + '/' + WSFILE
C eval QCmdCmd = 'BRWOBJSRC OBJ(' + LibFile +
C ') OBJTYPE(*FILE)'
,**
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
,**
C if (*IN99)
C eval WSMSG = 'BRWOBJSRC command not found.'
C endif
,**
C ENDSR
,****************************************************************
,**Search By Field *
,****************************************************************
C $SEARCHFLD BEGSR
,**
C eval WWFLD = ' '
C eval WWDSC = ' '
,**
C dow (W$KEY <> @f12)
C EXFMT WIN01
,**
C if (W$KEY = @f12)
C eval SFld = ' '
C ITER
C endif
,**
C if (WWFLD <> ' ')
C Low:Up XLATE WWFLD SFld
C EXSR $SEARCH
C eval SFld = ' '
C LEAVE
C endif
,**
C enddo
,**
C ENDSR
,****************************************************************
,**Search By Description *
,****************************************************************
C $SEARCHDSC BEGSR
,**
C eval WWFLD = ' '
C eval WWDSC = ' '
,**
C dow (W$KEY <> @f12)
C EXFMT WIN02
,**
C if (W$KEY = @f12)
C eval SDsc = ' '
C ITER
C endif
,**
C if (WWDSC <> ' ')
C Low:Up XLATE WWDSC SDsc
C EXSR $SEARCH
C eval SDsc = ' '
C LEAVE
C endif
,**
C enddo
,**
C ENDSR
,****************************************************************
,**Process Subfile For Search *
,****************************************************************
C $SEARCH BEGSR
,**
C eval FirstSrch = 'Y'
,**
C 1 do #Fields i
C i CHAIN SFL01 99
,**
C if (not *IN99)
,**
C if (W$KEY <> @f5)
,**
C select
C when (SFld <> ' ')
C eval Text1 = SFld
C Low:Up XLATE WFFLDN Text2
C when (SDsc <> ' ')
C eval Text1 = SDsc
C Low:Up XLATE WFDESC2 Text2
C endsl
,**
C ' ' CHECKR Text1 j 99
,**
C if (not *IN99)
C eval j = %size(Text1)
C endif
,**
C Text1:j SCAN Text2 68
,**
C if (*IN68) and (FirstSrch = 'Y')
C eval RECNBR = RRN
C eval FirstSrch = 'N'
C endif
,**
C else
C eval *IN68 = *OFF
C endif
,**
C UPDATE SFL01
C endif
,**
C enddo
,**
C if (W$KEY <> @f5)
,**
C if (FirstSrch = 'Y')
C eval WSMSG = 'No matches found.'
C else
C eval WSMSG = 'Matched records highlighted. ' +
C 'Press F5 to clear.'
C endif
,**
C else
C eval WSMSG = 'Fields cleared.'
C endif
,**
C ENDSR
,****************************************************************
,**Initialize The Subfiles *
,****************************************************************
C $INIT BEGSR
,**
C eval RRN = 0
C MOVEA '0010' *IN(31)
C WRITE CTL01
C MOVEA '0100' *IN(31)
,**
C eval RRN2 = 0
C MOVEA '0010' *IN(41)
C WRITE CTL02
C MOVEA '0100' *IN(41)
,**
C eval RRN3 = 0
C MOVEA '0010' *IN(51)
C WRITE CTL03
C MOVEA '0100' *IN(51)
,**
C ENDSR
,****************************************************************
,**Load the Field Description Subfile *
,****************************************************************
C $LOAD1 BEGSR
,**
C eval HeaderPtr = (%addr(Data(OffSetHdr + 1)))
C eval WSFILE = FileName
C eval WSLIB = LibName
C eval WSDESC = RecTxtD
C eval WSRCDF = RcdFmtName
C eval WSTYPE = FileType
C eval *IN88 = (FileType <> 'PF')
C eval SpaceStart = 513
,**
C do NumLstEnt
C EXSR $RTVUSAPI
C EXSR $DESC1
C eval WFFLDT = DataType
C eval WFSTART = OutBuffPos
C eval WFDESC2 = FldTextD
,**
C if (WFFLDT = 'P') or (WFFLDT = 'B')
C eval WFLENGTH = Digits
C else
C eval WFLENGTH = FldLength
C endif
,**
C if (WFFLDT <> 'B') and (WFFLDT <> 'D') and
C (WFFLDT <> 'F') and (WFFLDT <> 'G') and
C (WFFLDT <> 'H') and (WFFLDT <> 'M') and
C (WFFLDT <> 'N') and (WFFLDT <> 'P') and
C (WFFLDT <> 'S') and (WFFLDT <> 'Y')
C eval WFDEC = ' '
C else
C eval Decimals = DecPos
C Move Decimals WFDEC
C endif
,**
C eval WFFLDN = FldName
C eval i = 1
C FldName lookup Keys(i) 99
,**
C if (*IN99)
C eval WFKEY = ('K' + Pos(i))
C else
C eval WFKEY = ' '
C endif
,**
C eval *IN50 = (WFKEY <> ' ')
C eval RRN = (RRN + 1)
C WRITE SFL01
C EXSR $DESC2
C eval SpaceStart = (SpaceStart + DataSize)
C enddo
,**
C eval #Fields = RRN
C eval *IN34 = *ON
C eval *IN31 = (RRN > 0)
C eval RECNBR = 1
,**
C ENDSR
,****************************************************************
,**Fill Description 1 *
,****************************************************************
C $DESC1 BEGSR
,**
C eval j = %size(FldTextD)
,**
C dow (j > 0)
,**
C if (%subst(FldTextD:j:1) = ' ') and
C (j <= %size(WFDESC))
C LEAVE
C endif
,**
C eval j = (j - 1)
C enddo
,**
C eval WFDESC = %subst(FldTextD:1:j)
C eval ssStart = (j + 1)
C eval Desc2 = %subst(FldTextD:ssStart)
,**
C ENDSR
,****************************************************************
,**Fill Description 2 *
,****************************************************************
C $DESC2 BEGSR
,**
C if (Desc2 <> ' ')
C eval WFFLDN = ' '
C eval WFKEY = ' '
C eval WFFLDT = ' '
C eval WFSTART = 0
C eval WFLENGTH = 0
C eval WFDEC = ' '
C eval WFDESC = Desc2
C eval WFDESC2 = ' '
C eval RRN = (RRN + 1)
C WRITE SFL01
C endif
,**
C ENDSR
,****************************************************************
,**Load the Database Relations Subfile *
,****************************************************************
C $LOAD2 BEGSR
,**
C do NumLstEnt
C eval DBRPtr = (%addr(Data(OffSetDBR + 1)))
C eval OffSetDBR = (OffSetDBR + EntrySize)
,**
C eval WFDBFILE = DBDFName
C eval WFDBLIB = DBDLName
,**
C select
C when (DBDType = 'D')
C eval WFDBTYPE = 'DATA'
C when (DBDType = 'I')
C eval WFDBTYPE = 'ACCESS PATH'
C when (DBDType = 'O')
C eval WFDBTYPE = 'ACC PATH OWNER'
C when (DBDType = 'V')
C eval WFDBTYPE = 'SQL'
C other
,**
C if (WFDBFILE <> '*NONE')
C eval WFDBTYPE = '???'
C endif
,**
C endsl
,**
C eval *IN66 = (WFDBTYPE <> 'DATA')
C eval RRN2 = (RRN2 + 1)
C WRITE SFL02
C enddo
,**
C eval *IN44 = *ON
C eval *IN41 = (RRN2 > 0)
C eval RECNBR2 = 1
,**
C ENDSR
,****************************************************************
,**Load the Trigger Information *
,****************************************************************
C $LOAD3 BEGSR
,**
C OPEN FFD002PF
C READ FFD002PF 69
,**
C dow (not *IN69)
C eval WFPRGLIB = (%trim(TRTRIG) + '/' +
C %trim(TRTRLB))
,**
C select
C when (TRTRTM = 'B')
C eval WFTRTM = 'BEFORE'
C when (TRTRTM = 'A')
C eval WFTRTM = 'AFTER'
C other
C eval WFTRTM = '??? '
C endsl
,**
C select
C when (TRTREV = 'I')
C eval WFTREV = 'INSERT'
C when (TRTREV = 'D')
C eval WFTREV = 'DELETE'
C when (TRTREV = 'U')
C eval WFTREV = 'UPDATE'
C other
C eval WFTREV = '???'
C endsl
,**
C select
C when (TRTRCN = 'A')
C eval WFTRCN = 'ALWAYS'
C OTHER
C eval WFTRCN = 'CHANGE'
C endsl
,**
C eval RRN3 = (RRN3 + 1)
C WRITE SFL03
C READ FFD002PF 69
C enddo
,**
C CLOSE FFD002PF
,**
C if (RRN3 <= 0)
C eval WFPRGLIB = 'No Triggers'
C eval RRN3 = (RRN3 + 1)
C WRITE SFL03
C endif
,**
C eval #Triggers = RRN3
C eval *IN54 = *ON
C eval *IN51 = (RRN3 > 0)
C eval RECNBR3 = 1
,**
C ENDSR
,****************************************************************
,**Process Subfile 2 *
,****************************************************************
C $PROCES2 BEGSR
,**
C READC SFL02 69
,**
C dow (not *IN69)
,**
C if (WFWOPT = '1')
C eval QCmdCmd = 'LSTFFD FILE(' +
C %trim(WFDBLIB) + '/' +
C %trim(WFDBFILE) + ')'
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
,**
C if (*IN99)
C eval WSMSG = 'Error running LSTFFD command.'
C endif
,**
C endif
,**
C eval WFWOPT = ' '
C UPDATE SFL02
C READC SFL02 69
C enddo
,**
C ENDSR
,**************************************************************
,**Call List Fields API *
,**************************************************************
C $LFLDAPI BEGSR
,**
C CALL 'QUSLFLD'
C PARM SpaceName
C PARM 'FLDL0100' FmtName
C PARM WPQFName
C PARM WPRFName
C PARM WPOverride
C PARM WPError
,**
C ENDSR
,**************************************************************
,**Call Display Database Relations API *
,**************************************************************
C $LDBRAPI BEGSR
,**
C CALL 'QDBLDBR'
C PARM SpaceName
C PARM 'DBRL0100' FmtName
C PARM WPQFName
C PARM WPMember
C PARM WPRFName
C PARM WPError
,**
C endsr
,**************************************************************
,**Create User Space *
,**************************************************************
C $CRTUSAPI BEGSR
,**
C CALL 'QUSCRTUS'
C PARM SpaceName
C PARM SpaceAtr
C PARM SpaceSiz
C PARM SpaceInv
C PARM SpaceAut
C PARM SpaceDes
,**
C ENDSR
,**************************************************************
,**Retrieve Pointer To User Space *
,**************************************************************
C $PTRUSAPI BEGSR
,**
C CALL 'QUSPTRUS'
C PARM SpaceName
C PARM SpacePtr
,**
C ENDSR
,**************************************************************
,**Retrieve User Space Data *
,**************************************************************
C $RTVUSAPI BEGSR
,**
C CALL 'QUSRTVUS'
C PARM SpaceName
C PARM SpaceStart
C PARM DataSize
C PARM List
,**
C ENDSR
,**************************************************************
,**Delete User Space *
,**************************************************************
C $DLTUSAPI BEGSR
,**
C CALL 'QUSDLTUS'
C PARM SpaceName
C PARM WPError
,**
C ENDSR
,***************************************************************
,**Load Array With Key Fields *
,***************************************************************
C $GETKEYS BEGSR
,**
C OPEN FFD001PF
C eval i = 0
C READ FFD001PF 69
,**
C dow (not *IN69)
C eval i = (i + 1)
C eval Keys(i) = APKEYF
C MOVE APKEYN Pos(i)
C READ FFD001PF 69
C enddo
,**
C CLOSE FFD001PF
,**
C if (APUNIQ <> ' ')
C eval WSUNIQ = APUNIQ
C else
C eval WSUNIQ = 'N'
C endif
,**
C if (APBOF <> ' ') or (APBOL <> ' ')
C eval WSBOF = APBOF
C eval WSBOL = APBOL
C eval *IN67 = *ON
C endif
,**
C ENDSR
,***************************************************************
,**INITIALIZATION SUBROUTINE *
,***************************************************************
C *INZSR BEGSR
,**
C *ENTRY PLIST
C PARM WPFile 10
C PARM WPLib 10
C PARM WPRFName 10
c Parm WpPrint 4
,**
C eval WPQFName = (WPFile + WPLib)
C EXSR $GETKEYS
,**
C eval SpaceName = LstSpcName
C exsr $CRTUSAPI
C EXSR $LFLDAPI
C EXSR $PTRUSAPI
C EXSR $INIT
C EXSR $LOAD1
C EXSR $DLTUSAPI
,**
C eval SpaceName = DBRSpcName
C EXSR $CRTUSAPI
C EXSR $LDBRAPI
C EXSR $PTRUSAPI
C EXSR $LOAD2
C EXSR $DLTUSAPI
,**
C if (not *IN88)
C EXSR $LOAD3
C endif
,**
C ENDSR
Art Tostaine, Jr.
CCA, Inc.
Jackson, NJ 08527
-----Original Message-----
From: midrange-l-bounces@xxxxxxxxxxxx
[mailto:midrange-l-bounces@xxxxxxxxxxxx] On Behalf Of Art Tostaine, Jr.
Sent: Tuesday, August 12, 2003 4:34 PM
To: 'Midrange Systems Technical Discussion'
Subject: RE: DSPRCDFMT from News/400?
Mine is much different..........
D List DS
D FldName 10
D DataType 1
D Use 1
D OutBuffPos 9B 0
D InBuffPos 9B 0
D FldLength 9B 0
D Digits 9B 0
D DecPos 9B 0
D FldTextD 50
D EditCode 2
D EditWordL 9B 0
D EditWord 64
D ColHdg1 20
D ColHdg2 20
D ColHdg3 20
D IntFldName 10
D AltFldName 30
D AltFldNL 9B 0
Art Tostaine, Jr.
CCA, Inc.
Jackson, NJ 08527
-----Original Message-----
From: midrange-l-bounces@xxxxxxxxxxxx
[mailto:midrange-l-bounces@xxxxxxxxxxxx] On Behalf Of
MWalter@xxxxxxxxxxxxxxx
Sent: Tuesday, August 12, 2003 3:57 PM
To: Midrange Systems Technical Discussion
Subject: RE: DSPRCDFMT from News/400?
_______________________________________________
This is the Midrange Systems Technical Discussion (MIDRANGE-L) mailing
list
To post a message email: MIDRANGE-L@xxxxxxxxxxxx
To subscribe, unsubscribe, or change list options,
visit: http://lists.midrange.com/mailman/listinfo/midrange-l
or email: MIDRANGE-L-request@xxxxxxxxxxxx
Before posting, please take a moment to review the archives
at http://archive.midrange.com/midrange-l.
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
