**********************************************************************************************
      * 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
      **********************************************************************************************
Topic revision: r1 - 26 May 2005 - 19:11:38 - MartinRowe
 
This site is powered by FoswikiCopyright © 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