You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG005R4 (26 May 2005, MartinRowe)EditAttach
**************************************************************************
* 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 Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 18:54:01 - 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