RPG Windows
Writing and Reading from a source member
Reading the Window Source
This process was written as a generic help system RPG application development. Using the SoftCode system, application programs could be written without help functions and then help functions could be added as necessary after the application development had been completed. The read program, created as a module is very old code. It was built around examples originally created by a programmer named Julie Buckles--at least that was the first time I saw this type of code. Details I later filled in with information from an ancient IBM SDLC manual containing a map of the 5250 data stream. The original code was a program; this version of the source is actually compiled as a module and is incorporated into a service program.
/TITLE ** ACTIVE WINDOW DISPLAY FILE **
H DEBUG(*YES) NOMAIN
H OPTION(*SRCSTMT : *NODEBUGIO)
********************************************************************
* PROGRAM NAME - SC0105RM *
* *
* FUNCTION - THIS PROGRAM IS DESIGNED TO READ TEXT TO *
* PROVIDE AN INTERACTIVE WINDOW FOR USE *
* WITH GENERAL APPLICATION PROGRAMS *
* *
********************************************************************
********************************************************************
* PROGRAM INTERFACE SECTION *
* *
* CALLED BY PROGRAMS: PROMPTER - INTERACTIVE WINDOW SHELL *
* Procedures....: WriteWindow - Display processor *
* ShwHlpTxt- EXTENDED HELP TEXT *
* *
********************************************************************
********************************************************************
* ** INDICATOR USAGE *** *
* ** ON ** ** OFF ** *
* F3 -- EXIT *
* *
* ** ERROR INDICATORS ** *
* 98 -- ERROR INDICATOR *
* *
********************************************************************
********************************************************************
* MODIFICATION LOG *
* *
* DATE PROGRAMMER DESCRIPTION *
* *
********************************************************************
FINPUT IF F 92 DISK USROPN
F INFDS(INFDS)
*-- Common prototypes
*---
* SOURCE FILE CONTAINING WINDOW TEXT
D S S 1 DIM(256)
D NUM S 1 0 DIM(8)
D TT S 1 DIM(80)
*----------------------------------------------------------------
* FORMAT FLAG 1 03 FMTID FORMAT ID
* SOURCE TEXT 04 05 SRCTXT *BLANKS
* WINDOW ID 06 15 WNDID WINDOW ID
* BLANK CHARACTER 16 16 BLANK1 *BLANK
* STARTING ROW 17 18 STARTING LINE
* BLANK CHARACTER 19 19 BLANK2 *BLANK
* STARTING COLUMN 20 21 STARTING COLUMN
* BLANK CHARACTER 22 22 BLANK3 *BLANK
* ENDING ROW 23 24 ENDING LINE
* BLANK CHARACTER 25 25 BLANK4 *BLANK
* END COLUMN 26 27 ENDING COLUMN
*----------------------------------------------------------------
D INFDS DS
D NMBR1 397 400B 0
D PGMDS ESDS EXTNAME(SWPSTSP) Pgm status map
D FUNCTIONKEY E DS EXTNAME(UTLKEYPF) qualified Function keys
*
D FunctionKeys PR 32A
* Starting/Ending Row/Column test for valid numeric data
D CLRWNT DS
D STRRWA 2
D STRCLA 2
D ENDRWA 2
D ENDCLA 2
*----------------------------------------------------------------
* Multiple occurrence data structure to hold window text as it
* is read from file
*----------------------------------------------------------------
D WNDDS DS OCCURS(22)
D WNDTXT 80
D DS
D BIN2 4B 0
D BINLWB 1 OVERLAY(BIN2:2)
*---------------------------------------------------------------------
* START of work fields
*---------------------------------------------------------------------
D #BUILD S 8 INZ('BUILD ')
D #EOF S 1
D #ERROR S 8 INZ('ERROR ')
D #EXIT S 8 INZ('EXIT ')
D #FIRST S 1
D #FRCD S 9 0
D #FUNCT S 8
D #HELP S 8 INZ('HELP ')
D #INDX S 9 0
D #LRCD S 9 0
D #PAGE S 3 0
D #POSIT S 8 INZ('POSIT ')
D #READ S 8 INZ('READ ')
D #VALID S 8 INZ('VALID ')
D #WRITE S 8 INZ('WRITE ')
D #XPAND S 8 INZ('XPAND ')
D #YES S 1
D BTMBAR S 1
D CMD1 S 30 INZ('F2=Extended Help F3=Exit')
D CMD2 S 30 INZ('More...')
D CMD3 S 30 INZ('Bottom...')
D CMD4 S 30 INZ('Top of display')
D COL S 3 0
D DFLT S 1
D DFT S 2 0
D ENDCL S 2 0
D ENDRW S 2 0
D ERR S 1
D FILNAM S 10
D FOUND S 1
D FUNC S 1
D KEYPRESSED S 1
D HNZ S 3 0
D LBPOS S 2 0
D LEN S 3 0
D LIBNAM S 10
D LSND S 3 0
D LT S 2 0
D MBRNAM S 10
D MORE S 3 0
D NEWCL S 3 0
D NEWHT S 3 0
D NEWRW S 3 0
D NEWWD S 3 0
D P$DATA S 256
D P$HLP S 10 INZ('ISD44001 ')
D PGMWND S 10
D PS S 3 0
D PSE S 3 0
D QUIT S 1 INZ('0')
D RB S 3 0
D RCDS S 3 0
D RHTBAR S 1
D ROW S 3 0
D STRCL S 2 0
D STRRW S 2 0
D TBPOS S 2 0
D TSTPAR S 1
D VRT S 3 0
D W$KEY S 5 0
D WRK24 S 24
D X S 2 0
D XX S 2 0
D X20 S 1
D X22 S 1
D X26 S 1
D X4F S 1
* Prototype for SC0105RM
D ReadWinTxt PR 256 EXTPROC(*CL:'READWINTXT')
D MBRNAM 10 const
D PGMWND 10 const
* Prototype to write window
D WriteWindow PR
D FUNC 1
D S 1 DIM(256)
D LSND 3 0
D ROW 3 0
D COL 3 0
D KEY 1
D ERR 1
D MA_X S 5 0
* Prototype for extended help
D HelpText PR EXTPROC('HELPTEXT')
D MBRNAM 10 CONST
D PGMWND 10 CONST
*---------------------------------------------------------------------
* END of work fields
*---------------------------------------------------------------------
IINPUT NS 01
*----------------------------------------------------------------
* Data stream control record: Data Record is 92 bytes
* Input format:
* Statment number 1-6
* Source date 7-12
* Source text 13-92
I 1 6 SRCSTM
I 7 12 SRCDTE
I 13 92 SRCTXT
*----------------------------------------------------------------
* The control record must be the first record found in the text.
*----------------------------------------------------------------
* Format ID record
* Format ID flag 13-15
* Window ID 18-27
* Starting Row 29-30
* Starting Column 32-33
* Ending Row 35-36
* Ending Column 38-39
I 13 15 FMTID
I 18 27 WNDID
I 29 30 STRRWA
I 32 33 STRCLA
I 35 36 ENDRWA
I 38 39 ENDCLA
*---------------------------------------------------------------------
* Start mainline calculations
*---------------------------------------------------------------------
P ReadWinTxt B export
D ReadWinTxt PI 256
D MBRNAM 10 const
D PGMWND 10 const
D P$DATA s 256
*----------------------------------------------------------------
* Mainline calculations
*----------------------------------------------------------------
<--- C EXSR @INZSR
*----------------------------------------------------------------
* CASE:
*----------------------------------------------------------------
C DOU #FUNCT = #EXIT
C SELECT
<--- C WHEN #FUNCT = #EXIT
<--- C EXSR @EXIT
<--- C WHEN #FUNCT = #POSIT
<--- C EXSR @STR1
<--- C WHEN #FUNCT = #VALID
<--- C EXSR @VALD
<--- C WHEN #FUNCT = #BUILD
<--- C EXSR @BLD1
<--- C WHEN #FUNCT = #ERROR
<--- C EXSR @DFLT
<--- C WHEN #FUNCT = #WRITE
<--- C EXSR @WRTWD
<--- C WHEN #FUNCT = #READ
<--- C EXSR @READW
C ENDSL
C ENDDO
<--- C EXSR @EXIT
*================================================================
* First time processing - initialize program variables
* Color attribute definition - Comment Only, set bits to
* respresent desire color attributes
*================================================================
---> C @INZSR BEGSR
C EVAL %SUBST(FILNAM:1:7) = 'QWNDSRC'
C EVAL %SUBST(LIBNAM:1:5) = '*LIBL'
C EVAL #FRCD = *ZEROS FIRST RECORD
C EVAL #LRCD = *ZEROS LAST RECORD
C EVAL STRRW = *ZEROS
C EVAL STRCL = *ZEROS
C EVAL ENDRW = *ZEROS
C EVAL ENDCL = *ZEROS
C EVAL LBPOS = *ZEROS
C EVAL TBPOS = *ZEROS
C EVAL ROW = *ZEROS
C EVAL COL = *ZEROS
C EVAL LEN = *ZEROS
C EVAL LSND = *ZEROS
C EVAL RCDS = *ZEROS
C EVAL #PAGE = *ZEROS
C EVAL PS = *ZEROS
C EVAL PSE = *ZEROS
C EVAL TSTPAR = *BLANKS
C EVAL BTMBAR = *BLANKS
C EVAL DFLT = *OFF
C EVAL #EOF = '1'
C EVAL #YES = '1'
C EVAL #FUNCT = *BLANKS
C EVAL LT = *ZEROS
C EVAL RHTBAR = *BLANK
C EVAL FOUND = *BLANK
C EVAL ERR = *BLANK
C EVAL X = *ZEROS
C EVAL XX = *ZEROS
C EVAL RB = *ZERO
C EVAL DFT = 2
C EVAL FUNC = 'P'
* HEX 20 Stop/Turn off special display attributes
C BITOFF '01234567' X20
C BITON '2' X20
* HEX 22 Normal
C BITOFF '01234567' X22
C BITON '1' X22
* HEX 26 - USED FOR TEXT DEFINITION
C BITOFF '01234567' X26
C BITON '2' X26
* HEX 4F RIGHT AND LEFT BAR CHARACTER
C BITOFF '01234567' X4F
C BITON '1' X4F
C EVAL RHTBAR = X4F
C EVAL BTMBAR = X4F
* HEX 00 Null character to test for paragraph characters added
* by the text management
C BITOFF '01234567' TSTPAR
*---
* Define decimal representations of command function keys
*---
C EVAL functionKey = FunctionKeys()
*----------------------------------------------------------------
* Open Window text file
*----------------------------------------------------------------
C IF NOT %OPEN(INPUT)
C OPEN(E) INPUT
C ENDIF
C 1 SETLL INPUT
B1 C IF %ERROR
C EVAL #FUNCT = #EXIT
X1 C ELSE
C EVAL #FIRST = *ON
C EVAL #FUNCT = #POSIT
E1 C ENDIF
<--- C ENDSR
*================================================================
* Subroutine to locate the window requested
* First record of text should contain the starting and ending
* row and coloumn information. If the first record read is
* end-of-file, or not a format ID seton the error indicator
* and exit the subroutine.
*================================================================
---> C @STR1 BEGSR
C EVAL #FUNCT = #VALID
C EVAL QUIT = '0'
*
C READ INPUT
C EVAL *IN25 = %EOF
B1 C IF *IN25 = *ON
C OR FMTID <> 'FMT'
C EVAL #FUNCT = #ERROR
E1 C ENDIF
*
B1 C IF #FUNCT <> #ERROR
B2 C DOU QUIT = #YES
B3 C IF FMTID = 'FMT'
C AND WNDID = PGMWND
C EVAL #FRCD = NMBR1
C EVAL FOUND = #YES
C EVAL QUIT = #YES
* Check for valid numeric data in starting and ending positions
C MOVE CLRWNT NUM
B4 C FOR X = 1 TO 8
B5 C IF NUM(X) < 0
C OR NUM(X) > 9
C EVAL QUIT = #YES
E5 C ENDIF
E4 C ENDFOR
E3 C ENDIF
B3 C IF QUIT <> #YES
C READ INPUT
C EVAL *IN25 = %EOF
C EVAL QUIT = *IN25
E3 C ENDIF
E2 C ENDDO
E1 C ENDIF
*
B1 C IF FOUND <> #YES
C EVAL #FUNCT = #ERROR
E1 C ENDIF
<--- C ENDSR
*================================================================
* Validate row and column entries move to numeric fields
*================================================================
---> C @VALD BEGSR
C MOVE STRRWA STRRW
C MOVE STRCLA STRCL
C MOVE ENDRWA ENDRW
C MOVE ENDCLA ENDCL
* Test starting row: row cannot be < 2 or >23
* Test starting column: cannot be < 4, or > 75
*
B1 C IF STRRW < 2
C OR STRCL < 4
C OR STRRW > 23
C OR STRCL > 75
C EVAL *IN98 = *ON
E1 C ENDIF
* Test ending row: row cannot be < 2, or > 23
* Ending column, column cannot be < 4 > 75
*
B1 C IF ENDRW < 2
C OR ENDRW > 23
C OR ENDCL < 4
C OR ENDCL > 75
C EVAL *IN98 = *ON
E1 C ENDIF
* At least one display character must be present to display
* or else the window is not valid
*
B1 C IF ENDRW < STRRW
C OR ENDCL < STRCL
C EVAL *IN98 = *ON
E1 C ENDIF
B1 C IF *IN98 = *ON
C EVAL #FUNCT = #ERROR
X1 C ELSE
C EVAL #PAGE = ENDRW - STRRW
C EVAL #PAGE = #PAGE + 1
C EVAL #FUNCT = #BUILD
E1 C ENDIF
<--- C ENDSR
*================================================================
* Subroutine to read window text file
* Read input file to get text for window - calculate window pos
*================================================================
---> C @BLD1 BEGSR
C EVAL WNDDS = *BLANKS
C EVAL BTMBAR = *BLANKS
C EVAL RCDS = #PAGE
C EVAL X = *ZEROS
C READ INPUT
C EVAL *IN25 = %EOF
B1 C IF *IN25 = *ON
C EVAL *IN26 = *ON
C EVAL *IN98 = *ON
X1 C ELSE
C EVAL #LRCD = NMBR1
<--- C EXSR @WPOS
C EVAL *IN26 = *OFF
E1 C ENDIF
*----------------------------------------------------------------
* Put the line of text in the window data structure
*----------------------------------------------------------------
B1 C DOW *IN26 = *OFF
<--- C EXSR @WLIN
C READ INPUT
C EVAL *IN25 = %EOF
B2 C IF *IN25 = *ON
C OR FMTID = 'FMT'
C EVAL *IN26 = *ON
B3 C IF X < RCDS
C EVAL RCDS = X
E3 C ENDIF
E2 C ENDIF
B2 C IF *IN25 = *OFF
C AND X <= RCDS
C AND FMTID <> 'FMT'
C EVAL #LRCD = NMBR1
E2 C ENDIF
*----------------------------------------------------------------
B2 C IF X > RCDS
C EVAL BTMBAR = '+'
C EVAL *IN26 = *ON
E2 C ENDIF
E1 C ENDDO
*----------------------------------------------------------------
* Blank the rest of the page if a full page hasn't been found
*----------------------------------------------------------------
B1 C DOW X < #PAGE
C EVAL SRCTXT = *BLANKS
<--- C EXSR @WLIN
E1 C ENDDO
C EVAL #FUNCT = #WRITE
<--- C ENDSR
*================================================================
* Subroutine to calculate window positions
*================================================================
---> C @WPOS BEGSR
C EVAL LEN = *ZERO
* The size of the window text to display is the difference
* between the starting column and the ending column
*
C EVAL LEN = ENDCL - STRCL
C EVAL LEN = LEN + 1
C EVAL LBPOS = STRCL - 3
*
* The number of records to display is the difference between the
* top row and ending row positions
*
C EVAL TBPOS = STRRW - 1
C EVAL RCDS = ENDRW - TBPOS
* Set the position for the right bar of the window.
* Set Position for HEX Character to turn off DSPATR HI
C EVAL PS = LEN + 4
C EVAL RB = LEN + 5
C EVAL PSE = LEN + 6
C EVAL ROW = TBPOS
C EVAL COL = LBPOS
<--- C ENDSR
*================================================================
* Subroutine to put window text to data structure
*================================================================
---> C @WLIN BEGSR
<--- C EXSR PARTST
C EVAL LT = LEN + 1
B1 C IF TT(LT) <> *BLANKS
C EVAL RHTBAR = '+'
E1 C ENDIF
C EVAL X = X + 1
C EVAL %OCCUR(WNDDS) = X
C EVAL WNDTXT = SRCTXT
<--- C ENDSR
*================================================================
* Subroutine to test for non-displayable character
*================================================================
---> C PARTST BEGSR
C MOVEA SRCTXT TT
B1 C FOR XX = 1 TO LT
B2 C IF TT(XX) = TSTPAR
C EVAL TT(XX) = *BLANKS
E2 C ENDIF
C MOVEA TT SRCTXT
E1 C ENDFOR
<--- C ENDSR
*================================================================
* Set up default error window informing the user
* an invalid window was specified (not found) in the text file
*================================================================
---> C @DFLT BEGSR
* SET UP DEFAULT WINDOW
*
C EVAL STRRW = 10
C EVAL STRCL = 10
C EVAL ENDRW = 18
C EVAL ENDCL = 40
C EVAL #PAGE = ENDRW - STRRW
C EVAL #PAGE = #PAGE + 1
*
<--- C EXSR @WPOS
*
C EVAL X = 1
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:24) = 'No window was found'
C EVAL X = X + 1
*
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:24) = 'Wnd:'
C EVAL WNDTXT = %TRIMR(WNDTXT) + ' ' + PGMWND
C EVAL X = X + 1
*
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:5) = 'FILE:'
C EVAL WNDTXT = %TRIMR(WNDTXT) + ' ' + FILNAM
C EVAL X = X + 1
*
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:4) = 'LIB:'
C EVAL WNDTXT = %TRIMR(WNDTXT) + ' ' + LIBNAM
C EVAL X = X + 1
*
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:4) = 'MBR:'
C EVAL WNDTXT = %TRIMR(WNDTXT) + ' ' + MBRNAM
C EVAL X = X + 1
*
C EVAL %OCCUR(WNDDS) = X
C EVAL %SUBST(WNDTXT:1:24) = 'Contact IT'
*----------------------------------------------------------------
* Set up default error window Row/Col and length
* set color attributes to red reverse X'247'
*----------------------------------------------------------------
C BITOFF '01234567' X22
C BITOFF '01234567' X26
C BITOFF '01234567' X4F
C BITON '27' X4F
C BITON '2' X26
C BITON '27' X22
C EVAL RHTBAR = X4F
*
C EVAL RCDS = X
C EVAL DFLT = *ON
C EVAL #FUNCT = #WRITE
<--- C ENDSR
*================================================================
* Subroutine to write window to display
* WRITE Top Bar of window to display
* Total data stream length = LENGTH OF TEXT + 7 CONTROL
* CHARACTERS (ESC, WTD, CCQ, CC2, SBA, ROW, COL) + RIGHT and
* LEFT BAR of window
*================================================================
---> C @WRTWD BEGSR
C EVAL FUNC = 'P'
C EVAL LSND = 6 + LEN
C MOVEA *BLANKS S(1)
C MOVEA X22 S(1)
C MOVEA *ALL'.' S(2)
C MOVEA X20 S(PSE)
C EVAL ROW = STRRW
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
*----------------------------------------------------------------
* write the text of the window
*----------------------------------------------------------------
B1 C FOR X = 1 TO #PAGE
C EVAL ROW = ROW + 1
C EVAL %OCCUR(WNDDS) = X
C EVAL S(2) = ':'
C MOVEA WNDTXT S(4)
C MOVEA X4F S(1)
C MOVEA X26 S(3)
C MOVEA RHTBAR S(PS)
C EVAL S(RB) = ':'
C MOVEA X20 S(PSE)
*
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
E1 C ENDFOR
*----------------------------------------------------------------
* Write the command line of the window
*----------------------------------------------------------------
C EVAL ROW = ROW + 1
C EVAL S(2) = ':'
C MOVEA CMD1 S(4)
B1 C IF KEYPRESSED = functionKey.ROLLUP
C AND BTMBAR = *BLANK
C MOVEA CMD3 S(4)
E1 C ENDIF
C MOVEA X4F S(1)
C MOVEA X26 S(3)
C MOVEA RHTBAR S(PS)
C EVAL S(RB) = ':'
C MOVEA X20 S(PSE)
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
*----------------------------------------------------------------
* Write the bottom bar of the window
*----------------------------------------------------------------
C EVAL ROW = ROW + 1
C MOVEA BTMBAR S(1)
C MOVEA X22 S(1)
B1 C IF BTMBAR = '+'
C MOVEA *BLANK S(1)
C MOVEA X26 S(1)
C EVAL MORE = PSE - 7
B2 C IF MORE < 1
C EVAL MORE = 1
E2 C ENDIF
C MOVEA CMD2 S(MORE)
C MOVEA X20 S(PSE)
X1 C ELSE
C MOVEA *ALL'.' S(3)
C MOVEA X20 S(PSE)
E1 C ENDIF
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
*
C EVAL #FUNCT = #READ
<--- C ENDSR
*================================================================
* Subroutine to READ window display
*================================================================
---> C @READW BEGSR
* LAST FUNCTION READ FROM SCREEN
C EVAL FUNC = 'R'
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
C EVAL BIN2 = *ZERO
C EVAL BINLWB = KEYPRESSED
C EVAL W$KEY = BIN2
*----------------------------------------------------------------
* Process the return data stream, if the F2 command key was
* pressed, enter into the standard (expanded help text)
* If F3 was pressed, do not return any data to the calling
* program, otherwise return any data from default values, or
* keyed input (if applicable)
*----------------------------------------------------------------
C SELECT
B1 C WHEN KEYPRESSED = functionKey.F2
C CALLP HelpText( MBRNAM : PGMWND )
C EXSR @INZSR
B1 C WHEN KEYPRESSED = functionKey.F3
C EVAL P$DATA = *BLANKS
C EVAL #FUNCT = #EXIT
<--- C WHEN KEYPRESSED = functionKey.F20
<--- C EXSR @XPND
C EVAL #FUNCT = #WRITE
<--- C WHEN KEYPRESSED = functionKey.ROLLUP
<--- C EXSR @ROLLU
<--- C WHEN KEYPRESSED = functionKey.ROLLDN
<--- C EXSR @ROLLD
C OTHER
C MOVEA S P$DATA
C EVAL #FUNCT = #EXIT
C ENDSL
<--- C ENDSR
*================================================================
* Set On LR at window program, close file and exit pgm
*================================================================
---> C @EXIT BEGSR
C EVAL FUNC = 'Q'
C CALLP WRITEWINDOW(FUNC: S: LSND: ROW: COL:
C KEYPRESSED: ERR)
C IF %OPEN(INPUT)
C CLOSE INPUT
C ENDIF
C EVAL #FIRST = *BLANK
C RETURN P$DATA
<--- C ENDSR
*================================================================
* Expand the size of the window
*================================================================
---> C @XPND BEGSR
C EVAL VRT = ENDRW - STRRW
C EVAL HNZ = ENDCL - STRCL
C EVAL NEWRW = STRRW / 2
C EVAL NEWCL = STRCL / 2
C EVAL NEWHT = VRT * 2
C EVAL NEWWD = HNZ * 2
C EVAL RHTBAR = ' '
*----------------------------------------------------------------
B1 C IF NEWRW < 2
C EVAL STRRW = 2
X1 C ELSE
C EVAL STRRW = NEWRW
E1 C ENDIF
*
B1 C IF NEWCL < 4
C EVAL STRCL = 4
X1 C ELSE
C EVAL STRCL = NEWCL
E1 C ENDIF
*----------------------------------------------------------------
* Ending column, column cannot be < 4 > 75
*----------------------------------------------------------------
C EVAL NEWWD = NEWWD + STRCL
C EVAL NEWHT = NEWHT + STRRW
B1 C IF NEWHT > 22
C EVAL ENDRW = 22
X1 C ELSE
B2 C IF ENDRW < NEWHT
C EVAL ENDRW = NEWHT
E2 C ENDIF
E1 C ENDIF
B1 C IF NEWWD > 75
C EVAL ENDCL = 75
X1 C ELSE
B2 C IF NEWWD > ENDCL
C EVAL ENDCL = NEWWD
E2 C ENDIF
E1 C ENDIF
C EVAL #PAGE = ENDRW - STRRW
C EVAL #PAGE = #PAGE + 1
C #FRCD CHAIN INPUT
C EVAL *IN25 = NOT %FOUND
<--- C EXSR @BLD1
<--- C ENDSR
*================================================================
* Subroutine to position the file on ROLLDOWN. Subract the
* page-size from the last record read, reposition the file.
* If the index variable is less than the first record read
* set the index to the first record processed.
*================================================================
---> C @ROLLD BEGSR
C EVAL #INDX = #LRCD - RCDS
C EVAL #INDX = #INDX - #PAGE
B1 C IF #INDX < #FRCD
C EVAL #INDX = #FRCD
E1 C ENDIF
C #INDX CHAIN INPUT
C EVAL *IN25 = NOT %FOUND
<--- C EXSR @BLD1
<--- C ENDSR
*================================================================
* Subroutine to position the file on ROLLUP. If the index
* is less than the first record read, set the index to
* the first record processed.
*================================================================
---> C @ROLLU BEGSR
C EVAL #INDX = #LRCD
C READ INPUT
C EVAL *IN25 = %EOF
*
B1 C IF *IN25 = *ON
C OR FMTID = 'FMT'
C EVAL #INDX = #LRCD - RCDS
E1 C ENDIF
*
B1 C IF #INDX < #FRCD
C EVAL #INDX = #FRCD
C #INDX CHAIN INPUT
C EVAL *IN25 = NOT %FOUND
X1 C ELSE
C #INDX SETLL INPUT
E1 C ENDIF
*
<--- C EXSR @BLD1
<--- C ENDSR
P ReadWinTxt E
Fig. 1
Prompt Window for Status
The image is an example of the prompt window process in use. The program, an interactive job with a subfile displayed, has invoked the PROMPTER. The window presented is defined by the QWNDSRC source file. Notice the cursor is position to an input capable one-byte field. If a value is entered, it will be passed back to the calling program.
Writing the Window
The window is actually written one line at a time. The data passed to the module from the procedure reading the source code creates a window by setting display attributes. Bit patterns determine the field words as well as the attributes--where to start and end a field, if defined.
/TITLE ** ACTIVE INFORMATION WINDOW DISPLAY **
H nomain DEBUG(*YES)
****************************************************************
* PROGRAM NAME - SC0100RM *
* *
* FUNCTION - THIS PROGRAM DEFINES A DATA STREAM AND *
* OVERLAYS THE EXISTING DISPLAY, READS THE *
* WINDOW AND RETURNS INPUT DATA. *
* *
****************************************************************
****************************************************************
* PROGRAM INTERFACE SECTION *
* *
* CALLED BY PROGRAMS: SC0105RM - WINDOW TEXT PROCESSOR *
* CALLS PROGRAMS: *
****************************************************************
****************************************************************
* MODIFICATION LOG *
* *
* DATE PROGRAMMMER DESCRIPTION *
* *
****************************************************************
****************************************************************
* ** INDICATOR USAGE *** *
* ** ON ** ** OFF ** *
* *
* ** ERROR INDICATORS ** *
****************************************************************
FSC0100DF CF E WORKSTN USROPN
D DUMMYE S 1 DIM(1)
D C S 1 DIM(256)
D DS
D DUMMYD 1
* Stream data structure contains length of data stream to send
* and length of data stream to receive (both in Hex).
* The operation, determines send/receive (Hex 71=send Hex 73=
* receive).
D STREAM DS 1900
D S 1 1900
D DIM(1900)
D LSND 1 2B 0
D LREC 3 4B 0
D OP 5 5
D CFTCTL DS 2
D ESC1 1
D CFT 1
* REQUEST UNIT CONTROL DATA STRUCTURE
* ESC = ESCAPE
* WTD = WRITE TO DISPLAY
* CC1 = 1ST BYTE CONTROL CODE: HEX/00
* CC2 = 2ND BYTE CONTROL CODE: HEX/38
D RUCTL DS
D ESC 1
D WTD 1
D CC1 1
D CC2 1
* SET BUFFER ADDRESS DATA STRUCTURE
D SBA DS 3
D SB 1
D ROW 1
D COL 1
* RU INPUT DATA STRUCTURE
D RUDTA DS
D SF 1
D FFW1 1
D FFW2 1
D ATR 1
D FL 4B 0
*****************************************************************
D DS
D BIN2 4B 0
D BINLWB 1 OVERLAY(BIN2:2)
*---------------------------------------------------------------------
* START of work fields
*---------------------------------------------------------------------
D #A S 5 0
D #AD S 3 0
D #ADCTL S 3 0
D #B S 5 0
D #B1 S 5 0
D #CNT S 5 0
D #IX S 5 0
D #NL S 5 0
D #OVER S 5 0
D Override S 60 inz('OVRDSPF SC0100DF -
D SC0100DX LVLCHK(*NO) -
D OVRSCOPE(*CALLLVL)')
D #WKR S 3 0
D #WKX S 3 0
D CMDLen S 15 5
D CMDTXT S 60
D ECOL S 3 0
D ERR S 1
D FTYPE S 1
D HALF S 3 0
D HLDATR S 1
D KEY S 1
D NM S 1
D RCOL S 3 0
D SCOL S 3 0
D W$len S 3 0
*---------------------------------------------------------------------
* END of work fields
*---------------------------------------------------------------------
*----------------------------------------------------------------------
* Prototype for SWRWINRI
*----------------------------------------------------------------------
D WriteWindow PR
D FUNC_ 1
D CHAR_ 256
D LEN_ 3 0
D ROWI_ 3 0
D COLI_ 3 0
D KEY_ 1
D ERR_ 1
* *ENTRY Interface for Main Procedure
P WriteWindow B export
D WriteWindow PI
D DspFunction 1
D CharString 256
D StringLen 3 0
D RowIn 3 0
D ColIn 3 0
D Key 1
D Err 1
*
C SELECT
B001 C WHEN *IN01 = *OFF
B001 C EXSR @FIRST
C ENDSL
*
*----------------------------------------------------------------
* Allow 198 bytes for string, up to 18 possible 1 byte fields,
* 6 bytes require for definition = 108
* plus 18 bytes of default data = 126
* plus 18 spaces between fields and the definition
* 18 x 4 = 72, 126 + 72 = 198; 1900 - 198 = 1702
* Allow 198 bytes for string, up to 18 possible 1 byte fields,
*----------------------------------------------------------------
C SELECT
B001 C WHEN #IX > 1702
B001 C EXSR @WRITE
C ENDSL
C EVAL ERR = 'N'
*
B001 C IF DspFunction = 'P'
B002 C IF RowIn< 1
002 C OR RowIn> 24
002 C EVAL ERR = 'Y'
E002 C ENDIF
001 *
B002 C IF ColIn< 1
002 C OR ColIn> 80
002 C EVAL ERR = 'Y'
E002 C ENDIF
001 *
B002 C IF StringLen< 1
002 C OR StringLen> 256
002 C EVAL ERR = 'Y'
E002 C ENDIF
E001 C ENDIF
*
* CHECK FOR VALID FUNCTION ENTRY
*
B001 C IF DspFunction <> 'I'
001 C AND DspFunction <> 'P'
001 C AND Dspfunction <> 'R'
001 C AND DspFunction <> 'W'
001 C AND DspFunction <> 'Q'
001 C EVAL ERR = 'Y'
E001 C ENDIF
*
C IF ERR <> 'Y'
C SELECT
B001 C WHEN DspFunction = 'I'
B001 C EXSR @INIT
001 C WHEN DspFunction = 'P'
001 C EXSR @PUT
001 C WHEN DspFunction = 'R'
001 C EXSR @READ
001 C WHEN DspFunction = 'W'
001 C EXSR @WRITE
C ENDSL
C ENDIF
*
B001 C IF DspFunction = 'Q'
001 C EVAL *IN01 = *OFF
C IF %OPEN(SC0100DF)
C CLOSE SC0100DF
E001 C ENDIF
E001 C ENDIF
C RETURN
*================================================================
* FIRST PASS CALCULATIONS SUBROUTINE
*================================================================
C @FIRST BEGSR
C EVAL *IN01 = *ON
C MOVEL(P) OVERRIDE CMDTXT
C EVAL CMDLEN = 60
C CALL 'QCMDEXC' LR
C PARM CMDTXT
C PARM CMDLEN
*
B001 C IF *INLR = *ON
001 C EVAL ERR = 'Y'
001 C RETURN
E001 C ENDIF
*
C IF NOT %OPEN(SC0100DF)
C OPEN SC0100DF
E001 C ENDIF
C EXSR @INIT
C ENDSR
*================================================================
* INITIALIZE CONTROL FIELDS AND CONSTANTS
*================================================================
C @INIT BEGSR
C EVAL RCOL = *ZERO
* Initialize control bytes, set all bits off
C BITOFF '01234567' ESC1
C BITOFF '01234567' CFT
C BITOFF '01234567' ESC
C BITOFF '01234567' WTD
C BITOFF '01234567' CC1
C BITOFF '01234567' CC2
C BITOFF '01234567' SB
C BITOFF '01234567' SF
C BITOFF '01234567' FFW1
C BITOFF '01234567' FFW2
C BITOFF '01234567' ATR
C BITOFF '01234567' NM
*----------------------------------------------------------------
* Set control characters by setting bits on
*----------------------------------------------------------------
C BITON '5' ESC1 HEX'04'
C BITON '13' CFT HEX'50'
C BITON '5' ESC HEX'04'
C BITON '37' WTD HEX'11'
C BITON '234' CC2 HEX'38'
C BITON '37' SB HEX'11'
C BITON '3457' SF HEX'1D'
C BITON '14' FFW1
C BITON '256' ATR
C BITON '2' NM
*
C EVAL STREAM = *BLANKS
C MOVEA CFTCTL S(6)
C MOVEA RUCTL S(8)
C EVAL #IX = 12
C ENDSR
*================================================================
* BUILD DISPLAY DATA STREAM
*================================================================
C @PUT BEGSR
* Initialize character array, convert row, column and length
C MOVEA CharString C(1)
C EXSR @CVTRC
C EVAL W$Len= StringLen
* Adjust length of text sting if necessary
C EXSR @ADJST
* Define the starting column of the field
C EVAL #B = 1
B001 C DOU *IN51 = *OFF
001 C '~' LOOKUP C(#B) 51
B002 C IF *IN51 = *ON
002 C EVAL SCOL = #B
002 * Define the ending column
002 C EVAL #B = #B + 1
002 C '~' LOOKUP C(#B) 51
B003 C IF *IN51 = *ON
003 C EVAL ECOL = #B
003 C EVAL FL = ECOL - SCOL
003 C EVAL FL = FL - 1
003 C EVAL FTYPE = 'A'
B004 C FOR #B1 = SCOL TO ECOL
B005 C IF C(#B1) = '.'
005 C EVAL FTYPE = 'N'
E005 C ENDIF
E004 C ENDFOR
003 *
B004 C IF FTYPE = 'A'
004 C BITOFF '567' FFW1
004 C BITOFF '01234567' FFW2
004 C BITON '2' FFW2
X004 C ELSE
004 C BITON '567' FFW1
004 C BITOFF '01234567' FFW2
E004 C ENDIF
003 * write buffer address codes and field definitions
003 C EVAL BIN2 = ColIn+ SCOL
003 C EVAL BIN2 = BIN2 - 1
003 C EVAL COL = BINLWB
003 C MOVEA SBA S(#IX)
003 C EVAL #IX = #IX + 3
003 * include field definitions
003 C MOVEA RUDTA S(#IX)
003 C EVAL #IX = #IX + 6
003 * include default data (if any)
B004 C FOR #B1 = SCOL TO ECOL
B005 C IF C(#B1) <> '~'
005 C AND C(#B1) <> '.'
B006 C IF C(#B1) <> '_'
006 C EVAL S(#IX) = C(#B1)
006 C EVAL #IX = #IX + 1
X006 C ELSE
006 C EVAL S(#IX) = *BLANK
006 C EVAL #IX = #IX + 1
E006 C ENDIF
E005 C ENDIF
004 *
E004 C ENDFOR
003 *
003 * If field is numeric, make sure sign character is blank
B004 C IF FTYPE = 'N'
004 C EVAL S(#IX) = *BLANK
004 C EVAL #IX = #IX + 1
E004 C ENDIF
003 *
003 C EVAL #B = #B + 1
E003 C ENDIF
002 *
E002 C ENDIF
E001 C ENDDO
* Create text strings
C EXSR @CVTRC
C MOVEA SBA S(#IX)
C EVAL #IX = #IX + 3
* Find the beginning text attribute
C EXSR @ATR
* write text to screen/ignore input definitions
* skip all input defined fields
B001 C FOR #B = 1 TO W$Len
B002 C IF C(#B) = '~'
002 C EVAL #B = #B + 1
B003 C DOU C(#B) = '~'
003 C EVAL #B = #B + 1
E003 C ENDDO
002 * Send a new buffer address for the rest of the text
002 C EVAL BIN2 = #B + ColIn
002 C EVAL BIN2 = BIN2 - 1
002 C EVAL COL = BINLWB
002 C MOVEA SBA S(#IX)
002 C EVAL #IX = #IX + 3
002 C EVAL S(#IX) = HLDATR
002 C EVAL #IX = #IX + 1
X002 C ELSE
002 C EVAL S(#IX) = C(#B)
002 C EVAL #IX = #IX + 1
E002 C ENDIF
E001 C ENDFOR
C ENDSR
*================================================================
* ADD RU CONTROL FOR FINAL READ OPERATION
*================================================================
C @READ BEGSR
* Set control bits for send/receive
C BITOFF '01234567' OP
C BITON '12367' OP HEX/73
* Set request unit to read screen
C BITOFF '01234567' WTD
C BITON '16' WTD HEX/42
* Add read request to data stream
C MOVEA RUCTL S(#IX)
C EVAL #IX = #IX + 4
C EVAL #IX = #IX - 6
C EVAL LSND = #IX
C EVAL LREC = 1900
* request I/O to device file
C EXFMT USERFMT
* clear return values
C EVAL CharString= *BLANK
* set return values
C EVAL BIN2 = *ZERO
C EVAL BINLWB = S(1)
C EVAL RowIn= BIN2
C EVAL BIN2 = *ZERO
C EVAL BINLWB = S(2)
C EVAL ColIn= BIN2
C EVAL KEY = S(3)
C MOVEA S(4) CharString
* clear and initialize data stream
C MOVEA *BLANKS S(1)
C EXSR @INIT
C ENDSR
*================================================================
* WRITE THE DATA STREAM
*================================================================
C @WRITE BEGSR
* Set operation control bits to send
C BITOFF '01234567' OP
C BITON '1237' OP HEX/71
C EVAL #IX = #IX - 6
C EVAL LSND = #IX
C EVAL LREC = *ZERO
* request ouput to device file
C WRITE USERFMT
* clear and initialize data stream
C MOVEA *BLANKS S(1)
C EXSR @INIT
C ENDSR
*================================================================
* GET ATTRIBUTE FOR TEXT DATA STRING
*================================================================
C @ATR BEGSR
* Set default hold attribute to normal
C EVAL HLDATR = NM
* divide length of screen by 2, calulate the last screen
* attribute before the text begins
C EVAL HALF = W$Len/ 2
B001 C IF HALF > 1
B002 C FOR #A = 1 TO HALF
002 C TESTB '01' C(#A) 51
B003 C IF *IN51 = *ON
003 C TESTB '2' C(#A) 51
E003 C ENDIF
B003 C IF *IN51 = *ON
003 C EVAL HLDATR = C(#A)
E003 C ENDIF
E002 C ENDFOR
E001 C ENDIF
C ENDSR
*================================================================
* ADJUST TEXT TO FIT ON SCREEN
*================================================================
C @ADJST BEGSR
* Test and set field length
C EVAL RCOL = ColIn+ W$Len
C EVAL RCOL = RCOL - 1
B001 C IF RCOL > 80
001 C EVAL #OVER = #OVER - 80
001 C EVAL W$Len= W$Len- #OVER
E001 C ENDIF
C EVAL #NL = W$Len+ 1
C MOVEA *BLANKS C(#NL)
* Check to see if field has been truncated
* if field is truncated remove it
C EVAL #CNT = *ZERO
B001 C FOR #AD = 1 TO W$Len
B002 C IF C(#AD) = '~'
002 C EVAL #CNT = #CNT + 1
E002 C ENDIF
E001 C ENDFOR
B001 C IF #CNT <> *ZERO
001 C #CNT DIV 2 #WKX
001 C MVR #WKR
B002 C IF #WKR <> *ZERO
002 C EVAL #AD = W$Len
B003 C FOR #ADCTL = 1 TO W$Len
B004 C IF C(#AD) = '~'
004 C EVAL C(#AD) = *BLANK
004 C EVAL #ADCTL = W$Len
X004 C ELSE
004 C EVAL C(#AD) = *BLANK
E004 C ENDIF
003 C EVAL #AD = #AD - 1
E003 C ENDFOR
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
*================================================================
* CONVERT ROW AND COLUMN TO BINARY
*================================================================
C @CVTRC BEGSR
C EVAL BIN2 = *ZERO
C EVAL BIN2 = RowIn
C EVAL ROW = BINLWB
C EVAL BIN2 = ColIn
C EVAL COL = BINLWB
C ENDSR
P WriteWindow E
Prompt Window for Description
Here is another example of the window process in use. This time the window is a different size, the input capable field is now 25 characters, and placed at the bottom of the window instead of at the top. This is a generic help process. The code is archaic; the result is a write-once-use-anywhere type of effort. Using DDS keywords such as: ASSUME, KEEP, OVERLAY, PUTOVR, or WINDOW is much simpler to understand. However, this application development effort produced a window overlay that can be dynamically sized. Input capable fields are designed to be expandable--all without recompiling a display file or program. Think about that for a moment. The fields can even change from character to numeric without changing any code!