0001.00
0002.00 FEMPPF IF E K DISK
0003.00
0004.00 * Function Keys
0005.00 D F_HELP C X'31'
F1 - KEY
0006.00 D F_EXIT C X'33'
F3 - KEY
0007.00
0008.00 * Program Constants
0009.00 D TEMP C X'20'
0010.00 D TEMP1 C X'00'
0011.00 D C_HEAD C CONST('EMPLOYEE
DETAILS')
0012.00
0013.00 * Work Variables
0014.00 D HEADTEXT S 128A
0015.00 D WSTEXT S 128A
0016.00 D WSEMPNO S LIKE(EMPNO)
0017.00 D WSEMPNAM S LIKE(EMPNAM)
0018.00 D WSEMPSEX S LIKE(EMPSEX)
0019.00 D WSEMPAGE S LIKE(EMPAGE)
0020.00 D WSEMPADDR1 S LIKE(EMPADDR1)
0021.00 D WSEMPADDR2 S LIKE(EMPADDR2)
0022.00 D WSEMPSTATE S LIKE(EMPSTATE)
0023.00 D WSEMPADDR S 55A
0024.00 D TEXTLENGTH S 9B 0 INZ(32)
0025.00 D ROW S 9B 0 INZ
0026.00 D COLUMN S 9B 0 INZ
0027.00 D ROWCNT S 9 0 INZ(6)
0028.00 D COL3 S 9 0 INZ(3)
0029.00 D COL7 S 9 0 INZ(7)
0030.00 D COL16 S 9 0 INZ(16)
0031.00 D COL26 S 9 0 INZ(26)
0032.00 D COL32 S 9 0 INZ(32)
0033.00 D COL35 S 9 0 INZ(35)
0034.00 D COL70 S 9 0 INZ(70)
0035.00 D ERROR S 8
INZ(x'0000000000000000')
0036.00 D AID S 1
0037.00 D LINES S 9B 0 inz(1)
0038.00 D WF1 S 1
0039.00 D SCREEN S 9B 0
0040.00
0041.00 * API to clear the screen
0042.00 D CLRSCREEN PR 9B 0 EXTPROC('QsnClrScr')
0043.00 D MODE 1A OPTIONS(*NOPASS)
CONST MODE
0044.00 D CMDBUFHNDLE 9B 0 OPTIONS(*NOPASS)
CONST COMMAND BUFFER HANDLE
0045.00 D LOWLVLENV 9B 0 OPTIONS(*NOPASS)
CONST LOW LEVEL ENVIRONMENT
0046.00 D ERRCDE 8A OPTIONS(*NOPASS)
ERROR CODE
0047.00
0048.00 * API to write data to the screen
0049.00 D WRTDATA PR 9B 0 EXTPROC('QsnWrtDta')
0050.00 D DATA 128
DATA TO BE WRITTEN
0051.00 D DATALEN 9B 0
LENGTH OF THE DATA
0052.00 D FEILDID 9B 0 OPTIONS(*NOPASS)
CONST FIELD ID
0053.00 D ROW 9B 0 OPTIONS(*NOPASS)
CONST ROW
0054.00 D COLUMN 9B 0 OPTIONS(*NOPASS)
CONST COLUMN
0055.00 D STRMATR 1A OPTIONS(*NOPASS)
CONST STARTING MONOCHROME ATTRIBUTE
0056.00 D ENDMATR 1A OPTIONS(*NOPASS)
CONST ENDING MONOCHROME ATTRIBUTE
0057.00 D STRCOLATR 1A OPTIONS(*NOPASS)
CONST STARTING COLOR ATTRIBUTE
0058.00 D ENDCOLATR 1A OPTIONS(*NOPASS)
CONST ENDING COLOR ATTRIBUTE
0059.00 D CMDBUFHNDLE 9B 0 OPTIONS(*NOPASS)
CONST COMMAND BUFFER HANDLE
0060.00 D LOWLVLENV 9B 0 OPTIONS(*NOPASS)
CONST LOW LEVEL ENVIRONMENT
0061.00 D ERRCDE 8A OPTIONS(*NOPASS)
ERROR CODE
0062.00
0063.00 D GetAID PR 1A EXTPROC('QsnGetAID')
0064.00 D AID 1A OPTIONS(*NOPASS)
0065.00 D ENV 9B 0 OPTIONS(*NOPASS)
CONST LOW LEVEL ENVIRONMENT
0066.00 D ERRCDE 8A OPTIONS(*NOPASS)
ERROR CODE
0067.00
0068.00 D RollUp PR 9B 0 EXTPROC('QsnRollUp')
0069.00 D LINES 9B 0
CONST
0070.00 D TOP 9B 0
CONST
0071.00 D BOTTOM 9B 0
CONST
0072.00 D CMDBUFHNDLE 9B 0 OPTIONS(*NOPASS)
CONST COMMAND BUFFER HANDLE
0073.00 D LOWLVLENV 9B 0 OPTIONS(*NOPASS)
CONST LOW LEVEL ENVIRONMENT
0074.00 D ERRCDE 8 OPTIONS(*NOPASS)
ERROR CODE
0075.00
0076.00
********************************************************************
0077.00
0078.00 *Clear Screen Subroutine
0079.00 C EXSR CLRSCR
0080.00 *Subroutine to write the Screen Headings
0081.00 C EXSR HEADSR
0082.00 *Subroutine to write the Screen Footer
0083.00 C EXSR FOOTSR
0084.00 *Subroutine to write the Data
0085.00 C EXSR WRTDTASR
0086.00
0087.00 C EVAL *INLR = *ON
0088.00 C RETURN
0089.00
0090.00
********************************************************************
0091.00 * Clear Screen Subroutine
0092.00 C CLRSCR BEGSR
0093.00
0094.00 * Call the CLRSCR procedure to clear the screen initially
0095.00 * The values passed are
0096.00 * Mode = 4, Set the screen to 27 * 132 mode
0097.00 * Command Buffer Handle = 0, Screen is cleared immediatly
0098.00 * Low Level Environment = 0, Default low level environment
is used
0099.00 * Error Code - To store the return error code
0100.00 C EVAL SCREEN = CLRSCREEN('4' : 0 :
0 : ERROR)
0101.00
0102.00 C CLRSCRE ENDSR
0103.00
0104.00
********************************************************************
0105.00
0106.00
********************************************************************
0107.00 * Subroutine to write the Headings
0108.00 C HEADSR BEGSR
0109.00 *Write the Screen Heading for the first time
0110.00 C EVAL HEADTEXT = C_HEAD
0111.00 C EVAL ROW = 2
0112.00 C EVAL COLUMN = 25
0113.00 C EXSR WRTHEADSR
0114.00
0115.00 C EVAL HEADTEXT = '================'
0116.00 C EVAL ROW = 3
0117.00 C EVAL COLUMN = 25
0118.00 C EXSR WRTHEADSR
0119.00
0120.00 *Write the Column Heading
0121.00 C EVAL HEADTEXT = 'EMP NAME'
0122.00 C EVAL ROW = 4
0123.00 C EVAL COLUMN = 3
0124.00 C EXSR WRTHEADSR
0125.00
0126.00 C EVAL HEADTEXT = '==========='
0127.00 C EVAL ROW = 5
0128.00 C EVAL COLUMN = 3
0129.00 C EXSR WRTHEADSR
0130.00
0131.00 C EVAL HEADTEXT = 'EMP SEX'
0132.00 C EVAL ROW = 4
0133.00 C EVAL COLUMN = 16
0134.00 C EXSR WRTHEADSR
0135.00
0136.00 C EVAL HEADTEXT = '==========='
0137.00 C EVAL ROW = 5
0138.00 C EVAL COLUMN = 16
0139.00 C EXSR WRTHEADSR
0140.00
0141.00 C EVAL HEADTEXT = 'EMP ADDRESS'
0142.00 C EVAL ROW = 4
0143.00 C EVAL COLUMN = 32
0144.00 C EXSR WRTHEADSR
0145.00
0146.00 C EVAL HEADTEXT = '==========='
0147.00 C EVAL ROW = 5
0148.00 C EVAL COLUMN = 32
0149.00 C EXSR WRTHEADSR
0150.00
0151.00 C EVAL HEADTEXT = 'EMP STATE'
0152.00 C EVAL ROW = 4
0153.00 C EVAL COLUMN = 70
0154.00 C EXSR WRTHEADSR
0155.00
0156.00 C EVAL HEADTEXT = '========='
0157.00 C EVAL ROW = 5
0158.00 C EVAL COLUMN = 70
0159.00 C EXSR WRTHEADSR
0160.00
0161.00 C HEADSRE ENDSR
0162.00
0163.00
********************************************************************
0164.00
0165.00
********************************************************************
0166.00 * Subroutine to write the Screen Footer
0167.00 C FOOTSR BEGSR
0168.00 C EVAL HEADTEXT = 'F1-Help'
0169.00 C EVAL ROW = 25
0170.00 C EVAL COLUMN = 5
0171.00 C EVAL SCREEN =
WRTDATA(HEADTEXT:TEXTLENGTH:0:ROW:
0172.00 C
COLUMN:TEMP:TEMP:TEMP:TEMP:0:0:ERROR)
0173.00
0174.00 C EVAL HEADTEXT = 'F3-Exit'
0175.00 C EVAL ROW = 25
0176.00 C EVAL COLUMN = 17
0177.00 C EVAL SCREEN =
WRTDATA(HEADTEXT:TEXTLENGTH:0:ROW:
0178.00 C
COLUMN:TEMP:TEMP:TEMP:TEMP:0:0:ERROR)
0179.00
0180.00 C EVAL HEADTEXT = 'F6-Add'
0181.00 C EVAL ROW = 25
0182.00 C EVAL COLUMN = 31
0183.00 C EVAL SCREEN =
WRTDATA(HEADTEXT:TEXTLENGTH:0:ROW:
0184.00 C
COLUMN:TEMP:TEMP:TEMP:TEMP:0:0:ERROR)
0185.00
0186.00 C FOOTSRE ENDSR
0187.00
0188.00
********************************************************************
0189.00
0190.00
********************************************************************
0191.00 * Subroutine to write the Data
0192.00 C WRTDTASR BEGSR
0193.00
0194.00 C READ EMPR
90
0195.00 C DOW *IN90 = *OFF
0196.00
0197.00 C EVAL WSTEXT = EMPNAM
0198.00 C EVAL TEXTLENGTH = %LEN(EMPNAM)
0199.00 C EVAL ROW = ROWCNT
0200.00 C EVAL COLUMN = COL3
0201.00 C EXSR DATASR
0202.00
0203.00 C EVAL WSTEXT = EMPSEX
0204.00 C EVAL TEXTLENGTH = %LEN(EMPSEX)
0205.00 C EVAL ROW = ROWCNT
0206.00 C EVAL COLUMN = COL16
0207.00 C EXSR DATASR
0208.00
0209.00 C EVAL WSEMPADDR1 = EMPADDR1
0210.00 C EVAL WSEMPADDR2 = EMPADDR2
0211.00 C EVAL WSEMPADDR = WSEMPADDR1 +
WSEMPADDR2
0212.00 C EVAL WSTEXT = WSEMPADDR
0213.00 C EVAL TEXTLENGTH = %LEN(WSEMPADDR)
0214.00 C EVAL ROW = ROWCNT
0215.00 C EVAL COLUMN = COL32
0216.00 C EXSR DATASR
0217.00
0218.00 C EVAL WSTEXT = EMPSTATE
0219.00 C EVAL TEXTLENGTH = %LEN(EMPSTATE)
0220.00 C EVAL ROW = ROWCNT
0221.00 C EVAL COLUMN = COL70
0222.00 C EXSR DATASR
0223.00
0224.00 C READ EMPR
90
0225.00 C EVAL ROWCNT = ROWCNT + 1
0226.00 C ENDDO
0227.00 C* EVAL SCREEN =
ROLLUP(LINES:1:24:0:0:ERROR)
0228.00
0229.00 C EVAL WF1 = GETAID (AID : 0 :
ERROR)
0230.00 C IF AID = F_EXIT
0231.00 C EVAL *INLR = *ON
0232.00 C ENDIF
0233.00
0234.00 C WRTDTASRE ENDSR
0235.00
0236.00
********************************************************************
0237.00 * Subroutine to write the Data
0238.00 C DATASR BEGSR
0239.00
0240.00 C EVAL SCREEN =
WRTDATA(WSTEXT:TEXTLENGTH:0:ROW:
0241.00 C
COLUMN:TEMP:TEMP:TEMP:TEMP:0:0:ERROR)
0242.00
0243.00 *Clear the work variables
0244.00 C MOVE *ZEROS TEXTLENGTH
0245.00 C MOVE *ZEROS WSEMPNO
0246.00 C MOVE *BLANKS WSTEXT
0247.00 C MOVE *BLANKS WSEMPADDR1
0248.00 C MOVE *BLANKS WSEMPADDR2
0249.00 C MOVE *BLANKS WSEMPADDR
0250.00 C MOVE *BLANKS WSEMPSTATE
0251.00 C MOVE *BLANKS WSEMPNAM
0252.00 C MOVE *BLANKS WSEMPSEX
0253.00
0254.00 C DATASRE ENDSR
0255.00
0256.00
********************************************************************
0257.00
********************************************************************
0258.00 * Subroutine to write the Headers
0259.00 C WRTHEADSR BEGSR
0260.00
0261.00 C EVAL SCREEN =
WRTDATA(HEADTEXT:TEXTLENGTH:0:ROW:
0262.00 C
COLUMN:TEMP:TEMP:TEMP:TEMP:0:0:ERROR)
0263.00 C EVAL HEADTEXT = *BLANKS
0264.00
0265.00 C WRTHEADSRE ENDSR
0266.00
****************** End of data
***********************************************************
EMPPF - Physical File
0001.00 A UNIQUE
0002.00 A R EMPR
0003.00 A EMPNO 5P 0
0004.00 A EMPNAM 20A
0005.00 A EMPSEX 1A
0006.00 A EMPAGE 3P 0
0007.00 A EMPADDR1 25A
0008.00 A EMPADDR2 25A
0009.00 A EMPSTATE 10A
0010.00 A K EMPNO
This was first published in April 2005