home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
busi
/
rqm.zip
/
RQMSMPL4.DTA
< prev
Wrap
Text File
|
1990-10-15
|
12KB
|
316 lines
%(), Element%, SegPtr%, OffPtr%)
DECLARE SUB VWindow (Lines$(), LineLen, FldNo)
DECLARE SUB VerEdScreen (RetArray$(), FirstFld%, LastFld%, FldNo%, FCode$, FChanged%, index%, YrsTo90%, curpos%)
'----- The following arrays are mandatory -------------------------------
REDIM ScrnArray(1) 'holds the library of screens
REDIM FormArray(1) 'holds the field definitions
REDIM ScrBuf(2000) 'saves screen during multiple choice
DIM Choice$(1, 1) 'must include
'------------------------------------------------------------------------
DIM SHARED Col!(1 TO 10, -1 TO 70)
DIM SHARED FileName$
DIM SHARED HelpFlag
DIM SHARED index%(-1 TO 70)
DIM SHARED Lines$(9)
DIM SHARED Page%
DIM SHARED Pr$(9)
DIM SHARED Rec$(20)
DIM SHARED RecNum%
DIM SHARED ScrnName$
DIM SHARED Value$(10)
DIM SHARED Value#(80)
DIM Lib(1)
DIM Item$(5)
DEF SEG = 0 'look in low memory
IF (PEEK(1040) AND 48) = 48 THEN 'check the monitor type
LOCATE , , 0, 0, 7 'the mono cursor size if Pause is used
ELSE
LOCATE , , 0, 1, 6 'color cursor size
END IF
'****** MenuOne lines *********
'****** prompt lines
Pr$(1) = " F1= Help "
Pr$(2) = " F1= Help F3= Recalc"
Pr$(3) = " F1= Help F2= Menu F3= Recalc F6= Erase Page F10= Next Screen"
Pr$(4) = " F1= Help F2= Menu F3= Recalc F9= Prev Screen"
Pr$(5) = " F1= Help F3= Recalc F6= Erase Page F9= Prev Screen F10= Next Screen"
Pr$(7) = " F1= Intro F2= Menu"
Pr$(8) = " Edit the form as necessary. Press <Esc> when finished"
'----------- Set initial values
'LibName$ = "Ver1scr"
LibName$ = "Ver2scr"
'-----------------Executable code starts here_____________________
'restart:
CLS
'----- Load the library and field definitions
CALL LoadLib(LibName$, ErrFlag) 'load the one library for this prgm
IF ErrFlag THEN
PRINT "The Screen formats are not on this disk"
END
END IF
'_________ Title screen
IF F2Flag = 0 THEN
ScrnName$ = "Title1"
CALL DisplayScrn(ScrnName$, ErrFlag)
SLEEP (15): keyhit$ = INKEY$
CLS
END IF
'_____ Define F1 as event (Help)
ON KEY(1) GOSUB Help
KEY(1) ON
'---------- Initial display
CALL PageOne(RecNum%, Rec$(), F2Flag)
DO 'PRIMARY DO-LOOP to wait for a key
' LOCATE 25, 60: PRINT "Pg/Flag="; Page%; "/"; F2Flag;
DO
keyhit$ = INKEY$
LOOP UNTIL keyhit$ <> ""
'------ Check for special keys and establish scancode% for Pages
IF LEFT$(keyhit$, 1) = CHR$(0) THEN
scancode% = ASC(RIGHT$(keyhit$, 1))
IF scancode% = 60 THEN 'F2 menu key
LOCATE 25, 1: PRINT SPACE$(80); 'clears line 25
IF Page% = 1 THEN
CALL Pg1Menu(Choice, F2Flag)
ELSEIF Page% = 3 THEN
CALL Pg3Menu(Choice, F2Flag)
END IF
KEY(1) ON
ELSEIF scancode% = 61 AND RecNum% <> 0 THEN 'F3 same screen
CALL Pages(Page%, scancode%)
ELSEIF scancode% = 64 AND RecNum% <> 0 THEN 'F6 erase screen
CALL Pages(Page%, scancode%)
ELSEIF scancode% = 68 AND RecNum% <> 0 THEN 'F10 next screen
CALL Pages(Page%, scancode%)
' ELSEIF scancode% = 66 AND RecNum% <> 0 THEN 'F8 temp exit
' END
ELSEIF scancode% = 67 AND RecNum% <> 0 THEN 'F9 prev screen
CALL Pages(Page%, scancode%)
ELSEIF scancode% = 47 AND RecNum% <> 0 THEN 'hidden ver #
IF Page% = 1 THEN
LOCATE 25, 1: PRINT "Ver. 1.1 Copyright 1990 Rod Hoisington. s/n XXXXXXX. Dated 10-1-90";
DO: LOOP UNTIL LEN(INKEY$)
LOCATE 25, 1: PRINT SPACE$(80); 'clears line 25
END IF
END IF
END IF
LOOP
END
Help:
' ********** Display the Help Screens
IF HelpFlag = 0 THEN CALL ScrSave
CALL Help(Page%, F2Flag%, LastFld)
IF HelpFlag = 0 THEN CALL ScrRest(1, 25)
RETURN
'*********** Error Routines (activate before compiling)
handler1: ' for page3 calc
SELECT CASE ERR
CASE 6 'overflow
LOCATE 25, 1: CALL MQPrint(SPACE$(80), -1)
LOCATE 25, 1: CALL MQPrint(" Overlimit - please wait ", -1)
RESUME NEXT
CASE 11 'division by zero
LOCATE 25, 1: CALL MQPrint(SPACE$(80), -1)
LOCATE 25, 1: CALL MQPrint("Division by zero", -1)
RESUME NEXT
CASE ELSE 'temp leave in runtime
ON ERROR GOTO 0
END SELECT
handler2: 'for PrtPlan
SELECT CASE ERR
CASE 24
COLOR 7, 0 'required
CLS
LOCATE 10, 11: COLOR 7, 0
PRINT "Device timeout.":
DO: LOOP UNTIL LEN(INKEY$)
' PRINT " or press <ESC> to restart ":
' DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
' IF keyhit$ = CHR$(27) THEN F2Flag = 9': GOTO RESTART
' IF RecNum% = 99 THEN F2Flag = 3 'skip Choices
RESUME NEXT
CASE 25
COLOR 7, 0 'required
CLS
LOCATE 10, 11: COLOR 7, 0
PRINT "Turn Printer on, then press any key to continue.":
DO: LOOP UNTIL LEN(INKEY$)
' PRINT " or press <ESC> to restart ":
' DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
' IF keyhit$ = CHR$(27) THEN F2Flag = 9: GOTO restart
' IF RecNum% = 99 THEN F2Flag = 3 'skip Choices
RESUME
CASE 27
COLOR 7, 0 'required
CLS
LOCATE 10, 11: COLOR 7, 0
PRINT "Out of paper. Correct and press any key to continue.":
DO: LOOP UNTIL LEN(INKEY$)
' PRINT " or press <ESC> to restart ":
' DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
' IF keyhit$ = CHR$(27) THEN F2Flag = 9': GOTO RESTART
' IF RecNum% = 99 THEN F2Flag = 3 'skip Choices
RESUME
CASE 68
COLOR 7, 0 'required
CLS
LOCATE 10, 11: COLOR 7, 0
PRINT "Turn Printer on, then press any key to continue.":
DO: LOOP UNTIL LEN(INKEY$)
' PRINT " or press <ESC> to restart ":
' DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
' IF keyhit$ = CHR$(27) THEN F2Flag = 9: GOTO restart
' IF RecNum% = 99 THEN F2Flag = 3 'skip Choices
RESUME
CASE ELSE 'temp leave in runtime
COLOR 7, 0 'required
CLS
LOCATE 10, 11: COLOR 7, 0
PRINT "A system error occurred, #" + STR$(ERR)
DO: LOOP UNTIL LEN(INKEY$)
ON ERROR GOTO 0
END SELECT
END
SUB Help (Page%, F2Flag%, LastFld)
KEY(1) OFF
'LastFld not xferring from PageOne to this module - fix later
' IF LastFld = 0 THEN LastFld = 1
row = CSRLIN 'saves position
IF row = 25 THEN row = 24
Col = POS(0) 'saves position
IF Col = 1 THEN Col = 80
CALL ScrSave
CLS
IF Page% <= 1 AND F2Flag = 0 THEN
LOCATE , , 0
ScrnName$ = "Intro1"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
ScrnName$ = "Intro2"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
CLS
Choice = 1
CALL ScrRest(1, 25)
' LOCATE row, Col, 1 'restores position
KEY(1) ON
EXIT SUB
ELSEIF Page% <= 1 THEN
LOCATE , , 0
ScrnName$ = "Helppg1"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
CLS
Choice = 1
CALL ScrRest(1, 25)
LOCATE row, Col, 1 'restores position
KEY(1) ON
EXIT SUB
ELSEIF Page% = 2 THEN
LOCATE , , 0
ScrnName$ = "Helppg2"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
CLS
Choice = 1
CALL ScrRest(1, 25)
LOCATE row, Col, 1 'restores position
KEY(1) ON
EXIT SUB
ELSEIF Page% = 3 THEN
LOCATE , , 0
backto1:
ScrnName$ = "Helppg3a"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
IF LEFT$(keyhit$, 1) = CHR$(0) THEN
scancode% = ASC(RIGHT$(keyhit$, 1))
IF scancode% = 59 THEN 'F1 again
backto2:
ScrnName$ = "Helppg3b"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
IF keyhit$ = CHR$(27) THEN GOTO backto1
END IF
END IF
IF LEFT$(keyhit$, 1) = CHR$(0) THEN
IF scancode% = 59 THEN 'F1 again
ScrnName$ = "Helppg3c"
CALL DisplayScrn(ScrnName$, ErrFlag)
DO: keyhit$ = INKEY$: LOOP UNTIL keyhit$ <> ""
IF keyhit$ = CHR$(27) THEN GOTO backto2
END IF
END IF
CLS
Choice = 1
CALL ScrRest(1, 25)
KEY(1) ON
EXIT SUB
END IF
END SUB
'*************************** SUB PageOne ***************************
SUB PageOne (RecNum%, Rec$(), F2Flag)
'-----------------------------------
' F2flag = 0 -
' F2flag = 1 load record -
' F2flag = 2 create record -
' F2flag = 3 demo -
' F2flag = 4 display loaded record then exit -
' F2flag = 5 appendix -
' F2flag = 6 erase page -
' F2flag = 7 used in PrtPlan -
' F2flag = 9 loaded record-skip choices -
' F2flag = 10 #1 pension has cola
' F2flag = 11 #2 pension has cola
'------------------------------------
STATIC LastChoice%
SHARED FormArray()
SHARED Item$()
'----- The following arrays are mandatory
REDIM ScrnArray(1) 'holds the library of screens
REDIM FormArray(1) 'holds the field definitions
REDIM ScrBuf(2000) 'saves screen during multiple choice
DIM Choice$(1, 1) 'must include
'----------------------------------------
DIM amt$(50)
DIM amt#(50)
DIM cnt%(50)
DIM NumRecs%(20)
DIM RecLen
'**
" % ' ) Mr. Retiree These three additional lines are available for comments if desired.