pls say which type of subfile is this ? single page . page by page sub file .... or! ?? 
i can load more than 9999 record to this subfile without error but if i press more than 9999 times page down button - subfile is dump!
thanks
dhanuxp

i can load more than 9999 record to this subfile without error but if i press more than 9999 times page down button - subfile is dump!
Code:
H DEBUG DATEDIT(*YMD) TIMFMT(*HMS)
FPAY01L00 IF E K DISK
FTESTSUB01 CF E WORKSTN INFDS(WSDS)
F SFILE(SFL:SFLRN)
D @F01 C CONST(X'31')
D @F02 C CONST(X'32')
D @F03 C CONST(X'33')
D @F04 C CONST(X'34')
D @F05 C CONST(X'35')
D @F06 C CONST(X'36')
D @F07 C CONST(X'37')
D @F08 C CONST(X'38')
D @F09 C CONST(X'39')
D @F10 C CONST(X'3A')
D @F11 C CONST(X'3B')
D @F12 C CONST(X'3C')
D @F13 C CONST(X'B1')
D @F14 C CONST(X'B2')
D @F15 C CONST(X'B3')
D @F16 C CONST(X'B4')
D @F17 C CONST(X'B5')
D @F18 C CONST(X'B6')
D @F19 C CONST(X'B7')
D @F20 C CONST(X'B8')
D @F21 C CONST(X'B9')
D @F22 C CONST(X'BA')
D @F23 C CONST(X'BB')
D @F24 C CONST(X'BC')
D @CLEAR C CONST(X'BD')
D @ENTER C CONST(X'F1')
D @HELP C CONST(X'F3')
D @PAGUP C CONST(X'F4')
D @PAGDN C CONST(X'F5')
D @PRINT C CONST(X'F6')
*
**----------------------------------------------------------------*
** Standard include for all interactive programs *
** Defines standard constants *
**================================================================*
*
D @FALSE C CONST('0')
D @TRUE C CONST('1')
D @FOLD C CONST('0')
D @DROP C CONST('1')
*
**----------------------------------------------------------------*
** Standard include for all interactive programs *
** display file information data structure *
**================================================================*
*
D WSDS DS
** Identifies the key pressed
D KEY 369 369
D PAGRRN 378 379B 0
D CURSOR 370 371B 0
D DS INZ
** Identifies the subfile page rrn
D STKCNT 1 4B 0
D DTALEN 5 8B 0
D ERRCOD 9 12B 0
** GET Local user ID.
D SDS
D USER 254 263
*
**----------------------------------------------------------------*
** Body of the program *
**================================================================*
*
C Reset @Exit
C Reset SFMODE
C Exsr @Reset
C Move @FALSE *IN99
C *LOVAL Setll PAY01R
C READ PAY01R
C Exsr @Load
C Exsr Msfsnd
C If NOT %EOF(PAY01L00)
C Eval *IN99 = @false
C Endif
*
C*
C*
C @EXIT DOWEQ @FALSE
C Write SFLHDR
C Write SFLCMD
C Write MSGCTL
C EXFMT SFLCTL
C Exsr Msfclr
C EVAL SFLPS = PAGRRN
*
C KEY CASEQ @F03 @F03SR
C KEY CASEQ @F05 @F05SR
C KEY CASEQ @F06 @F06SR
C KEY CASEQ @F12 @F12SR
C KEY CASEQ @PAGDN @PgDown
C KEY CASEQ @ENTER @Entky
C ENDCS
C ENDDO
C Eval *INLR = @TRUE
*
C *INZSR BEGSR
C Move @False @Exit 1
C Z-add 0 SFLRN 4 0
C Z-add 0 ENDRN 4 0
C Z-add 1 SFLPS
C Move @DROP SFMODE
C Move 'PAY0000' Msgid
C Movel 'PAYMSGF ' Msgf 20
C Movel '*LIBL' Msglib 10
C Move Msglib Msgf
C Move *Blanks Msgdta 80
C Movel '*DIAG' Msgtyp 10
C Movel '*' Pgmq
C Move *Blanks Msgky 4
C Movel '*ALL' Msgrmv 10
*
C ENDSR
C Msfsnd Begsr
*
C Call 'QMHSNDPM'
C Parm Msgid 7
C Parm Msgf
C Parm Msgdta
C Parm Dtalen
C Parm Msgtyp
C Parm Pgmq
C Parm Stkcnt
C Parm Msgkey
C Parm Errcod
C Move *Blanks Msgdta
C Z-add *Zeros Dtalen
*
C Endsr
*
**----------------------------------------------------------------*
** Clear message subfile *
**================================================================*
*
C Msfclr Begsr
*
C CALL 'QMHRMVPM'
C Parm Pgmq
C Parm Stkcnt
C Parm Msgky
C Parm Msgrmv
C Parm Errcod
*
C Endsr
*
**----------------------------------------------------------------*
** @Reset Subroutine *
**================================================================*
*
C @Reset Begsr
C Move @TRUE *In40
C Write SFLCTL
C Move @FALSE *In40
C Move @FALSE *In42
C Reset SFLRN
C Reset ENDRN
C Endsr
*
**----------------------------------------------------------------*
** @Load Subroutine *
**================================================================*
*
C @Load Begsr
C Z-add SFLRN SFLPS
C Eval SFLPS = SFLPS +1
C DO 15
*
C If %EOF(PAY01L00)
C Eval *IN99 = @TRUE
C Leave
*
C Else
C Eval Optd = *Blanks
C Eval Empno01D = Empno01
C Eval Name01D = Name01
C Eval SFLRN = SFLRN +1
C Write SFL
C Endif
C Read PAY01R
C ENDDO
C Eval ENDRN = SFLRN
C If SFLRN = *zeros
C Eval *IN42 = @FALSE
C Write NOREC
C else
C Eval *IN42 = @TRUE
*pageup....
C If SFLPS > SFLRN
C Eval SFLPS = SFLRN
C Endif
C Endif
*
C Endsr
*
C @F03SR Begsr
C EVAL @EXIT ='1'
C Endsr
C @F12SR Begsr
C EVAL @EXIT ='1'
C Endsr
*
C @Entky Begsr
C If EMPNO01DT <> 0
C Eval *IN99 = @false
C EMPNO01DT Setll PAY01R
C READ PAY01R
C Eval EMPNO01DT = 0
C Exsr @Refresh
C else
*
C if CSRPOS <> 0
C z-add csrpos sflps
C endif
*
*select options value
*
C z-add *zeros SUBNUM 4 0
C z-add ENDRN SUBREC 4 0
C move '0' MSGSTAT 1
C DO SUBREC
C ADD 1 SUBNUM
C SUBNUM CHAIN SFL
C if optd <> *blanks
C z-add SUBNUM SFLPS
C endif
*
C if (optd = ' 2') or (optd ='2')
C call 'MAIN2'
C PARM EMPNO01D
C endif
C if (optd <>' 2') or (optd<>'2')
C move '1' msgstat
C endif
C enddo
C if msgstat = '1'
C move 'PAY0001' msgid
C exsr msFsnd
C endif
C endif
C
C Endsr
*
C @PgDown Begsr
C If Not %EOF(PAY01L00)
C eval *in99 = @false
C Eval XROW = 0
C Eval XCOL = 0
C Eval SFLRN = ENDRN
C Exsr @Load
c else
C eval *in99 = @true
C endif
C Endsr
*
C @Refresh Begsr
C Eval SFLRN = 0
C Eval ENDRN = 0
C Eval SFLPS = 1
C Move @DROP SFMODE
C Reset @EXIT
C Reset SFMODE
C Exsr @Reset
C Exsr @Load
C endsr
*
C @F05SR Begsr
C Eval *IN99 = @false
C *LOVAL Setll PAY01R
C READ PAY01R
C Eval EMPNO01DT = 0
C Exsr @Refresh
C Endsr
*
C @F06SR Begsr
* call 'TEST02R'
C Endsr
dhanuxp









Comment