You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG015R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG015R4: Display document text - Printout
* Copyright (C) 2000 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:
**********************************************************************************************
* Document helptext
FDBGDFTD1 IF E K DISK INFDS(DOC#DS)
* Document helptext header
FDBGDFTH1 IF E K DISK
* Printout
FDBG015PF O E PRINTER INFDS(PRT#DS)
F USROPN
**********************************************************************************************
* ARRAYS:
**********************************************************************************************
D Str S 1 DIM(79)
D Xtr S 1 DIM(79)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
D PRT#Ds DS
* Define the offset 188 as a 2 digit binary field to get
* the overflow line number
D Ovflin 188 189B 0
* Define the offset 367 as a 2 digit binary field to get
* the current line number
D Curlin 367 368B 0
* User name
D SDS
D R#USER 254 263
* Information Data Structure
D DOC#DS DS
D FileName 83 92
D FileLibNme 10
*
D DS
D Cmd1 80 INZ('OVRPRTF FILE(GSIDDT2-
D 0) USRDTA(A4Document-
D ) SPLFNAME( -
D ) HOLD(*YES) ')
D C#Docd 10 OVERLAY(Cmd1:52)
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
D Atr C CONST(X'212223242526303132- MR2
D 3334353628292C2D3839- MR2
D 3A3B3C3D3E') MR2
D Chk C CONST(X'404040404040404040- MR2
D 40404040404040404040-
D 4040404040') MR2
D Set C CONST(X'222222242626242624- MR2
D 26242624222224262224-
D 2224222624') MR2
D HiLite C CONST(X'22')
D ULine C CONST(X'24')
D HiULin C CONST(X'26')
D Norm C CONST(X'20')
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D #Extra S 4 0
D #X S 3 0
D ChkTxt S 79
D CmdLen S 15 5
D CmdStr S 256
D CurPage S 4 0
D EndRep S 1
D FstPag S 1
D FullDoc S 32
D P#Docd S 10
D P#Titl S 50
D Remain S 3 0
D Requir S 3 0
D Result S 79
D StartB S 1
D StartH S 1
D StartU S 1
D StartPos S 3 0
D TotRcd S 7 0
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P#Docd
C PARM P#Titl
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
* Get company name
C *DTAARA DEFINE DBGCOMP COMPNY
C IN COMPNY
C MOVE P#Docd C#Docd
C MOVE P#Docd R#DOCD
C MOVE P#Titl R#TITL
C EVAL R#DATE = UDATE
C MOVE *off EndRep
C MOVE *on FstPag
C EVAL FullDoc = %TRIM(FileLibNme) + '/' +
C %TRIM(FileName) + ':' + P#Docd
*
C MOVEL(P) Cmd1 CmdStr
C CALL 'QCMDEXC' 90
C PARM CmdStr
C PARM 80 CmdLen
C OPEN DBG015PF
* Get the total number of records in the document (hence pages required)
C P#Docd CHAIN DBGDFTD1 80
B001 C DOW *IN80 = *off
C EVAL TotRcd = TotRcd + 1
C P#Docd READE DBGDFTD1 80
E001 C ENDDO
* At 3 screen pages per print page (3x18 lines), each print is 54 lines
C TotRcd DIV 54 TOTPAG
C MVR #Extra
* Add an extra page if it doesn't fit exactly
B001 C IF #Extra <> 0
C EVAL TOTPAG = TOTPAG + 1 Total pages
E001 C ENDIF
C EVAL CurPage = 1 > MR3 <
* Get the index record for this document
C P#Docd CHAIN DBGDFTH1 80
B001 C IF *IN80 = *off
* Print the report header
* If user specified header/footer required
B002 C IF DFHEAD = 'Y' MR3 >>
* Skip to new page
C WRITE DDUSRHED
* Print the first page header lines (three of them)
C EVAL R#TEXT = DFHTX1
C EXSR SetUsrDfn
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
C EVAL R#TEXT = DFHTX2
C EXSR SetUsrDfn
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
C EVAL R#TEXT = DFHTX3
C EXSR SetUsrDfn
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
* Otherwise print the standard header
X002 C ELSE
C WRITE DDHEADER
E002 C ENDIF << MR3
* Process the document records
C P#Docd CHAIN DBGDFTD1 80
B002 C DOW *IN80 = *off
* Write the detail line
C EVAL Requir = 7 Lines required
C EXSR Ovchck
C MOVE DFTEXT R#TEXT
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
* Get the next line to print
C P#Docd READE DBGDFTD1 80
E002 C ENDDO
* Write the end of report
* If user specified footer required
B002 C IF DFHEAD = 'Y'
* If first page, print the page 1 footer
B003 C IF FstPag = *on
C EVAL R#TEXT = DFFTX1
C EXSR SetUsrDfn > MR3 <
* Otherwise print the final page footer
X003 C ELSE
C MOVE DFFTX3 R#TEXT
C EXSR SetUsrDfn > MR3 <
E003 C ENDIF
C WRITE DDUSREND
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
* Otherwise print the standard footer
X002 C ELSE
C WRITE DDENDREP
E002 C ENDIF
E001 C ENDIF
* EXIT PROGRAM
C EVAL *INLR = *on
C RETURN
**************************************************************************
* OVCHCK: Overflow check - throw new page if no room for next format
**************************************************************************
C Ovchck BEGSR
*
C EVAL Remain = Ovflin - Curlin Lines left on page
* If not enough room to print on current page
B001 C IF Remain <= Requir
* If user specified header/footer required
B002 C IF DFHEAD = 'Y'
* If first page, print the page 1 footer
B003 C IF FstPag = *on
C MOVE DFFTX1 R#TEXT
C MOVE *off FstPag
* Otherwise print the continuation footer
X003 C ELSE
C MOVE DFFTX2 R#TEXT
E003 C ENDIF
C EXSR SetUsrDfn > MR3 <
C WRITE DDUSREND > MR3 <
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
* Header on new page
C EVAL CurPage = CurPage + 1 > MR3 <
C WRITE DDUSRHED
* Print the continuation header lines (three of them)
C MOVE DFHTX4 R#TEXT > MR3 <
C EXSR SetUsrDfn > MR3 <
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
C MOVE DFHTX5 R#TEXT
C EXSR SetUsrDfn > MR3 <
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
C MOVE DFHTX6 R#TEXT
C EXSR SetUsrDfn > MR3 <
C WRITE DDDETAIL
* Are there any formatting instructions in current line?
C Atr:Chk XLATE(P) R#TEXT ChkTxt
* If attribute characters found, format & overlay print lines
B003 C IF ChkTxt <> R#TEXT
C EXSR Attrib
E003 C ENDIF
* Otherwise print the standard header/footer
X002 C ELSE
* Continuation footer on current page
C WRITE DDCONTIN
* Header on new page
C WRITE DDHEADER
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**************************************************************************
* ATTRIB: Process embedded attributes
**************************************************************************
C Attrib BEGSR
* Initialise control flags
C MOVE *off StartH
C MOVE *off StartU
C MOVE *off StartB
C EVAL #X = 1
* Reduce attribute character set used (can't print all those displayed)
C Atr:Set XLATE R#TEXT ChkTxt
C MOVEA ChkTxt Str
* Process the string to create a print line with highlight/underline etc
B001 C 1 DO 79 #X
B002 C SELECT
* Start of hilight (therefore end of other attribute types)
S002 C WHEN Str(#X) = HiLite
C MOVE *on StartH
C MOVE *off StartU
C MOVE *off StartB
C MOVE ' ' Str(#X)
C MOVE ' ' Xtr(#X)
* Start of underline (therefore end of other attribute types)
S002 C WHEN Str(#X) = ULine
C MOVE *on StartU
C MOVE *off StartH
C MOVE *off StartB
C MOVE ' ' Str(#X)
C MOVE ' ' Xtr(#X)
* Start of both highlight & underline (therefore end of other attributes)
S002 C WHEN Str(#X) = HiULin
C MOVE *on StartB
C MOVE *off StartH
C MOVE *off StartU
C MOVE ' ' Str(#X)
C MOVE ' ' Xtr(#X)
* End of highlight/underline
S002 C WHEN Str(#X) = Norm
C MOVE *off StartH
C MOVE *off StartU
C MOVE *off StartB
C MOVE ' ' Str(#X)
C MOVE ' ' Xtr(#X)
* Text within highlight block - leave as it is
S002 C WHEN StartH = *on
C MOVE ' ' Xtr(#X)
* Text within underline block - substitute with underline character
S002 C WHEN StartU = *on
C MOVE ' ' Str(#X)
C MOVE '_' Xtr(#X)
* Text within underline+highlight block - as underline, but set up a
* second attribute print line to be printed
S002 C WHEN StartB = *on
C MOVE '_' Xtr(#X)
* If outside an attribute block, blank out character in print line
S002 C WHEN StartH = *off
C AND StartU = *off
C AND StartB = *off
C MOVE ' ' Str(#X)
C MOVE ' ' Xtr(#X)
E002 C ENDSL
E001 C ENDDO
* If highlight line not empty, print it over the top of the detail line
C MOVEA Str R#TEXT
B001 C IF R#TEXT <> *blanks
C WRITE DDATTRIB
E001 C ENDIF
* If underline line not empty, print it over the top as well
C MOVEA Xtr R#TEXT
B001 C IF R#TEXT <> *blanks
C WRITE DDATTRIB
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* SetUsrDfn: Set user defined header/footer variables
**********************************************************************************************
C SetUsrDfn BEGSR MR3 >>
*
C EVAL Result = R#TEXT
B001 C IF Result <> *blanks
* If any user defind replacement variables found, get with the replacing
B002 C IF %SCAN('.&':Result) > 0
* Replace .&tp with total pages variable
C EVAL StartPos = %SCAN( '.&tp' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 4 ) = *blanks
C EVAL Result =
C %REPLACE( %EDITC ( TOTPAG : 'Z' ) :
C Result : StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&cp' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 4 ) = *blanks
C EVAL Result =
C %REPLACE( %EDITC ( CurPage : 'Z' ) :
C Result : StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&date' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST(Result : StartPos : 6) = *blanks
C EVAL Result =
C %REPLACE( %EDITC ( UDATE : 'Y' ) :
C Result : StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&document' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 10 ) = *blanks
C EVAL Result = %REPLACE( P#Docd : Result :
C StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&title' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 7 ) = *blanks
C EVAL Result = %REPLACE( P#Titl : Result :
C StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&company' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 9 ) = *blanks
C EVAL Result = %REPLACE( COMPNY : Result :
C StartPos )
E003 C ENDIF
*
C EVAL StartPos = %SCAN( '.&fulldoc' : Result )
B003 C IF StartPos > 0
C EVAL %SUBST( Result : StartPos : 9 ) = *blanks
C EVAL Result = %REPLACE( FullDoc : Result :
C StartPos )
E003 C ENDIF
E002 C ENDIF
E001 C ENDIF
*
C EVAL R#TEXT = Result
*
C ENDSR << MR3
**********************************************************************************************
Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 19:11:38 - 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