You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG020R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG020R4: Edit text screen
* 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
**********************************************************************************************
* N.B. This pgm uses workfile logicals, TEMPDFT1 & TEMPDFT2. These are copies of DBGDFTD1 &
* DBGDFTD2 in QTEMP. To create this program, wrap the CRTBNDRPG command with overrides, or
* create permanent copies of the objects.
**********************************************************************************************
H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
**********************************************************************************************
* FILES:
**********************************************************************************************
FTEMPDFT1 UF A E K DISK USROPN
F RENAME(DB1DFT0:TEMP0)
FTEMPDFT2 UF E K DISK USROPN
F RENAME(DB1DFT1:TEMP1)
FDBGDFTD1 UF A E K DISK
FDBGDFTH1 UF E K DISK
FDBG020DF CF E WORKSTN
F SFILE(SFL:RRN1)
**********************************************************************************************
* ARRAYS:
**********************************************************************************************
* Input text 50 lines of upto 132 characters
D P#I S 132 DIM(50)
* Output text 50 lines of upto 132 characters
D P#O S 132 DIM(50)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* PROGRAM NAME
D SDS
D PGM 10
D #@User 254 263
*
D DS
D Cmd 40 INZ('CLRPFM FILE(QTEMP/DB-
D GDFTD0) ')
*
D Banner DS 79
D Headtx 13 INZ('Edit Text for')
D Docmnt 15 24
D Descrp 26 75
*
D DS
D Atr 1 48
D DIM(24)
D ATR001 1 2
D ATR002 3 4
D ATR003 5 6
D ATR004 7 8
D ATR005 9 10
D ATR006 11 12
D ATR007 13 14
D ATR008 15 16
D ATR009 17 18
D ATR010 19 20
D ATR011 21 22
D ATR012 23 24
D ATR013 25 26
D ATR014 27 28
D ATR015 29 30
D ATR016 31 32
D ATR017 33 34
D ATR018 35 36
D ATR019 37 38
D ATR020 39 40
D ATR021 41 42
D ATR022 43 44
D ATR023 45 46
D ATR024 47 48
*
**********************************************************************************************
* NAMED CONSTANTS:
**********************************************************************************************
D Atribs C CONST(X'215C225C235C245C-
D 255C265C305C315C325C-
D 335C345C355C365C285C-
D 295C2C5C2D5C385C395C-
D 3A5C3B5C3C5C3D5C3E5C')
D Blanks C CONST(X'4040404040404040404040404040-
D 4040404040404040404040')
D DspAtr C CONST(X'2021222324252630313233343536-
D 28292C2D38393A3B3C3D3E')
D Lower C CONST('abcdefghijklmnopqrstuvwxyz')
D Upper C CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D #C S 3 0
D #E S 1
D #Errid S 7
D #L S 3 0
D #O S 3 0
D #P S 3 0
D #S S 1
D BegWrp S 5 0
D CmdLen S 15 5
D CmdStr S 256
D CpyDta S 79
D CsrPos S 3 0
D CurrentLine S 5 0
D DataToScan S 80
D DtaLen S 5 0
D EndWrp S 5 0
D ErrCde S 1
D GoCopy S 1
D GoMove S 1
D GoOver S 1
D GoWrap S 1
D HldPag S 4 0
D HldWrp S 5 0
D Ignore S 3 0
D LDA S 512
D Len#1 S 3 0
D Len#2 S 3 0
D Lineno S 5 0
D LineNumber S 3 0
D MovDta S 79
D MsgDta S 512
D MsgFil S 10
D MsgID S 7
D MsgLib S 10
D MsgTyp S 10
D Needed S 3 0
D NewLin S 5 0
D Object S 10
D ObjTyp S 10
D OrgSeq S 5 0
D OvrDta S 79
D P#Elen S 3 0
D P#Flen S 3 0
D P#In1 S 256
D P#In2 S 256
D P#Out S 256
D P#Rent S 3 0
D P#Tent S 3 0
D P#TextLine S 132
D PatternLen S 3 0
D PgmQ S 10
D PgmStk S 5 0
D RcdNbr S 4 0
D Remain S 3 0
D Result S 79
D Rrn1 S 4 0
D SearchMask S 25
D SearchString S 25
D StartPos S 3 0
D StringLen S 3 0
D StringPos S 3 0
D Sv#Col S 3 0
D Sv#Lin S 3 0
D SyntaxPgm S 10
D Tolib S 10
D Toobj S 10
D Totrrn S 4 0
D Totseq S 5 0
D Translate S 1
D Trim S 1
D W#Data S 79
D Wrap S 1
D Wildcard S 1
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P#DOCD
C PARM P#TITL
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
C EXSR #INITS
* Screen display
C CALL 'DBG045CL' 90 REMOVE MSGS
B001 C DOW *IN03 = *OFF
*
C WRITE MSFLC MSG SUBFILE
C WRITE FOOTER
C EVAL *IN36 = Rrn1 > 0
C EXFMT SFLCTL
C CALL 'DBG045CL' 90 REMOVE MSGS
* Store current cursor location
C EVAL Sv#Lin = CSRLIN
C EVAL Sv#Col = CSRCOL
C EVAL HldPag = 1
* Store subfile page number
B002 C IF RELRCD > 0
C EVAL HldPag = RELRCD
E002 C ENDIF
* Process response
B002 C SELECT
* F2=Syntax prompt/check routine
S002 C WHEN *IN02 = *ON
C AND SyntaxPgm <> *BLANKS
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
C CALL SyntaxPgm 90
C TXTDTA PARM TXTDTA P#TextLine
C UPDATE SFL
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E003 C ENDIF
* F3=Exit
S002 C WHEN *IN03 = *ON
C OR *IN12 = *ON
* Display exit panel
C MOVE 'Y' #SSAVE
C EXFMT WINDOW2
* If F12=Previous not requested
B003 C IF *IN12 = *OFF
* If 'Save changes' is 'Y'es
B004 C IF #SSAVE = 'Y'
* Load screen subfile to temp file, process, & write back to document
C EXSR DWLOAD
C EXSR UPDATE
E004 C ENDIF
* Exit display
C LEAVE
* Otherwise user wants to stay on the edit screen so set off exit inds
X003 C ELSE
C EVAL *IN03 = *OFF
C EVAL *IN12 = *OFF
E003 C ENDIF
* F4=Split line
S002 C WHEN *IN04 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
C EVAL CsrPos = CSRCOL - 1
B004 C IF CsrPos > 1
* Allocate line number (to go above selected line)
C EVAL NewLin = TXTSEQ
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E004 C ENDIF
E003 C ENDIF
* F5=Move
S002 C WHEN *IN05 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* If selecting the move line
B004 C IF GoMove = *OFF
* Flag to select the move location next time round
C MOVE *ON GoMove
* Highlight the line to be moved
C MOVE TXTDTA MovDta
C EVAL OrgSeq = TXTSEQ
C MOVE X'23' TXTATR
C UPDATE SFL
* Tell user to put cursor on desired line & press F5 again
C MOVE 'GSM0302' MsgID
C EVAL MsgDta = *BLANKS
C EVAL DtaLen = 0
C EVAL PgmStk = 0
C EXSR SNDMSG
* Put cursor back to prior location
C EVAL LINE = Sv#Lin
C EVAL COL = Sv#Col
C EVAL SFPAGE = RELRCD
* Otherwise, user is specifying move location
X004 C ELSE
* Flag back to standard overlay status
C MOVE *OFF GoMove
* Allocate line number (to go above selected line)
* If moved line to go above previous location, use that line number
B005 C IF TXTSEQ < OrgSeq
C EVAL NewLin = TXTSEQ
* otherwise account for shuffling up of all lines above new location
X005 C ELSE
C EVAL NewLin = TXTSEQ - 10
E005 C ENDIF
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E004 C ENDIF
E003 C ENDIF
* F6=Insert
S002 C WHEN *IN06 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* Allocate line number (to go above selected line)
C EVAL NewLin = TXTSEQ
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E003 C ENDIF
* F7=Copy
S002 C WHEN *IN07 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* If selecting the copy line
B004 C IF GoCopy = *OFF
* Flag to select the copy location next time round
C MOVE *ON GoCopy
* Highlight the line to be copied
C MOVE TXTDTA CpyDta
C MOVE X'23' TXTATR
C UPDATE SFL
* Tell user to put cursor on desired line & press F7 again
C MOVE 'GSM0300' MsgID
C EVAL MsgDta = *BLANKS
C EVAL DtaLen = 0
C EVAL PgmStk = 0
C EXSR SNDMSG
* Put cursor back to prior location
C EVAL LINE = Sv#Lin
C EVAL COL = Sv#Col
C EVAL SFPAGE = RELRCD
* Otherwise, user is specifying copy location
X004 C ELSE
* Flag back to standard copy status
C MOVE *OFF GoCopy
* Allocate line number (to go above selected line)
C EVAL NewLin = TXTSEQ
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E004 C ENDIF
E003 C ENDIF
* F8=Remove
S002 C WHEN *IN08 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* Throw line to end of file (blanked out) & it wiil be removed
C EVAL TXTSEQ = 99999
C EVAL TXTDTA = *BLANKS
C UPDATE SFL
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E003 C ENDIF
* F9=Overlay
S002 C WHEN *IN09 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* If selecting the overlay line
B004 C IF GoOver = *OFF
* Flag to select the overlay location next time round
C MOVE *ON GoOver
* Highlight the line to be overlaid
C MOVE TXTDTA OvrDta
C EVAL OrgSeq = TXTSEQ
C MOVE X'23' TXTATR
C UPDATE SFL
* Tell user to put cursor on desired line & press F9 again
C MOVE 'GSM0303' MsgID
C EVAL MsgDta = *BLANKS
C EVAL DtaLen = 0
C EVAL PgmStk = 0
C EXSR SNDMSG
* Put cursor back to prior location
C EVAL LINE = Sv#Lin
C EVAL COL = Sv#Col
C EVAL SFPAGE = RELRCD
* Otherwise, user is specifying overlay location
X004 C ELSE
* Flag back to standard overlay status
C MOVE *OFF GoOver
C CALL 'DBG042R3' 90
C PARM OvrDta P#In1
C PARM TXTDTA P#In2
C PARM P#Out
C MOVEL P#Out TXTDTA
C EVAL OvrDta = *BLANKS
C MOVE X'20' TXTATR
C UPDATE SFL
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E004 C ENDIF
E003 C ENDIF
* F10=Attributes
S002 C WHEN *IN10 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* Select the desired attributes for the text
C EXSR ATTRIB
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E003 C ENDIF
* F11=Word wrap
S002 C WHEN *IN11 = *ON
C RELRCD CHAIN SFL 80
B003 C IF *IN80 = *OFF
* Store page number for redisplay
C EVAL HldPag = RELRCD
* If selecting the first word wrap line
B004 C IF GoWrap = *OFF
* Flag to select the copy location next time round
C MOVE *ON GoWrap
* Highlight the wrapping start line
C MOVE TXTSEQ BegWrp
C MOVE X'23' TXTATR
C UPDATE SFL
* Tell user to put cursor on the last line to be wrapped, & press 14
C MOVE 'GSM0307' MsgID
C EVAL MsgDta = *BLANKS
C EVAL DtaLen = 0
C EVAL PgmStk = 0
C EXSR SNDMSG
* Put cursor back to prior location
C EVAL LINE = Sv#Lin
C EVAL COL = Sv#Col
C EVAL SFPAGE = RELRCD
* Otherwise, user is specifying copy location
X004 C ELSE
* Flag back to standard wrap status
C MOVE *OFF GoWrap
* Allocate line number (end of wrap block)
C EVAL EndWrp = TXTSEQ
* Shuffle line numbers if wrap selection done in reverse order (end wrap
* line selected first, then start wrap line).
B005 C IF BegWrp > EndWrp
C EVAL HldWrp = EndWrp
C EVAL EndWrp = BegWrp
C EVAL BegWrp = HldWrp
E005 C ENDIF
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E004 C ENDIF
E003 C ENDIF
* F14=Find Options
S002 C WHEN *IN14 = *ON
C EXSR FINDOPTIONS
* F16=Find
S002 C WHEN *IN16 = *ON
C EXSR FIND
* Roll up
S002 C WHEN *IN60 = *ON
* Add a page of blank records
C EXSR ADDPAG
* Print (*IN29)
S002 C WHEN *IN29 = *ON
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
* Print the current 'live' document
C CALL 'DBG015R4' 90
C PARM P#DOCD
C PARM 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
* Otherwise, just save the current changes
S002 C OTHER
* Load screen subfile to temp file, process, & copy back to screen
C EXSR DWLOAD
C EXSR UPLOAD
E002 C ENDSL
E001 C ENDDO
* Update the index lock
C P#DOCD CHAIN DBGDFTH1 80
B001 C IF *IN80 = *OFF
C MOVE 'F' DFLOCK
C UPDATE DB1DFTH
E001 C ENDIF
*
C EVAL *INLR = *ON
C RETURN
**************************************************************************
* #INITS: INITIALISE ROUTINE
**************************************************************************
C #INITS BEGSR
* Create temp physical of document formatted text file
C CALL 'DBG046CL' 90
C PARM 'DBGDFTD0' Object
C PARM '*FILE' ObjTyp
C PARM 'DBGDFTD0' Toobj
C PARM 'QTEMP' Tolib
C PARM '0' ErrCde
* Create temp logicals over temp document formatted text file
C CALL 'DBG046CL' 90
C PARM 'DBGDFTD1' Object
C PARM '*FILE' ObjTyp
C PARM 'TEMPDFT1' Toobj
C PARM 'QTEMP' Tolib
C PARM '0' ErrCde
*
C CALL 'DBG046CL' 90
C PARM 'DBGDFTD2' Object
C PARM '*FILE' ObjTyp
C PARM 'TEMPDFT2' Toobj
C PARM 'QTEMP' Tolib
C PARM '0' ErrCde
* Clear the file out (if running in same job as earlier editor session)
C CALL 'QCMDEXC' 90
C PARM Cmd CmdStr
C PARM 40 CmdLen
* Open the temp logicals
C OPEN TEMPDFT1
C OPEN TEMPDFT2
* Load the temp physical with selected document
C P#DOCD CHAIN DBGDFTD1 80
B001 C DOW *IN80 = *OFF
C WRITE TEMP0
C P#DOCD READE DBGDFTD1 80
E001 C ENDDO
* Field setups
* Get company name
C *DTAARA DEFINE DBGCOMP COMPNY
C IN COMPNY
* Get primary search string if present
C *DTAARA DEFINE *LDA LDA
C IN LDA
C EVAL FINDSTRING = %SUBST(LDA:503:10)
C EVAL SyntaxPgm = %SUBST(LDA:493:10)
C MOVE P#DOCD Docmnt
C MOVE P#TITL Descrp
C MOVE *OFF GoMove
C MOVE *OFF GoCopy
C MOVE *OFF GoOver
C MOVE *OFF GoWrap
C EVAL CpyDta = *BLANKS
C EVAL OvrDta = *BLANKS
C EVAL MovDta = *BLANKS
C EVAL W#Data = *BLANKS
C EVAL NewLin = 0
C EVAL CsrPos = 0
C EVAL #P = 0
C EVAL Len#1 = 0
C EVAL Len#2 = 0
C EVAL OrgSeq = 0
C EVAL BegWrp = 0
C EVAL EndWrp = 0
C EVAL HldWrp = 0
C MOVEA Atribs Atr
C MOVE '{' STRIND
C MOVE '}' ENDIND
C MOVE X'20' #E
C EVAL HldPag = 1
* Set Find defaults
C EVAL MATCHTYPE = '2'
C EVAL Wrap = *ON
* Load screen from temp file
C EXSR UPLOAD
* Enable message subfile keywords
C EVAL *IN26 = *ON
*
C ENDSR
**************************************************************************
* DWLOAD: DOWNLOAD DATA TO DATABASE FILE FROM SCREEN
**************************************************************************
C DWLOAD BEGSR
* Loop through the whole subfile, loading into temp file
C EVAL DFLINE = 0
C CLEAR P#I
C EVAL #C = 0
B001 C 1 DO Totrrn RcdNbr
C RcdNbr CHAIN SFL 80
B002 C IF *IN80 = *OFF
* If word wrapping this block
B003 C IF TXTSEQ >= BegWrp
C AND TXTSEQ <= EndWrp
* Store text in array, ready for wrapping
C EVAL #C = #C + 1
C MOVEL TXTDTA P#I(#C)
* If on the last line of the word wrap block
B004 C IF TXTSEQ = EndWrp
* Fit text to screen size (78 char length)
C CALL 'DBG040R3' 90
C PARM #C P#Tent Text entries
C PARM 79 P#Elen Entry length
C PARM P#I Entry data
C PARM 78 P#Flen Format to length
C PARM P#Rent Returned entries
C PARM P#O Returned data
* If format text line program completed okay, load screen fields
B005 C IF *IN90 = *OFF
B006 C 1 DO P#Rent #L
C MOVEL P#O(#L) DFTEXT
C EVAL DFLINE = DFLINE + 10
C WRITE TEMP0
E006 C ENDDO
E005 C ENDIF
E004 C ENDIF
* Otherwise processing non wrap lines
X003 C ELSE
* Don't write lines to be removed after F5=Move/F8=Remove/F9=Overlay
B004 C IF TXTSEQ <> OrgSeq
C AND TXTSEQ <> 99999
* Bump up text sequence by ten for each line
C EVAL DFLINE = DFLINE + 10
C MOVE P#DOCD DFDOCD
* If current line is required slot for copy or move
B005 C IF DFLINE = NewLin
B006 C SELECT
* Load split text to two lines
S006 C WHEN *IN04 = *ON
* Calc length of data before cursor position
C EVAL Len#1 = CsrPos - 1
* Calc length of data from cursor position to end
C EVAL Len#2 = 80 - CsrPos
C EVAL #P = CsrPos
* Split line, leaving data before cursor on the original line (in effect)
C Len#1 SUBST(P) TXTDTA:1 DFTEXT
* And remainder onto the new, inserted line
C Len#2 SUBST(P) TXTDTA:#P W#Data
C MOVE W#Data TXTDTA
* Load moved text to new location
S006 C WHEN *IN05 = *ON
C MOVE MovDta DFTEXT
C EVAL MovDta = *BLANKS
* Load copied text to new location
S006 C WHEN *IN07 = *ON
C MOVE CpyDta DFTEXT
C EVAL CpyDta = *BLANKS
* Inserting a line - blank entry
S006 C OTHER
C EVAL DFTEXT = *BLANKS
E006 C ENDSL
* Write a record for the moved/copied data
C WRITE TEMP0
* Bump up text sequence for original line
C EVAL DFLINE = DFLINE + 10
E005 C ENDIF
* Write the subfile record to temp file
C MOVE TXTDTA DFTEXT
C WRITE TEMP0
E004 C ENDIF
E003 C ENDIF
E002 C ENDIF
E001 C ENDDO
* Reset pointers
C EVAL OrgSeq = 0
C EVAL NewLin = 0
C EVAL BegWrp = 0
C EVAL EndWrp = 0
* Strip out all blanks lines from the end of the document (but leave at
* least one line to indicate the document exists)
C *LOVAL SETLL TEMPDFT2
C READ TEMPDFT2 80
B001 C DOW *IN80 = *OFF
B002 C IF DFTEXT <> *BLANKS
C OR DFLINE <= 10
C UPDATE TEMP1
C LEAVE
E002 C ENDIF
C DELETE TEMP1
C READ TEMPDFT2 80
E001 C ENDDO
*
C ENDSR
**************************************************************************
* UPLOAD: UPLOAD DATA FROM DATABASE FILE TO SCREEN
**************************************************************************
C UPLOAD BEGSR
* Clear the subfile
C EVAL *IN36 = *OFF SFLCLR
C WRITE SFLCTL
C EVAL Rrn1 = 0
C EVAL TXTDTA = *BLANKS
C EVAL TXTSEQ = 0
C MOVE X'20' TXTATR
* Load in the data from the temp file
C *LOVAL SETLL TEMPDFT1
C READ TEMPDFT1 80
B001 C DOW *IN80 = *OFF
C MOVE DFTEXT TXTDTA
C EVAL TXTSEQ = DFLINE
C EVAL Rrn1 = Rrn1 + 1
C WRITE SFL
* Delete the records after reading them
C DELETE TEMP0
C READ TEMPDFT1 80
E001 C ENDDO
* If records added to subfile, complete the page with blank records
B001 C IF Rrn1 > 0
C Rrn1 DIV 18 Ignore
C MVR Remain
C EVAL Needed = 18 - Remain
X001 C ELSE
C EVAL Needed = 18
E001 C ENDIF
* Add the needed blank lines
B001 C 1 DO Needed
C EVAL TXTSEQ = TXTSEQ + 10
C EVAL TXTDTA = *BLANKS
C EVAL Rrn1 = Rrn1 + 1
C WRITE SFL
E001 C ENDDO
* Save max relative record number
C EVAL Totrrn = Rrn1
* Save the max text sequence number
C EVAL Totseq = TXTSEQ
* If previous page number is still valid (ie not displayed a blank page)
B001 C IF HldPag <= Totrrn
C EVAL SFPAGE = HldPag
* Otherwise set to page 1
X001 C ELSE
C EVAL SFPAGE = Rrn1
E001 C ENDIF
* Put cursor back to prior location
C EVAL LINE = Sv#Lin
C EVAL COL = Sv#Col
*
C ENDSR
***********************************************************************
* UPDATE: UPDATE LIVE FILE WITH NEW INFO
***********************************************************************
C UPDATE BEGSR
* Delete the original document records (live file)
B001 C DOU *IN80 = *ON
C P#DOCD DELETE DB1DFT0 80
E001 C ENDDO
* Now loop through temp file, & write to live file
C *LOVAL SETLL TEMPDFT1
C READ TEMPDFT1 80
C EVAL Lineno = 0
B001 C DOW *IN80 = *OFF
C MOVE P#DOCD DFDOCD
C EVAL Lineno = Lineno + 10
C EVAL DFLINE = Lineno
C WRITE DB1DFT0
C READ TEMPDFT1 80
E001 C ENDDO
* Update the index with change date/user
C P#DOCD CHAIN DBGDFTH1 80
B001 C IF *IN80 = *OFF
C EVAL DFADTE = *DATE
C MOVE #@User DFAUSR
C MOVE 'F' DFLOCK
C UPDATE DB1DFTH
E001 C ENDIF
* Update the keyword index file for this document
C CALL 'DBG006R4' 90
C PARM DFDOCD
*
C ENDSR
***********************************************************************
* ATTRIB: REPLACE MARKED CHARACTERS WITH SELECTED ATTRIBUTES
***********************************************************************
C ATTRIB BEGSR
* Display the attribute menu for selection
C EXFMT WINDOW1
* If user didn't quit out of the screen, and selected an option
B001 C IF *IN12 = *OFF
C AND OPTION <> 0
* Extract the selected attribute
C EVAL #O = OPTION
C MOVEL Atr(#O) #S
* Replace start character with selected attribute
C STRIND:#S XLATE TXTDTA Result
* Move translated result back into target string
C MOVE Result TXTDTA
* Replace start character with normalise attribute (hex 20)
C ENDIND:#E XLATE TXTDTA Result
* Move translated result back into target string
C MOVE Result TXTDTA
* Update subfile with 'tarted up' text
C UPDATE SFL
E001 C ENDIF
*
C ENDSR
**************************************************************************
* ADDPAG: ADD A PAGE OF BLANK RECORDS
**************************************************************************
C ADDPAG BEGSR
* Starting from last record written to subfile
C EVAL Rrn1 = Totrrn
C EVAL TXTSEQ = Totseq
C MOVE X'20' TXTATR
C EVAL TXTDTA = *BLANKS
* Add 18 blank records
B001 C 1 DO 18
C EVAL TXTSEQ = TXTSEQ + 10
C EVAL Rrn1 = Rrn1 + 1
C WRITE SFL
E001 C ENDDO
* Update max values
C EVAL Totrrn = Rrn1
C EVAL Totseq = TXTSEQ
C EVAL SFPAGE = Totrrn
* Position cursor to start of first line on the new page
C EVAL LINE = 2
C EVAL COL = 2
*
C ENDSR
**************************************************************************
* SNDMSG: SEND PROGRAM MESSAGE
**********************************************************************************************
* FINDOPTIONS: Set find options
**********************************************************************************************
C FINDOPTIONS BEGSR
*
C WRITE MSFLC
C EXFMT WINDOW3
* Remove messages from queue after display
C CALL 'DBG045CL' 90
B001 C SELECT
* F3=Exit
S001 C WHEN *IN03 = *ON
* F12=Previous
S001 C WHEN *IN12 = *ON
* Enter/F16=Find
S001 C OTHER
C EVAL Wrap = *ON
C EXSR FIND
E001 C ENDSL
*
C ENDSR
**********************************************************************************************
* FIND: SEARCH FOR STRING AND POSITION TO, IF FOUND
**********************************************************************************************
C FIND BEGSR
*
B001 C IF FINDSTRING <> *BLANKS
B002 C IF MATCHTYPE = '2'
C Lower:Upper XLATE FINDSTRING SearchMask
C EVAL Translate = *ON
X002 C ELSE
C EVAL SearchMask = FINDSTRING
C EVAL Translate = *OFF
E002 C ENDIF
* Read all records for this document number
B002 C IF Wrap = *ON
C EVAL CurrentLine = 1
C EVAL Wrap = *OFF
C EVAL StartPos = 1
E002 C ENDIF
B002 C DOW CurrentLine <= Totrrn
* Get the latest version of the current line being searched
C CurrentLine CHAIN SFL 80
* Strip out any display attributes, so search doesn't get confused
C DspAtr:Blanks XLATE TXTDTA DataToScan
C CALL 'QCLSCAN' 90
C PARM DataToScan
C PARM 79 StringLen
C PARM StartPos
C PARM SearchMask SearchString
C PARM 25 PatternLen
C PARM Translate
C PARM '1' Trim
C PARM '$' Wildcard
C PARM 0 StringPos
B003 C IF StringPos > 0
C CurrentLine DIV 18 Ignore
C MVR LineNumber
C EVAL SFPAGE = CurrentLine
C EVAL COL = StringPos + 1
C EVAL StartPos = COL
B004 C IF LineNumber = 0
C EVAL LineNumber = 18
E004 C ENDIF
C EVAL LINE = LineNumber + 3
C LEAVE
X003 C ELSE
C EVAL StartPos = 1
E003 C ENDIF
* Read next record for document number
C EVAL CurrentLine = CurrentLine + 1
B003 C IF CurrentLine > Totrrn
C LEAVE
E003 C ENDIF
E002 C ENDDO
*
B002 C IF StringPos = 0
C EVAL Wrap = *ON
* Inform user that the string wasn't found - press F16 to search from the start
C MOVE 'GSM0308' MsgID
C EVAL MsgDta = FINDSTRING
C EVAL DtaLen = 25
C EVAL PgmStk = 0
C EXSR SNDMSG
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**************************************************************************
C SNDMSG BEGSR
* Use in-house utility (via system API 'QMHSNDPM')
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
**************************************************************************
Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 19:13:29 - 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