|
I'm well behind in my reading ... 300 appends to get through ...
midrange.com
SHWATRD1 -- Display file
* Compile-time format to show the screen atrributes
*
A R USRDFNRCD
A IO1 1800 B 1 2
A IO2 1800 B 1 2
A IO3 1800 B 1 2SHWATRD2 -- Display file
* Run-time formats to show the screen attributes
*
A DSPSIZ(*DS3 *DS4)
A PRINT(*LIBL/QSYSPRT)
A R USRDFNRCD USRDFN
*
A R DUMMYRCD ASSUME
A DUMMY1 1800 O 1 2
A DUMMY2 1800 O 1 2
A DUMMY3 1800 O 1 2SHWATR_ATN - Attention program SHWATR_ATN: PGM
/* */
/* ---------------- Input Parameter Declarations ----------------- */
/* */
DCL VAR(&ERROPT) TYPE(*CHAR) LEN(4)
/* Error option *//* */
/* ------------------- Program Declarations ---------------------- */
/* */
DCLF FILE(SHWATRD1)
/* Compile-time display file */ DCL VAR(&IN) TYPE(*CHAR) LEN(5400)
/* Input buffer */
DCL VAR(&OUT) TYPE(*CHAR) LEN(5400)
/* Output buffer */
DCL VAR(&CHAR) TYPE(*CHAR) LEN(1)
/* Current character */
DCL VAR(&ATR) TYPE(*CHAR) LEN(1)
/* Saved attribute */
DCL VAR(&INCREMENT) TYPE(*DEC) LEN(5 0)
/* Increment */
DCL VAR(&ROW_POS) TYPE(*DEC) LEN(1 0) VALUE(5)
/* Row position in 5250 Data Stream */
DCL VAR(&COL_POS) TYPE(*DEC) LEN(1 0) VALUE(6)
/* Column position in 5250 Data Stream */
DCL VAR(&HEX_ROW) TYPE(*CHAR) LEN(2) VALUE(X'0000')
/* Number of rows - hexadecimal */
DCL VAR(&HEX_COL) TYPE(*CHAR) LEN(2) VALUE(X'0000')
/* Number of columns - hexadecimal */
DCL VAR(&ROW) TYPE(*DEC) LEN(5 0)
/* Number of rows */
DCL VAR(&COL) TYPE(*DEC) LEN(5 0)
/* Number of columns */
DCL VAR(&SIZE) TYPE(*DEC) LEN(5 0)
/* Screen size */
DCL VAR(&POS) TYPE(*DEC) LEN(5 0)
/* Position */
DCL VAR(&IDX) TYPE(*DEC) LEN(5 0)
/* Index of 5250DS buffer */
DCL VAR(&ERROR) TYPE(*LGL) LEN(1)
/* Error flag *//* */
/* ---------------- Mnemonic Value Declarations ------------------ */
/* */
DCL VAR(&BLANK) TYPE(*CHAR) LEN(1) VALUE(X'40')
/* Mnemonic for 'blank' */
DCL VAR(&TRUE) TYPE(*LGL) LEN(1) VALUE('1')
/* Mnemonic for 'true' */
DCL VAR(&FALSE) TYPE(*LGL) LEN(1) VALUE('0')
/* Mnemonic for 'false' */
DCL VAR(&STAR) TYPE(*CHAR) LEN(1) VALUE('*')
/* Mnemonic for 'asterisk' */
DCL VAR("E) TYPE(*CHAR) LEN(1) VALUE('''')
/* Mnemonic for 'quote' */
DCL VAR(&BATCH) TYPE(*CHAR) LEN(1) VALUE('0')
/* Mnemonic for 'batch job' */
DCL VAR(&INTER) TYPE(*CHAR) LEN(1) VALUE('1')
/* Mnemonic for 'interactive job' */
DCL VAR(&ZERO) TYPE(*DEC) LEN(1 0) VALUE(0)
/* Mnemonic for 'zero' */
DCL VAR(&HEX00) TYPE(*CHAR) LEN(2) VALUE(X'0000')
/* Mnemonic for 'binary zero' */
DCL VAR(&YES) TYPE(*CHAR) LEN(1) VALUE('Y')
/* Mnemonic for 'yes' */
DCL VAR(&NO) TYPE(*CHAR) LEN(1) VALUE('N')
/* Mnemonic for 'no' */
DCL VAR(&NULL) TYPE(*CHAR) LEN(1) VALUE(X'00')
/* Mnemonic for 'NULL' */
DCL VAR(&HEX20) TYPE(*CHAR) LEN(1) VALUE(X'20')
/* Mnemonic for X'20' */
DCL VAR(&HEX3F) TYPE(*CHAR) LEN(1) VALUE(X'3F')
/* Mnemonic for X'3F' */
DCL VAR(&HEX9F) TYPE(*CHAR) LEN(1) VALUE(X'9F')
/* Mnemonic for X'9F' */
DCL VAR(&GDS) TYPE(*CHAR) LEN(2) VALUE(X'12A0')
/* Mnemonic for General Data Stream - DSPT *//* */
/* ------------------- Copyright Declarations -------------------- */
/* */
DCL VAR(©RIGHT) TYPE(*CHAR) LEN(80) +
VALUE('Copyright (C) FlyByNight Software. +
1999, 2004.')/* */
/* -------------- Global Message Monitor Intercept --------------- */
/* */
MONMSG MSGID(CPF9999) EXEC(GOTO CMDLBL(FAILED))/* */
/* ---------- Force Copyright Notice in Executable Code ---------- */
/* */
CHGVAR VAR(©RIGHT) VALUE(©RIGHT)/* */
/* ----------------- Send the Copyright Notice ------------------- */
/* */
SNDPGMMSG MSG(©RIGHT) TOPGMQ(*SAME) /* Initialise error indicator */
CHGVAR VAR(&ERROR) VALUE(&FALSE) /* Point to run-time display file */
OVRDSPF FILE(SHWATRD1) TOFILE(SHWATRD2) LVLCHK(*NO) /* Use "save immediate" to retrieve the number of */
/* columns and screen size. */
CHGVAR VAR(&IO1) VALUE(X'00021518730402')
/* Ì */
SNDRCVF RCDFMT(USRDFNRCD) /* Save Immediate returns a "restore screen" 5250 */
/* command */ /* Check for a GDS header in case this is a DSPT */
/* screen */
IF COND(%SST(&IO1 3 2) *EQ &GDS) THEN(DO)
CHGVAR VAR(&ROW_POS) VALUE(&ROW_POS + 10)
CHGVAR VAR(&COL_POS) VALUE(&COL_POS + 10)
ENDDO /* Convert the number of rows to decimal */
CHGVAR VAR(&ROW) VALUE(%BIN(&HEX_ROW))
/* Convert the number of columns to decimal */
CHGVAR VAR(&COL) VALUE(%BIN(&HEX_COL))
/* Screen size = number_of_rows * number_of_columns */
CHGVAR VAR(&SIZE) VALUE(&ROW * &COL) /* Build "clear unit" and "write to display" commands */
/* -- If display size is *DS3 ... */
IF COND(&SIZE *EQ 1920) THEN(DO)
CHGVAR VAR(&OUT) +
VALUE(X'078D000373044004110008110101')
/* | | */
CHGVAR VAR(&INCREMENT) VALUE(15)
ENDDO
/* ... otherwise if display size is *DS4 ... */
ELSE CMD(IF COND(&SIZE *EQ 3564) THEN(DO))
CHGVAR VAR(&OUT) +
VALUE(X'0DFA00037304200004110008110101')
/* | | */
CHGVAR VAR(&INCREMENT) VALUE(16)
ENDDO
/* ... otherwise unknown display size ... */
/* --- usually a 5250 emulator problem --- */
/* or possibly trying to run on S/38 console */
ELSE CMD(DO)
/* */
/* @A1D IF COND(&ERROPT *EQ '*DFT') THEN(DO) */
/* Assume display size is *DS3 ... */
CHGVAR VAR(&OUT) +
VALUE(X'078D000373044004110008110101'
/* | | */
CHGVAR VAR(&INCREMENT) VALUE(15)
CHGVAR VAR(&ROW) VALUE(24)
CHGVAR VAR(&COL) VALUE(80)
CHGVAR VAR(&SIZE) VALUE(1920)
/* @A1D ENDDO */
/* @A1D ELSE CMD(DO) */
/* @A1D SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + */
/* @A1D MSGDTA('Screen size cannot be + */
/* @A1D determined. Emulator is not + */
/* @A1D building a correct Restore Screen + */
/* @A1D command') MSGTYPE(*ESCAPE) */
/* @A1D ENDDO */
ENDDO /* Use "read immediate" to get a snapshot of screen */
CHGVAR VAR(&IO1) VALUE(X'00021518730462')
/* | */
SNDRCVF RCDFMT(USRDFNRCD)
CHGVAR VAR(&IN) VALUE(&IO1 *CAT &IO2 *CAT &IO3) /* Initialise attribute byte */
CHGVAR VAR(&ATR) VALUE(&HEX9F) /* Loop for each byte in the input buffer ... */
CHGVAR VAR(&POS) VALUE(1)
LOOP: CHGVAR VAR(&CHAR) VALUE(%SST(&IN &POS 1)) /* If an attribute byte was found ... */
IF COND((&CHAR *GE &HEX20) *AND +
(&CHAR *LE &HEX3F)) THEN(DO)
/* Replace attribute with magic marker */
CHGVAR VAR(&CHAR) VALUE(&ATR)
ENDDO /* Calculate the output position ... */
CHGVAR VAR(&IDX) VALUE(&POS - 1 + &INCREMENT) /* Build the new screen ... */
CHGVAR VAR(%SST(&OUT &IDX 1)) VALUE(&CHAR)
CHGVAR VAR(&POS) VALUE(&POS + 1)
IF COND(&POS *LE &SIZE) THEN(DO)
GOTO CMDLBL(LOOP)
ENDDO /* Append "read input" command to display screen */
/* attribute data and wait for user action. */
CHGVAR VAR(&IDX) VALUE(&POS + &INCREMENT - 1)
CHGVAR VAR(%SST(&OUT &IDX 4)) VALUE(X'04420008')
/* | */
CHGVAR VAR(&IO1) VALUE(%SST(&OUT 1 1800))
CHGVAR VAR(&IO2) VALUE(%SST(&OUT 1801 1800))
CHGVAR VAR(&IO3) VALUE(%SST(&OUT 3601 1800))
SNDRCVF RCDFMT(USRDFNRCD)
EXIT: RETURN /* Normal end of program *//* */
/* --------------------- Exception Routine ----------------------- */
/* */
FAILED: STDERR PGMTYPE(*CPP)
MONMSG MSGID(CPF9999) /* Just in case */SHWATRX: ENDPGM
Regards, Simon Coulter. -------------------------------------------------------------------- FlyByNight Software AS/400 Technical Specialists
http://www.flybynight.com.au/ Phone: +61 3 9419 0175 Mobile: +61 0411 091 400 /"\ Fax: +61 3 9419 0175 \ / X ASCII Ribbon campaign against HTML E-Mail / \ --------------------------------------------------------------------
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
