|
midrange.com
? F* *
? F********************************************************************
? F* *
? F* *
? F* HANOVER WIRE CLOTH *
? F* *
? F********************************************************************
? F* DO NOT COPY OR DISTRIBUTE WITH OUT PERMISSION *
? F********************************************************************
? F* *
? F* PROGRAM: RCD003RG *
? F* PURPOSE: PROGRAM TO PROCESS DSPRCDFMT *
? F* AUTHOR: MARK WALTER *
? F* DATE: 01/15/96 *
? F* *
? F********************************************************************
? F* *** MODIFICATION LOG *** *
? F* NAME/CO. DATE DESCRIPTION *
? F* -------------------- -------- ------------------------------- *
? F* *
? F********************************************************************
FRCD003PR O E PRINTER USROPN
FRCD003DF CF E WORKSTN USROPN
F SFILE(DSPDTL:SRN)
D LN S 1 DIM(9)
D KY S 10 DIM(120)
D SQ S 1 DIM(120)
D FN S 10 DIM(2000)
D TYP S 1 DIM(14) CTDATA PERRCD(1)
D DSC S 7 DIM(14) ALT(TYP)
D RCVVAR DS 7736
D NBRKYS 37 38B 0
D OFFSET 53 56B 0
D DS
D USRSPC 1 20 INZ('RCD003US QTEMP ')
D STRPOS 21 24B 0
D STRLEN 25 28B 0
D RCVLEN 29 32B 0
D ERRCOD DS
D BYTPRV 1 4B 0 INZ(96)
D BYTAVA 5 8B 0
D ERRID 9 15
D ERRDTA 17 96
D GENDS DS
D SIZHDR 65 68B 0
D OFFHDR 117 120B 0
D OFFLST 125 128B 0
D NUMLST 133 136B 0
D SIZENT 137 140B 0
D HEADER DS
D HDFILE 1 10
D HDLIB 11 20
D HDTYPE 21 30
D HDRFMT 31 40
D RCDLEN 41 44B 0
D LIST DS
D DTFLD 1 10
D DTATYP 11 11
D FLDLEN 21 24B 0
D DIGITS 25 28B 0
D DECPOS 29 32B 0
D DTTEXT 33 74
D VARLEN 268 268
? C*
? C* GET THE PARAMETERS
? C*
C *ENTRY PLIST
C PARM FILE 20
C PARM RCDFMT 10
C PARM OUTPUT 6
C PARM TEXT 50
C PARM MSGID 7
C PARM MSGDTA 80
? C*
C CLEAR FN
? C*
? C* OPEN THE OUTPUT FILES
? C*
? C OUTPUT IFEQ '*PRINT'
C OPEN RCD003PR
? C ELSE
C OPEN RCD003DF
? C ENDIF
? C*
? C* CALL AN API TO RETRIEVE THE FILE DESCRIPTION DATA
? C*
C CALL 'QDBRTVFD'
C PARM RCVVAR
C PARM 7736 RCVLEN
C PARM RTNFIL 20
C PARM 'FILD0300' FMTNAM 8
C PARM FILE
C PARM RCDFMT
C PARM '1' OVRRID 1
C PARM '*LCL' SYSTEM 10
C PARM '*INT' FMTTYP 10
C PARM ERRCOD
? C*
? C BYTAVA IFEQ 0
C OFFSET ADD 11 X 4 0
? C DO NBRKYS
C ADD 1 Y 4 0
C 10 SUBST RCVVAR:X KY(Y)
C ADD 18 X
C 1 SUBST RCVVAR:X SQ(Y)
C ADD 46 X
? C ENDDO
? C ENDIF
? C*
? C* CALL AN API TO RETRIEVE THE FILE FIELD DESCRIPTIONS
? C*
C CALL 'QUSLFLD'
C PARM USRSPC
C PARM 'FLDL0100' OUTFMT 8
C PARM FILE
C PARM RCDFMT
C PARM '1' OVRRID
C PARM ERRCOD
? C*
? C BYTAVA IFGT 0
C MOVEL ERRID MSGID
C MOVEL ERRDTA MSGDTA
? C ELSE
C Z-ADD 1 STRPOS
C Z-ADD 140 STRLEN
? C ENDIF
? C*
? C* RETRIEVE THE USER SPACE ALLOCATED IN THE CALLING CL
? C*
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM GENDS
? C*
C OFFHDR ADD 1 STRPOS
C Z-ADD SIZHDR STRLEN
? C*
? C* RETRIEVE THE USER SPACE ALLOCATED IN THE CALLING CL
? C*
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM HEADER
? C*
C Z-ADD NUMLST HDFLDS
C Z-ADD RCDLEN HDRLEN
C MOVEL TEXT HDTEXT
? C*
? C* WRITE THE PRINT HEADING
? C*
? C OUTPUT IFEQ '*PRINT'
C WRITE PRTHDR
C Z-ADD 9 LINCNT
? C ENDIF
? C*
? C*
? C*
C OFFLST ADD 1 STRPOS
C Z-ADD SIZENT STRLEN
? C*
? C DO NUMLST
? C*
? C* RETRIEVE THE USER SPACE
? C*
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM LIST
? C*
C MOVE *BLANKS DTYPE
C Z-ADD 1 X
C DTATYP LOOKUP TYP(X)
99
? C *IN99 IFEQ *ON
C MOVEL DSC(X) DTYPE
? C ENDIF
? C*
C Z-ADD *ZEROS DTKEY
C MOVE *BLANKS DTSEQ
C Z-ADD 1 X
C DTFLD LOOKUP KY(X)
99
? C *IN99 IFEQ *ON
C Z-ADD X DTKEY
C TESTB '0' SQ(X)
99
? C *IN99 IFEQ *ON
C MOVE 'D' DTSEQ
? C ENDIF
? C ENDIF
? C*
C MOVEA *BLANKS LN
? C DIGITS IFNE 0
C MOVE DIGITS SIZE 5
C MOVEA SIZE LN(1)
C MOVE ',' LN(6)
C MOVE DECPOS DEC 2
? C DECPOS IFLT 10
C MOVE DEC LN(7)
? C ELSE
C MOVEA DEC LN(7)
? C ENDIF
? C ELSE
? C VARLEN IFEQ '1'
C SUB 2 FLDLEN
C MOVE 'V' LN(9)
? C ENDIF
C MOVE FLDLEN SIZE
C MOVEA SIZE LN(1)
? C ENDIF
C Z-ADD 1 X
? C LN(X) DOWEQ '0'
? C X ANDLT 9
C MOVE *BLANKS LN(X)
C ADD 1 X
? C ENDDO
C MOVEA LN DTSIZE
? C*
? C* ROUTINE TO PRINT THE OUTPUT
? C*
? C OUTPUT IFEQ '*PRINT'
? C*
C ADD 1 LINCNT 2 0
? C LINCNT IFEQ 59
C WRITE PRTHDR
C Z-ADD 9 LINCNT
? C ENDIF
? C*
C WRITE PRTDTL
? C ELSE
C ADD 1 SRN 4 0
C MOVEL DTFLD FN(SRN)
C WRITE DSPDTL
? C ENDIF
? C*
C ADD SIZENT STRPOS
? C ENDDO
? C*
? C OUTPUT IFEQ '*PRINT'
C WRITE PRTFTR
? C ELSE
? C*
C Z-ADD 1 SFLRRN
C Z-ADD SRN MAXRRN 4 0
? C*
? C* ROUTINE TO WRITE THE SCREEN OUTPUT
? C*
? C *IN03 DOUEQ *ON
C *IN12 OREQ *ON
? C*
? C* N31N16 CLEARSCFIND
? *
C WRITE DSPFTR
C EXFMT DSPHDR
? C*
C SETOFF 3135
? C* EXSR @CLRRI
? C*
? C* CHECK COMMAND KEYS
? C*
? C SELECT
? C*
? C* EXIT
? C*
? C* *IN03 WHENEQ *OFF
? C* *IN12 ANDEQ *OFF
? C* *IN16 ANDEQ *OFF
? C* *IN17 ANDEQ *OFF
? C* *IN18 ANDEQ *OFF
? C* *IN19 ANDEQ *OFF
? C* MOVE *ON *IN03
? C WHEN *in03
C LEAVE
? C*
? C* FIND RECORD
? C*
? C *IN16 WHENEQ *ON
? C IF scfind <> *blanks
? C EXSR @FIND
? C ELSE
C ITER
? C ENDIF
? C*
? C* GO TO TOP
? C*
? C *IN17 WHENEQ *ON
C Z-ADD 1 SFLRRN
? C*
? C* GO TO BOTTOM
? C*
? C *IN18 WHENEQ *ON
C Z-ADD MAXRRN SFLRRN
? C*
? C* PRINT
? C*
? C *IN19 WHENEQ *ON
? C EXSR @PRINT
C Z-ADD 1 SFLRRN
? *
C OTHER
? C IF scfind = *blanks
C EVAL *inlr = *on
C RETURN
? C ELSE
? C EXSR @find
? C ENDIF
? C ENDSL
? *
? C*
? C ENDDO
? C*
? C ENDIF
? C*
C MOVE *ON *INLR
? C*
? C* PRINT RECORD FORMAT LISTING FROM SCREEN
? C*
? C @PRINT BEGSR
C OPEN RCD003PR
C WRITE PRTHDR
? C*
C Z-ADD 1 RRNKEY 4 0
C Z-ADD 9 LINCNT
? C*
? C *IN45 DOWEQ *OFF
C RRNKEY CHAIN DSPDTL 45
? C *IN45 IFEQ *OFF
? C*
C WRITE PRTDTL
? C*
C ADD 1 LINCNT
? C*
? C LINCNT IFEQ 59
C WRITE PRTHDR
C Z-ADD 9 LINCNT
? C ENDIF
? C*
C ADD 1 RRNKEY
? C*
? C ENDIF
? C ENDDO
? C*
C WRITE PRTFTR
? C*
C CLOSE RCD003PR
? C ENDSR
? C*
? C* FIND FIELD SUBROUTINE
? C*
? C @FIND BEGSR
? C EXSR @CLRRI
C MOVEA '000' *IN(32)
? C *IN39 IFEQ *ON
C Z-ADD 1 X 4 0
? C ELSE
C ADD 1 X
? C ENDIF
? C*
C ' ':1 SCAN SCFIND:1 RMNDR 2 0
C RMNDR SUB 1 S 2 0
? C*
? C X DO MAXRRN Y 4 0
C SCFIND:S SCAN FN(Y):1 34
32
C 32
COR 34 LEAVE
? C ENDDO
? C*
C Z-ADD Y X
? C*
? C *IN32 IFEQ *ON
C Z-ADD X SFLRRN
C X CHAIN DSPDTL 33
C N33 UPDATE DSPDTL
C Z-ADD X RRNKEY 4 0
? C ELSE
C MOVE *ON *IN31
? C ENDIF
? C*
? C ENDSR
? C*
? C* CLEAR THE REVERSE IMAGE ATTRIBUTE FROM FOUND FIELDS
? C*
? C @CLRRI BEGSR
? C RRNKEY IFNE *ZERO
C RRNKEY CHAIN DSPDTL 36
C N36 MOVE *OFF *IN32
C N36 UPDATE DSPDTL
? C ENDIF
? C ENDSR
**
PPacked
SZoned
BBinary
FFloat
AChar
LDate
TTime
ZTMStmp
HHex
JDBCS-J
EDBCS-E
ODBCS-O
GDBCS-G
Thanks,
Mark
Mark D. Walter
Senior Programmer/Analyst
CCX, Inc.
mwalter@xxxxxxxxxx
http://www.ccxinc.com
"Art Tostaine, Jr."
<artjr@xxxxxxxxxxx> To: "'Midrange Systems
Technical Discussion'" <midrange-l@xxxxxxxxxxxx>
Sent by: cc:
midrange-l-bounces@xx Subject: RE: DSPRCDFMT
from News/400?
drange.com
08/12/2003 02:36 PM
Please respond to
Midrange Systems
Technical Discussion
Care to post the source? We error out here on second to last line,
"receiver value to small to hold result"
****************************************************************
**Load the Field Description Subfile *
****************************************************************
C $LOAD1 BEGSR
**
C eval HeaderPtr = (%addr(Data(OffSetHdr +
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
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 2:20 PM
To: Midrange Systems Technical Discussion
Subject: Re: DSPRCDFMT from News/400?
We use it fine with V5R2.
Thanks,
Mark
Mark D. Walter
Senior Programmer/Analyst
CCX, Inc.
mwalter@xxxxxxxxxx
http://www.ccxinc.com
"Art Tostaine, Jr."
<artjr@xxxxxxxxxxx> To: "'Midrange
Systems Technical Discussion'" <midrange-l@xxxxxxxxxxxx>
Sent by: cc:
midrange-l-bounces@xx Subject: DSPRCDFMT
from News/400?
drange.com
08/12/2003 02:07 PM
Please respond to
Midrange Systems
Technical Discussion
This was utility that displayed the record format of a database file.
We've been using a version of this forever.
It stopped working with V5R2. Does anyone know if the fix was published
anywhere?
WRKDBF does the job with F14, but it doesn't search, etc.
Art Tostaine, Jr.
CCA, Inc.
Jackson, NJ 08527
_______________________________________________
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.
_______________________________________________
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.
_______________________________________________
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.
