**************************************************************************
      * DBG005R4: Work with On-line Documents
      * 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
      **********************************************************************************************
      * Indicator usage
      **********************************************************************************************
      * 01: F1=Help
      * 03: F3=Exit
      * 08: F8=Edit header/footer
      * 12: F12=Previous
      * 27: ROLLUP
      * 28: ROLLDOWN
      * 35: SFLEND
      * 36: SFLDSP
      * 50: DISPLAY mode on - disable all options except view & print
      * 51: DSPATR(PR) on screen titles (selective by 'lock' state)
      * 52: DSPATR(PR) on screen titles (all/none ('locked' documents excluded))
      * 80 - 84: File I/O
      * 90: General error trap
      **********************************************************************************************
     H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
      **********************************************************************************************
      * FILES:
      **********************************************************************************************
      *  Document index (title, headers & footers, etc)
     FDBGDFTH1  UF A E           K DISK
      *  Document text
     FDBGDFTD1  UF A E           K DISK
      *  Workfile for keyword limited documents
     FDBGOLD0W  UF A E           K DISK
      *  Keyword file by document & keyword
     FDBGDFTK1  UF   E           K DISK
      *  Keyword file by keyword & document
     FDBGDFTK2  IF   E           K DISK
      *  Screen display
     FDBG005DF  CF   E             WORKSTN
     F                                     SFILE(SFL:RRN)
      **********************************************************************************************
      * DATA STRUCTURES:
      **********************************************************************************************
      *  PROGRAM NAME
     D                SDS
     D PGM                           10
     D #@User                254    263
      *
     D                 DS
     D Ovrdb1                        60    INZ('OVRDBF FILE(DBGDFTD1-
     D                                     ) TOFILE(DBGDFTD1) S-
     D                                     ECURE(*YES)         ')
      *
     D                 DS
     D Ovrdb2                        60    INZ('OVRDBF FILE(DBGDFTH1-
     D                                     ) TOFILE(DBGDFTH1) S-
     D                                     ECURE(*YES)         ')
      *
     D                 DS
     D Ovrdb3                        60    INZ('OVRDBF FILE(DBGDFTK1-
     D                                     ) TOFILE(DBGDFTK1) S-
     D                                     ECURE(*YES)         ')
      *
     D                 DS
     D Dltovr                        60    INZ('DLTOVR FILE(DBGDFTD1-
     D                                      DBGDFTH1 DBGDFTK1) -
     D                                     LVL(*)              ')
      *
     D                 DS

     D Clrpfm                        40    INZ('CLRPFM FILE(QTEMP/DB-
     D                                     GOLD0W  )           ')
      **********************************************************************************************
      * CONSTANTS:
      **********************************************************************************************
     D Symb            C                   CONST('{}[]<>')
     D Atrb            C                   CONST(X'222024202620')
     D Text01          C                   CONST('Subsetted list')
      **********************************************************************************************
      * WORK FIELDS:
      **********************************************************************************************
     D #Docd           S             10
     D #Errid          S              7
     D #1              S              3  0
     D #2              S              3  0
     D #3              S              3  0
     D Cmdlen          S             15  5
     D Cmdstr          S            256
     D Docfil          S             10
     D Doclib          S             10
     D Dtalen          S              5  0
     D K#Docd          S             10
     D K#Word          S             10
     D LDA             S            512
     D Lockok          S              1
     D Msgdta          S            512
     D Msgfil          S             10
     D Msgid           S              7
     D Msglib          S             10
     D Msgtyp          S             10
     D P#Docd          S             10
     D P#Edit          S              1
     D P#Pgm           S             10
     D P#Titl          S             50
     D Pagful          S              3  0
     D Pgmmod          S              4
     D Pgmq            S             10
     D Pgmstk          S              5  0
     D Rcdrqd          S              1
     D Reload          S              1
     D Rrn             S              4  0
     D Strpos          S              3  0
     D Subset          S              1
      **********************************************************************************************
      * ENTRY PARAMETERS:
      **********************************************************************************************
     C     *ENTRY        PLIST
     C                   PARM                    Doclib
     C                   PARM                    Docfil
     C                   PARM                    Pgmmod
      **********************************************************************************************
      * KEY LISTS:
      **********************************************************************************************
     C     Wrdky1        KLIST
     C                   KFLD                    K#Docd
     C                   KFLD                    K#Word
      *
     C     Wrdky2        KLIST
     C                   KFLD                    KWORD1
     C                   KFLD                    #Docd
      **********************************************************************************************
      * MAINLINE:
      **********************************************************************************************
      *  Get company name
     C     *DTAARA       DEFINE    DBGCOMP       COMPNY
     C                   IN        COMPNY
     C     *DTAARA       DEFINE    *LDA          LDA
     C                   MOVE      *off          Subset
      *  Display only if not in edit mode
B001 C                   IF        Pgmmod <> '*EDT'
     C                   EVAL      *IN50 = *on
E001 C                   ENDIF
      *  Show the document & index files being worked with
     C     Doclib        CAT(P)    '/':0         #SDFIL
     C                   CAT       Docfil:0      #SDFIL
     C                   EVAL      SUBTXT = *blanks
      *  Build subfile and display
     C     *loval        SETLL     DBGDFTH1
     C                   EXSR      PAGUP
      *  Repeat display until exit requested
B001 C                   DOW       *IN03 = *off
      *  Don't display subfile if empty
     C                   EVAL      *IN36 = Rrn > 0
     C                   WRITE     FOOTER1
     C                   WRITE     MSFLC                                        MSG SUBFILE
     C                   EXFMT     SFLCTL                                       DISPLAY SCREEN
      *  Remove messages from queue after display
     C                   CALL      'DBG045CL'                           90
     C                   MOVE      *off          Reload
      *  Process response
B002 C                   SELECT
      *  F1/Help pressed
S002 C                   WHEN      *IN01 = *on
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb1        Cmdstr
     C                   PARM      60            Cmdlen
      *
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb2        Cmdstr
     C                   PARM      60            Cmdlen
      *
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb3        Cmdstr
     C                   PARM      60            Cmdlen
      *  Call the Helptext Viewer
     C                   CALL      'DBG010R4'                           90      Trap errors
     C                   PARM      PGM           P#Pgm
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Dltovr        Cmdstr
     C                   PARM      60            Cmdlen
      *  F3=Exit or F12=Previous
S002 C                   WHEN      *IN03 = *on
     C                             OR *IN12 = *on
     C                   LEAVE
      *  F17=Subset
S002 C                   WHEN      *IN17 = *on
     C                   EXSR      KEYWRD
      *  RollUp
S002 C                   WHEN      *IN27 = *on
     C                   EXSR      PAGUP
      *  RollDown
S002 C                   WHEN      *IN28 = *on
     C                   EXSR      PAGDWN
      *  Reposition list
S002 C                   WHEN      #PDOCD <> *blanks
      *  Use workfile if subsetted by keyword(s)
B003 C                   IF        Subset = *on
     C     #PDOCD        SETLL     DBGOLD0W                           35
      *  Otherwise use the full header
X003 C                   ELSE
     C     #PDOCD        SETLL     DBGDFTH1                           35
E003 C                   ENDIF
     C                   EVAL      #PDOCD = *blanks
     C                   EXSR      PAGUP
      *  Create a new document
S002 C                   WHEN      #CTL01 = '1'
     C     NEWDOC        SETLL     DBGDFTH1                               81
B003 C                   SELECT
      *  Error if no document specified
S003 C                   WHEN      NEWDOC = *blanks
     C                   MOVE      'GSM0305'     Msgid
     C                   EVAL      Msgdta = *blanks
     C                   EVAL      Dtalen = 0
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
      *  Error if document already exists
S003 C                   WHEN      *IN81 = *on
     C                   MOVE      'GSM0304'     Msgid
     C                   MOVEL     NEWDOC        Msgdta
     C                   EVAL      Dtalen = 10
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
      *  Otherwise create a new index record, and run the edit program
S003 C                   OTHER
     C                   MOVE      NEWDOC        DFDOCD
     C                   EVAL      DFDOCH = *blanks
     C                   EVAL      NEWDOC = *blanks
     C                   EVAL      DFCDTE = *DATE
     C                   EVAL      DFADTE = *DATE
     C                   MOVE      #@User        DFCUSR
     C                   MOVE      #@User        DFAUSR
     C                   MOVE      'T'           DFLOCK
     C                   MOVE      'N'           DFHEAD
     C                   WRITE     DB1DFTH
     C                   MOVE      DFDOCD        #Docd
     C                   CALL      'DBG020R4'                           90
     C                   PARM      #Docd         P#Docd
     C                   PARM      *blanks       P#Titl
     C                   MOVE      *on           Reload
E003 C                   ENDSL
     C                   EVAL      #CTL01 = *blanks
      *  Process subfile requests (if subfile not empty)
S002 C                   OTHER
B003 C                   IF        Rrn <> 0
     C                   READC     SFL                                    80
      *  Process changed records
B004 C                   DOW       *IN80 = *off
B005 C                   SELECT
      *  2=Edit
S005 C                   WHEN      #SEL1 = '2'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Option only available in Edit mode
B006 C                   IF        Pgmmod = '*EDT'
      *  If record free for editing
B007 C                   IF        #SLOCK = 'F'
      *  Set the lock on the index
     C                   MOVE      #SDOCD        K#Docd
     C     K#Docd        CHAIN     DBGDFTH1                           81
B008 C                   IF        *IN81 = *off
     C                   MOVE      'T'           DFLOCK
     C                   UPDATE    DB1DFTH
E008 C                   ENDIF
      *  Run the edit program
     C                   CALL      'DBG020R4'                           90
     C                   PARM      #SDOCD        P#Docd
     C                   PARM      #SDOCH        P#Titl
      *  Flag to reload screen (show new change date if document amended)
     C                   MOVE      *on           Reload
      *  Otherwise document is locked & unlocked first (either someone else is
      *  editing it, or it has been permanently locked by the author.
X007 C                   ELSE
     C                   MOVE      'GSM0306'     Msgid
     C                   MOVEL     #SDOCD        Msgdta
     C                   EVAL      Dtalen = 10
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
E007 C                   ENDIF
E006 C                   ENDIF
      *  3=Copy
S005 C                   WHEN      #SEL1 = '3'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Option only available in Edit mode
B006 C                   IF        Pgmmod = '*EDT'
      *  Request 'Copy to' name
     C                   MOVE      #SDOCD        CPYDOC
     C                   EXFMT     WINDOW1
      *  If continuing with request
B007 C                   IF        *IN12 = *off
     C     CPYDOC        SETLL     DBGDFTH1                               81
      *  Error if document already exists
B008 C                   IF        *IN81 = *on
     C                   MOVE      'GSM0304'     Msgid
     C                   MOVEL     CPYDOC        Msgdta
     C                   EVAL      Dtalen = 10
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
      *  Otherwise loop through all records for the original, creating copies
      *  with the new name
X008 C                   ELSE
     C                   MOVE      #SDOCD        K#Docd
     C     K#Docd        CHAIN(N)  DBGDFTD1                           81
B009 C                   DOW       *IN81 = *off
     C                   MOVE      CPYDOC        DFDOCD
     C                   WRITE     DB1DFT0
     C     K#Docd        READE(N)  DBGDFTD1                               81
E009 C                   ENDDO
      *  Copy the index entry to the new name
     C     K#Docd        CHAIN(N)  DBGDFTH1                           81
B009 C                   IF        *IN81 = *off
     C                   MOVE      CPYDOC        DFDOCD
     C                   EVAL      DFCDTE = *DATE
     C                   EVAL      DFADTE = *DATE
     C                   MOVE      #@User        DFCUSR
     C                   MOVE      #@User        DFAUSR
     C                   MOVE      'F'           DFLOCK
     C                   WRITE     DB1DFTH
E009 C                   ENDIF
      *  Refresh screen from point of new document
     C                   EVAL      CPYDOC = *blanks
     C                   MOVE      DFDOCD        #Docd
     C                   MOVE      *on           Reload
E008 C                   ENDIF
E007 C                   ENDIF
E006 C                   ENDIF
      *  4=Delete
S005 C                   WHEN      #SEL1 = '4'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Option only available in Edit mode
B006 C                   IF        Pgmmod = '*EDT'
      *  If record free for deletion
B007 C                   IF        #SLOCK = 'F'
      *  Request confirmation
     C                   MOVE      'Y'           #SDLTF
     C                   EXFMT     WINDOW2
      *  If confirmed
B008 C                   IF        *IN12 = *off
     C                             AND #SDLTF = 'Y'
      *  Delete document record(s)
     C                   MOVE      #SDOCD        K#Docd
B009 C                   DOU       *IN81 = *on
     C     K#Docd        DELETE    DB1DFT0                            81
E009 C                   ENDDO
      *  Delete document keyword record(s)
     C                   MOVE      #SDOCD        K#Docd
B009 C                   DOU       *IN81 = *on
     C     K#Docd        DELETE    DB1DFTK1                           81
E009 C                   ENDDO
      *  Delete index record
     C     K#Docd        DELETE    DB1DFTH                            81
      *  Delete workfile record (if there is one)
B009 C                   IF        Subset = *on
     C     K#Docd        DELETE    DB1OLDWF                           81
E009 C                   ENDIF
      *  Reload screen
     C                   MOVE      *on           Reload
E008 C                   ENDIF
      *  Otherwise document is locked & must be unlocked before deleting
X007 C                   ELSE
     C                   MOVE      'GSM0306'     Msgid
     C                   MOVEL     #SDOCD        Msgdta
     C                   EVAL      Dtalen = 10
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
E007 C                   ENDIF
E006 C                   ENDIF
      *  5=Display
S005 C                   WHEN      #SEL1 = '5'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Run the display program
     C                   CALL      'DBG030R4'                           90
     C                   PARM      #SDOCD        P#Docd
     C                   PARM      #SDOCH        P#Titl
     C                   PARM      *off          P#Edit
      *  6=Print
S005 C                   WHEN      #SEL1 = '6'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Run the print program
     C                   CALL      'DBG015R4'                           90
     C                   PARM      #SDOCD        P#Docd
     C                   PARM      #SDOCH        P#Titl
      *  Inform user that report has been printed
     C                   MOVE      'GSM0301'     Msgid
     C     P#Docd        CAT(P)    P#Titl        Msgdta
     C                   EVAL      Dtalen = 60
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
      *  7=Rename
S005 C                   WHEN      #SEL1 = '7'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
      *  Option only available in Edit mode
B006 C                   IF        Pgmmod = '*EDT'
      *  Request the 'Rename to' name
     C                   MOVE      #SDOCD        RNMDOC
     C                   EXFMT     WINDOW3
      *  If continuing
B007 C                   IF        *IN12 = *off
     C     RNMDOC        SETLL     DBGDFTH1                               81
      *  Error if document already exists
B008 C                   IF        *IN81 = *on
     C                   MOVE      'GSM0304'     Msgid
     C                   MOVEL     RNMDOC        Msgdta
     C                   EVAL      Dtalen = 10
     C                   EVAL      Pgmstk = 0
     C                   EXSR      SNDMSG
      *  Otherwise loop through all records for the original, & change the name
X008 C                   ELSE
     C                   MOVE      #SDOCD        K#Docd
     C     K#Docd        CHAIN     DBGDFTD1                           81
B009 C                   DOW       *IN81 = *off
     C                   MOVE      RNMDOC        DFDOCD
     C                   UPDATE    DB1DFT0
     C     K#Docd        READE     DBGDFTD1                               81
E009 C                   ENDDO
      *  Update the index with the change of name
     C     K#Docd        CHAIN     DBGDFTH1                           81
B009 C                   IF        *IN81 = *off
     C                   MOVE      RNMDOC        DFDOCD
     C                   EVAL      DFADTE = *DATE
     C                   MOVE      #@User        DFAUSR
     C                   UPDATE    DB1DFTH
E009 C                   ENDIF
      *  Set screen for reload at the new name
     C                   EVAL      RNMDOC = *blanks
     C                   MOVE      DFDOCD        #Docd
     C                   MOVE      *on           Reload
E008 C                   ENDIF
E007 C                   ENDIF
E006 C                   ENDIF
      *  8=Details
S005 C                   WHEN      #SEL1 = '8'
     C                   EVAL      #SEL1 = *blanks
     C                   UPDATE    SFL
     C                   EXSR      DETAIL
E005 C                   ENDSL
      *  Read next changed record in subfile
     C                   READC     SFL                                    80
E004 C                   ENDDO
E003 C                   ENDIF
E002 C                   ENDSL
      *  Reload screen if required
B002 C                   IF        Reload = *on
B003 C                   IF        Subset = *on
     C     #Docd         SETLL     DBGOLD0W                           35
X003 C                   ELSE
     C     #Docd         SETLL     DBGDFTH1                           35
E003 C                   ENDIF
     C                   EXSR      PAGUP
     C                   MOVE      *off          Reload
E002 C                   ENDIF
      *  Loop back to screen display if not F3
E001 C                   ENDDO
      *  Exit program
     C                   EVAL      *INLR = *on
     C                   RETURN
      **********************************************************************************************
      * PAGUP: Display next page
      **********************************************************************************************
     C     PAGUP         BEGSR
      *  If not end of file
B001 C                   IF        *IN35 = *off
      *  Clear the subfile
     C                   EVAL      Rrn = 0
     C                   EVAL      Pagful = 0
     C                   EVAL      *IN36 = *off
     C                   WRITE     SFLCTL
      *  Load up a page of records
B002 C                   DO        16
      *  If F17=Subset in use, restrict document to those containing keyword(s)
B003 C                   IF        Subset = *on
     C                   READ(N)   DBGOLD0W                               82
      *  Get the matching document header
B004 C                   IF        *IN82 = *off
     C     DFDOCD        CHAIN(N)  DBGDFTH1                           82
E004 C                   ENDIF
      *  Otherwise process the full index file
X003 C                   ELSE
     C                   READ(N)   DBGDFTH1                               82
E003 C                   ENDIF
      *  If index record found, write to subfile
B003 C                   IF        *IN82 = *off
     C                   EVAL      Rrn = Rrn + 1
     C                   MOVE      DFDOCD        #SDOCD
     C                   MOVE      DFDOCH        #SDOCH
     C                   EVAL      #SADTE = DFADTE
     C                   EVAL      #SCDTE = DFCDTE
     C                   MOVE      DFCUSR        #SCUSR
     C                   MOVE      DFAUSR        #SAUSR
     C                   MOVE      DFLOCK        #SLOCK
     C                   MOVE      DFHEAD        #SHEAD
     C                   MOVE      DFHTX1        #SHTX1
     C                   MOVE      DFHTX2        #SHTX2
     C                   MOVE      DFHTX3        #SHTX3
     C                   MOVE      DFHTX4        #SHTX4
     C                   MOVE      DFHTX5        #SHTX5
     C                   MOVE      DFHTX6        #SHTX6
     C                   MOVE      DFFTX1        #SFTX1
     C                   MOVE      DFFTX2        #SFTX2
     C                   MOVE      DFFTX3        #SFTX3
     C                   MOVE      DFADD1        #SADD1
     C                   MOVE      DFADD2        #SADD2
     C                   MOVE      DFADD3        #SADD3
     C                   WRITE     SFL
      *  Store key of first subfile record for RollDown requests
B004 C                   IF        Rrn = 1
     C                   MOVE      DFDOCD        #Docd
E004 C                   ENDIF
      *  Otherwise no (more) records found, so set on SFLEND
X003 C                   ELSE
     C                   EVAL      *IN35 = *on
     C                   LEAVE
E003 C                   ENDIF
E002 C                   ENDDO
      *  Look ahead to see if last record read was last on file: SFLEND if so
B002 C                   IF        Subset = *on
      *  Use workfile if processing subset request
B003 C                   IF        *IN35 = *off
     C     DFDOCD        SETGT     DBGOLD0W                           35
E003 C                   ENDIF
      *  Otherwise use full file
X002 C                   ELSE
B003 C                   IF        *IN35 = *off
     C     DFDOCD        SETGT     DBGDFTH1                           35
E003 C                   ENDIF
E002 C                   ENDIF
E001 C                   ENDIF
      *
     C                   ENDSR
      **********************************************************************************************
      * PAGDWN: Display previous page
      **********************************************************************************************
     C     PAGDWN        BEGSR
      *  Set off SFLEND
     C                   EVAL      *IN35 = *off
     C                   EVAL      Pagful = 0
      *  Position file pointer to first record in subfile
B001 C                   IF        Subset = *on
     C     #Docd         SETLL     DBGOLD0W
X001 C                   ELSE
     C     #Docd         SETLL     DBGDFTH1
E001 C                   ENDIF
      *  Set pointer key to first record in case already at beginning
     C                   MOVE      #Docd         DFDOCD
      *  Read back a page + one record to reposition file at correct point
B001 C                   DO        17
B002 C                   IF        Subset = *on
     C                   READP(N)  DBGOLD0W                               82
B003 C                   IF        *IN82 = *off
     C     DFDOCD        CHAIN(N)  DBGDFTH1                           82
E003 C                   ENDIF
X002 C                   ELSE
     C                   READP(N)  DBGDFTH1                               82
E002 C                   ENDIF
      *  If no earlier records, this one is the first, so leave now
B002 C                   IF        *IN82 = *on
B003 C                   IF        Subset = *on
     C     DFDOCD        SETLL     DBGOLD0W
X003 C                   ELSE
     C     DFDOCD        SETLL     DBGDFTH1
     C                   LEAVE
E003 C                   ENDIF
E002 C                   ENDIF
E001 C                   ENDDO
      *  File is set up to one page back, so reload screen from that point
     C                   EXSR      PAGUP
      *
     C                   ENDSR
      **********************************************************************************************
      * DETAIL: Display/amend document details
      **********************************************************************************************
     C     DETAIL        BEGSR
      *  Display the details screen
     C                   MOVE      #SDOCH        #WDOCH
     C                   MOVE      #SHEAD        #WHEAD
      *  If document free for changes, and in edit mode
B001 C                   IF        #SLOCK = 'F'
     C                             AND Pgmmod = '*EDT'
     C     #SDOCD        CHAIN     DBGDFTH1                           81
      *  Put a temporary lock on the document
B002 C                   IF        *IN81 = *off
     C                   MOVE      'T'           DFLOCK
     C                   UPDATE    DB1DFTH
     C                   MOVE      *on           Lockok
     C                   EVAL      *IN51 = *off
E002 C                   ENDIF
      *  Otherwise show all fields as output only
X001 C                   ELSE
     C                   MOVE      *off          Lockok
     C                   EVAL      *IN51 = *on
E001 C                   ENDIF
      *
B001 C                   DOW       *IN03 = *off
     C                   WRITE     MSFLC
     C                   WRITE     FOOTER2
     C                   EXFMT     SCREEN1
B002 C                   SELECT
      *  F1/Help pressed
S002 C                   WHEN      *IN01 = *on
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb1        Cmdstr
     C                   PARM      60            Cmdlen
      *
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb2        Cmdstr
     C                   PARM      60            Cmdlen
      *  Call the Helptext Viewer
     C                   CALL      'DBG010R4'                           90      Trap errors
     C                   PARM      PGM           P#Pgm
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Dltovr        Cmdstr
     C                   PARM      40            Cmdlen
      *  F3=Exit
S002 C                   WHEN      *IN03 = *on
      *  Release the document lock
B003 C                   IF        Lockok = *on
     C     #SDOCD        CHAIN     DBGDFTH1                           81
B004 C                   IF        *IN81 = *off
     C                   MOVE      'F'           DFLOCK
     C                   UPDATE    DB1DFTH
E004 C                   ENDIF
E003 C                   ENDIF
      *  F12=Previous
S002 C                   WHEN      *IN12 = *on
      *  Release the document lock
B003 C                   IF        Lockok = *on
     C     #SDOCD        CHAIN     DBGDFTH1                           81
B004 C                   IF        *IN81 = *off
     C                   MOVE      'F'           DFLOCK
     C                   UPDATE    DB1DFTH
E004 C                   ENDIF
E003 C                   ENDIF
     C                   LEAVE
      *  Update details
S002 C                   OTHER
      *  Update the index if document free for update
B003 C                   IF        Lockok = *on
     C     #SDOCD        CHAIN     DBGDFTH1                           81
B004 C                   IF        *IN81 = *off
     C                   MOVE      #WDOCH        DFDOCH
     C                   MOVE      #WHEAD        DFHEAD
     C                   MOVE      'F'           DFLOCK
     C     Symb:Atrb     XLATE(P)  #SHTX1        DFHTX1
     C     Symb:Atrb     XLATE(P)  #SHTX2        DFHTX2
     C     Symb:Atrb     XLATE(P)  #SHTX3        DFHTX3
     C     Symb:Atrb     XLATE(P)  #SHTX4        DFHTX4
     C     Symb:Atrb     XLATE(P)  #SHTX5        DFHTX5
     C     Symb:Atrb     XLATE(P)  #SHTX6        DFHTX6
     C     Symb:Atrb     XLATE(P)  #SFTX1        DFFTX1
     C     Symb:Atrb     XLATE(P)  #SFTX2        DFFTX2
     C     Symb:Atrb     XLATE(P)  #SFTX3        DFFTX3
     C                   EVAL      DFADTE = *DATE
     C                   MOVE      #@User        DFAUSR
     C                   UPDATE    DB1DFTH
E004 C                   ENDIF
     C                   MOVE      *on           Reload
E003 C                   ENDIF
     C                   LEAVE
E002 C                   ENDSL
E001 C                   ENDDO
      *
     C                   ENDSR
      **********************************************************************************************
      * KEYWRD: Subset display by keyword(s)
      **********************************************************************************************
     C     KEYWRD        BEGSR
      *
     C                   EXFMT     WINDOW4
B001 C                   SELECT
      *  F1/Help pressed
S001 C                   WHEN      *IN01 = *on
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb1        Cmdstr
     C                   PARM      60            Cmdlen
      *
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Ovrdb2        Cmdstr
     C                   PARM      60            Cmdlen
      *  Call the Helptext Viewer
     C                   CALL      'DBG010R4'                           90      Trap errors
     C                   PARM      PGM           P#Pgm
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Dltovr        Cmdstr
     C                   PARM      40            Cmdlen
      *  F12=Previous
S001 C                   WHEN      *IN12 = *on
      *
S001 C                   OTHER
      *  The first keyword is required to trigger subset processing
B002 C                   IF        KWORD1 <> *blanks
     C                   MOVE      *on           Subset
     C                   MOVE      Text01        SUBTXT
      * Set *LDA to first keyword for F16 search in matching documents
     C                   IN        LDA
     C                   EVAL      %SUBST(LDA:503:10) = KWORD1
     C                   OUT       LDA
      *  Set the length of each keyword entered
     C     ' '           CHECKR    KWORD1        #1                       70
B003 C                   IF        *IN70 = *off
     C                   EVAL      #1 = 0
E003 C                   ENDIF
      *
     C     ' '           CHECKR    KWORD2        #2                       70
B003 C                   IF        *IN70 = *off
     C                   EVAL      #2 = 0
E003 C                   ENDIF
      *
     C     ' '           CHECKR    KWORD3        #3                       70
B003 C                   IF        *IN70 = *off
     C                   EVAL      #3 = 0
E003 C                   ENDIF
      *  Load the workfile with document(s) that contain above keyword(s)
     C                   EXSR      LOADWF
      *  Otherwise cancel subset processing
X002 C                   ELSE
     C                   MOVE      *off          Subset
     C                   EVAL      SUBTXT = *blanks
E002 C                   ENDIF
     C                   EVAL      #Docd = *blanks
     C                   MOVE      *on           Reload
E001 C                   ENDSL
      *
     C                   ENDSR
      **********************************************************************************************
      * LOADWF: Load workfile with documents containing keyword(s)
      **********************************************************************************************
     C     LOADWF        BEGSR
      *  Start with the first document that contains this word
     C     KWORD1        SETLL     DBGDFTK2
      *  Clear out the workfile
     C                   CLOSE     DBGOLD0W
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      Clrpfm        Cmdstr
     C                   PARM      40            Cmdlen
     C                   OPEN      DBGOLD0W
      *  Remove messages from queue after display
     C                   CALL      'DBG045CL'                           90
      *  Read all the entries for this word, including words that start with it
     C                   READ      DBGDFTK2                               83
      *
B001 C                   DOW       *IN83 = *off
     C                   MOVE      DFDOCD        K#Docd
     C                   MOVE      *off          Rcdrqd
      *  Look for a match
B002 C                   IF        %TRIM(KWORD1) =
     C                             %SUBST(DFWORD:1:%LEN(%TRIM(KWORD1)))
     C                   MOVE      *on           Rcdrqd
X002 C                   ELSE
     C                   LEAVE
E002 C                   ENDIF
      *  If keyword two entered, it must exist on the same document as keyword 1
      *  to be selected for display
B002 C                   IF        KWORD2 <> *blanks
     C                   MOVE      *off          Rcdrqd
     C                   MOVE      KWORD2        K#Word
     C     Wrdky1        SETLL     DBGDFTK1
     C                   READ(N)   DBGDFTK1                               84
B003 C                   IF        *IN84 = *off
     C                             AND DFDOCD = K#Docd
      *  Look for a match
B004 C                   IF        %TRIM(KWORD2) =
     C                             %SUBST(DFWORD:1:%LEN(%TRIM(KWORD2)))
     C                   MOVE      *on           Rcdrqd
E004 C                   ENDIF
E003 C                   ENDIF
E002 C                   ENDIF
      *  If keyword three entered, it must exist on the same document as the
      *  previous keywords to be selected for display
B002 C                   IF        KWORD3 <> *blanks
     C                             AND Rcdrqd = *on
     C                   MOVE      *off          Rcdrqd
     C                   MOVE      KWORD3        K#Word
     C     Wrdky1        SETLL     DBGDFTK1
     C                   READ(N)   DBGDFTK1                               84
B003 C                   IF        *IN84 = *off
     C                             AND DFDOCD = K#Docd
      *  Look for a match
B004 C                   IF        %TRIM(KWORD3) =
     C                             %SUBST(DFWORD:1:%LEN(%TRIM(KWORD3)))
     C                   MOVE      *on           Rcdrqd
X004 C                   ELSE
     C                   LEAVE
E004 C                   ENDIF
E003 C                   ENDIF
E002 C                   ENDIF
      *  If this document holds all entered keyword(s), make sure it's on file
B002 C                   IF        Rcdrqd = *on
     C     DFDOCD        CHAIN     DBGOLD0W                           84
B003 C                   IF        *IN84 = *off
     C                   UPDATE    DB1OLDWF
X003 C                   ELSE
     C                   WRITE     DB1OLDWF
E003 C                   ENDIF
E002 C                   ENDIF
      *
     C                   READ      DBGDFTK2                               83
      *
E001 C                   ENDDO
      *
     C                   ENDSR
      **********************************************************************************************
      * SNDMSG: Send Program Message
      **********************************************************************************************
     C     SNDMSG        BEGSR
      *  Use in-house utility (via system API 'QMHSNDPM')
      *  Name of message file used. GSM0000 is the standard on the F70/35
     C                   CALL      'DBG044R3'
     C                   PARM                    Msgid
     C                   PARM      'DBGMSGF'     Msgfil
     C                   PARM      '*LIBL'       Msglib
     C                   PARM                    Msgdta
     C                   PARM                    Dtalen
     C                   PARM      '*INFO'       Msgtyp
     C                   PARM      PGM           Pgmq
     C                   PARM                    Pgmstk
     C                   PARM      '       '     #Errid
      *
     C                   ENDSR
      **********************************************************************************************

-- MartinRowe - 26 May 2005
Topic revision: r1 - 26 May 2005 - 18:54:01 - 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