1890 lines
65 KiB
Plaintext
1890 lines
65 KiB
Plaintext
|
******************************************************************************* *
|
||
|
|
* uniVerse port of PI/open ENTRO subroutine
|
||
|
|
*
|
||
|
|
* Module %M% Version %I% Date %H%
|
||
|
|
*
|
||
|
|
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
|
||
|
|
* This is unpublished proprietary source code of Ardent Software Inc.
|
||
|
|
* The copyright notice above does not evidence any actual or intended
|
||
|
|
* publication of such source code.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* Maintenance log - insert most recent change descriptions at top
|
||
|
|
*
|
||
|
|
* Date.... GTAR# WHO Description.........................................
|
||
|
|
* 10/14/98 23801 SAP Change copyrights.
|
||
|
|
* 04/15/96 18272 LDG Distinguish bad conv check message from pattern
|
||
|
|
* 07/13/95 16907 EAP Use UNISEQ() for NLS support
|
||
|
|
* 05/18/95 15741 EAP Added error message for NLS write errors
|
||
|
|
* 05/16/95 15741 EAP Added error message for NLS unmappable Ids
|
||
|
|
* 09/15/93 12031 PVW Handle "top" to be the same as "TOP"
|
||
|
|
* 07/02/93 11778 PVW Handle insert syntax >#n correctly
|
||
|
|
* 07/01/93 11772 PVW Handling of SQL NULL character fixed
|
||
|
|
* 06/29/93 11741 PVW Handle SQL Integrity Constraint Violations
|
||
|
|
* 06/01/93 11645 PVW Remove DEVSYS.STRIPSTRS.MODE from code
|
||
|
|
* 02/23/93 11107 PVW Fix revise handling of sql null.
|
||
|
|
* 02/19/93 11008 PVW Put check on readu of invalid part file records.
|
||
|
|
* 01/27/93 10953 PVW Let NULL string be entered where a conversion
|
||
|
|
* code is specified as valid data.
|
||
|
|
* 01/04/92 10800 PVW Accept upper and lower case commands.
|
||
|
|
* 12/31/92 10213 PVW Set DEVSYS.STRIPSTRS.MODE to "Revise"
|
||
|
|
* 12/07/92 10213 PVW Change INMAT statements and upcase(top)
|
||
|
|
* 12/03/92 10213 PVW Make page length fo discussions term depth.
|
||
|
|
* 12/03/92 10213 PVW Change REVISE.CHANGE(L) to REVISE*CHANGE(L).
|
||
|
|
* 11/12/92 10213 PVW Port PI/open ENTRO to replace uniVerse REVISE.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
|
||
|
|
$OPTIONS INFORMATION
|
||
|
|
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE VERBINSERT.H
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE SYMBOL.TBL.H
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE UV.COM
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE KEYWORD.H
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE REVISE.H
|
||
|
|
|
||
|
|
@SYSTEM.SET = 0
|
||
|
|
STRIPSTRINGS = '-STRIPSTRINGS'
|
||
|
|
FINDFILE = '-FINDFILE'
|
||
|
|
EXPAND = '-EXPAND'
|
||
|
|
SQLINTCHK = '-SQLINTCHK'
|
||
|
|
|
||
|
|
EQU IntegrityViolation TO -3
|
||
|
|
EQU UpdateExisting TO 1
|
||
|
|
EQU UpdateNew TO 2
|
||
|
|
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* The following lines of code are included to setup this program
|
||
|
|
* with the same input as the PI/open ENTRO.B subroutine receives
|
||
|
|
* from the PI/open command line processor PERFORM.B.
|
||
|
|
*
|
||
|
|
* SUBROUTINE REVISE (SENTENCE, MAT SYMBOLS)
|
||
|
|
*
|
||
|
|
DIM SYMBOLS (VALSTART + MAXTOKENS)
|
||
|
|
|
||
|
|
SENTENCE = @SENTENCE
|
||
|
|
SENTENCE = TRIMF(SENTENCE)
|
||
|
|
TOKEN.1 = FIELD(SENTENCE," ",1)
|
||
|
|
IF TOKEN.1 = "RUN" OR TOKEN.1 = "RAID" THEN
|
||
|
|
SENTENCE = FIELD(SENTENCE," ",3,9999)
|
||
|
|
END
|
||
|
|
|
||
|
|
MAT SYMBOLS = ''
|
||
|
|
|
||
|
|
SYMBOLS (NEXT.TKN.VALUE) = VALSTART
|
||
|
|
SYMBOLS (ORIGINAL.SENTENCE) = SENTENCE
|
||
|
|
|
||
|
|
OPEN "VOC" TO DEVSYS.VOC.FILE ELSE
|
||
|
|
CALL *UVPRINTMSG(001752,"")
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
|
||
|
|
DEVSYS.FILE.FOUND = 0
|
||
|
|
DEVSYS.DICT.SWITCH = 0
|
||
|
|
|
||
|
|
IF INDEX(SENTENCE,'"',1) + INDEX(SENTENCE,"'",1) THEN
|
||
|
|
CALL @STRIPSTRINGS (SENTENCE, MAT SYMBOLS)
|
||
|
|
END
|
||
|
|
|
||
|
|
HOLD.SENTENCE = SENTENCE
|
||
|
|
ERROR.CODE = 0
|
||
|
|
|
||
|
|
CALL @FINDFILE (HOLD.SENTENCE, MAT SYMBOLS, ERROR.CODE)
|
||
|
|
|
||
|
|
IF ERROR.CODE THEN GO 9920
|
||
|
|
|
||
|
|
POS = SYMBOLS (NEXT.TKN.VALUE)
|
||
|
|
SYMBOLS (VERB) = FIELD(SENTENCE,' ',1):@VM:POS
|
||
|
|
SYMBOLS (NEXT.TKN.VALUE) += 1
|
||
|
|
SYMBOLS (POS) = '-REVISE':@FM:'IN'
|
||
|
|
OUTBUF = CHAR(VERB):POS
|
||
|
|
|
||
|
|
HOLD.SENTENCE = FIELD(HOLD.SENTENCE, ' ', 2, 9999)
|
||
|
|
IF HOLD.SENTENCE # '' THEN
|
||
|
|
CALL @EXPAND (HOLD.SENTENCE, OUTBUF, MAT SYMBOLS, ERROR.CODE)
|
||
|
|
IF ERROR.CODE THEN GO 9920
|
||
|
|
SENTENCE = OUTBUF
|
||
|
|
END
|
||
|
|
|
||
|
|
*******************************************************************************
|
||
|
|
!
|
||
|
|
* S T A N D A R D F I E L D V A R I A B L E S
|
||
|
|
!
|
||
|
|
* TERMINAL CONTROL CHARACTERS
|
||
|
|
*
|
||
|
|
PROMPT ' '
|
||
|
|
* SUBROUTINE ENTRY POINTS
|
||
|
|
IP = 1 ; *PROMPT ENTRY POINT FOR PROMPTER
|
||
|
|
EP = 2 ; *ERROR MESSAGE ENTRY POINT FOR PROMPTER
|
||
|
|
* STANDARD RESPONSES
|
||
|
|
STD.RESP0=@FM:@FM:RV$CMD.TOP:@FM:RV$CMD.HELP:@FM:RV$CMD.EXTENDED.HELP:@FM:RV$CMD.PROMPT:@FM:RV$CMD.REDRAW:@FM:RV$CMD.SKIP:@FM ; *006
|
||
|
|
STD.RESP = STD.RESP0:RV$CMD.DELETE:@FM ; *006
|
||
|
|
STD2.RESP=@FM:@FM:'>':@FM:'##':@FM:'"':@FM ; * SECOND SCREEN CONVENTIONS ;*006
|
||
|
|
* ARRAYS
|
||
|
|
ITYPE = '' ; * ITYPE FLAG FOR TESTING ITYPES FOR PI/PC PRT ;*009
|
||
|
|
DTYPE = '' ; * DTYPE FLAG FOR TESTING DTYPES FOR PI/PC PRT ;*009
|
||
|
|
MAX.PMTS = 50
|
||
|
|
DIM D.D(MAX.PMTS),INP(MAX.PMTS),RFMT(MAX.PMTS),LFMT(MAX.PMTS),CV(MAX.PMTS),LAST.IN(MAX.PMTS),OLD(MAX.PMTS)
|
||
|
|
DIM VERIFILE(MAX.PMTS),VERIFY(MAX.PMTS),LAST.INPUT(MAX.PMTS),START.SCR(10),END.SCR(10)
|
||
|
|
DIM MACRO(2), ITEM.ARRAY(50) ; * ITEM.ARRAY is used with CLEAR.OPCODES;*009
|
||
|
|
; * routine ;*009
|
||
|
|
CHANGE=@AM:'CHANGE':@AM:@AM:'(1,99)':@SVM:'"DELETE"'
|
||
|
|
CHANGE:=@SVM:'"TOP"':@SVM:'"?"':@SVM:'"QUIT"':@AM:'O':@AM:@AM:@AM:@AM:@AM
|
||
|
|
CHG = UVREADMSG(001585,"")
|
||
|
|
CHANGE := CHG
|
||
|
|
10:* OPEN FILES AND BEGIN PROCESSING
|
||
|
|
WDN=2
|
||
|
|
FNAME=''
|
||
|
|
PROCESS=''
|
||
|
|
DICT=''
|
||
|
|
NEXT.AVAILABLE=0 ; * FLAG TO USE NEXT AVAILABLE SEQUENTIAL ID
|
||
|
|
ADD.FLAG=1 ; * FLAG FOR WINDOW LOGIC ALSO ENFORCES REQUIRED PROMPTING
|
||
|
|
NO.WDS=COUNT(SENTENCE,' ')+1
|
||
|
|
IF FIELD(SENTENCE,' ',2) EQ '' THEN GO PROMPT.
|
||
|
|
WD.LAST=''
|
||
|
|
FOR WDN=2 TO NO.WDS
|
||
|
|
WD=FIELD(SENTENCE,' ',WDN)
|
||
|
|
SNO=WD[2,99]
|
||
|
|
IF UNISEQ(WD)=KEYWORD THEN
|
||
|
|
OP.CODE = SYMBOLS(SNO)<1>
|
||
|
|
IF OP.CODE = KW$DICT THEN DICT=1 ; IF FNAME THEN GO AROUND.GET.NAME ELSE GO 2
|
||
|
|
IF OP.CODE = KW$USING THEN ; * 'USING' CLAUSE
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
IF TYPE EQ FILE THEN
|
||
|
|
GOSUB GET.NAME
|
||
|
|
PROCESS.FNAME=GOT.NAME
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
END ELSE PROCESS.FNAME=REVISE.PROCESSES
|
||
|
|
GOSUB GET.NAME
|
||
|
|
PROCESS=GOT.NAME
|
||
|
|
GO 2
|
||
|
|
END
|
||
|
|
IF OP.CODE = KW$VERIFIELD THEN ; * VERIFIELD KEYWORD
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
IF TYPE = NOUN THEN ; * MAKE SURE VERIFIELD FIELD IS NOT PROMPTED FOR
|
||
|
|
IF NOT(INDEX(SENTENCE,SNO,2)) THEN ; * ONLY APPEARS ONCE IN SENTENCE
|
||
|
|
I=1
|
||
|
|
LOOP Q=SYMBOLS(NOUN)<I> UNTIL Q="" DO
|
||
|
|
IF Q<0,2>=SNO THEN
|
||
|
|
SYMBOLS(NOUN)=DELETE(SYMBOLS(NOUN),I,0,0)
|
||
|
|
SYMBOLS(VALUE)=INSERT(SYMBOLS(VALUE),-1,0,0,Q)
|
||
|
|
SYMBOLS(SNO)=""
|
||
|
|
SENTENCE[COL1() + 1,1]=CHAR(VALUE)
|
||
|
|
GOTO 2
|
||
|
|
END
|
||
|
|
I+=1
|
||
|
|
REPEAT
|
||
|
|
END
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF OP.CODE = KW$TEMPLATE THEN ; * TEMPLATE
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
IF TYPE=FILE THEN GO 2 ; * SKIP IT
|
||
|
|
WDN-=1
|
||
|
|
GO 2
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
IF UNISEQ(WD) EQ FILE THEN
|
||
|
|
IF UNISEQ(WD.LAST)=KEYWORD THEN
|
||
|
|
IF SYMBOLS(WD.LAST[2,99])<1,1> EQ KW$VERIFILE THEN GO 2 ; * VERIFILE
|
||
|
|
IF SYMBOLS(WD.LAST[2,99])<1,1> EQ KW$USING THEN GO 2 ; * PROCESS FILE
|
||
|
|
IF SYMBOLS(WD.LAST[2,99])<1,1> EQ KW$TEMPLATE THEN GO 2 ; * TEMPLATE FILE
|
||
|
|
END
|
||
|
|
GOSUB GET.NAME
|
||
|
|
FNAME=GOT.NAME
|
||
|
|
IF DICT THEN GO AROUND.GET.NAME ; * ALL SET FOR NOW
|
||
|
|
END
|
||
|
|
END
|
||
|
|
2: WD.LAST=WD
|
||
|
|
NEXT WDN
|
||
|
|
GO AROUND.GET.NAME
|
||
|
|
|
||
|
|
GET.NAME:
|
||
|
|
I = 1
|
||
|
|
X = UNISEQ(WD)
|
||
|
|
LOOP Q = SYMBOLS(X)<I,2> UNTIL Q='' DO
|
||
|
|
IF Q = SNO THEN
|
||
|
|
GOT.NAME=SYMBOLS(X)<I,1>
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
I+=1
|
||
|
|
REPEAT
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "REVISE.Symbol Table error. Token =>":WDN:"<= not found in Type =>":UNISEQ(WD):"<="
|
||
|
|
GO 9920
|
||
|
|
|
||
|
|
GET.NEXT.WD:
|
||
|
|
WDN+=1
|
||
|
|
IF WDN GT NO.WDS THEN GO PREMATURE
|
||
|
|
WD=FIELD(SENTENCE,' ',WDN)
|
||
|
|
TYPE=UNISEQ(WD)
|
||
|
|
SNO=WD[2,99]
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
PREMATURE:
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "Your sentence ended prematurely."
|
||
|
|
GO 9920
|
||
|
|
|
||
|
|
GET.PMT:
|
||
|
|
* ROUTINE TO FIND PRECEDENT FIELD NAME AND PROMPT NUMBER
|
||
|
|
PMT=''
|
||
|
|
IF LAST.PMT='' THEN RETURN
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.NAME> EQ LAST.PMT THEN RETURN
|
||
|
|
NEXT PMT
|
||
|
|
PMT=''
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
AROUND.GET.NAME:
|
||
|
|
IF FIELD(SENTENCE,' ',2) EQ '' THEN GO PROMPT.
|
||
|
|
IF DICT THEN IF FNAME THEN FNAME='DICT ':FNAME
|
||
|
|
IF PROCESS THEN GO PROMPT.
|
||
|
|
IF FNAME='' THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "This REVISE.sentence has neither a File Name nor a PROCDEF."
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
IF FNAME THEN GOSUB FNAME. ; * OPEN FILES
|
||
|
|
IF FNAME='' THEN RETURN ; * BAD FILE NAME
|
||
|
|
IF DICT THEN PROCESS = 'ENTER.DICT' ; GO PROMPT.
|
||
|
|
GO 20
|
||
|
|
PROMPT.:IF PROCESS = '' THEN
|
||
|
|
5: CALL *UVPRINTMSG(001609,"") ; * enter process name
|
||
|
|
INPUT PROCESS
|
||
|
|
IF PROCESS = RV$CMD.HELP THEN PRINT "Enter the name of the PROCDEF you wish to use, or END to quit." ; GO 5
|
||
|
|
IF PROCESS='' OR UPCASE(PROCESS) = RV$CMD.END THEN RETURN
|
||
|
|
END
|
||
|
|
OPENCHECK '',REVISE.PROCESSES TO PROCESS.FILE ELSE
|
||
|
|
OPENCHECK '','NEWACC' TO NEWACC.FILE ELSE
|
||
|
|
PRINT "Can't open NEWACC"
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
READ NEWACC.RECORD FROM NEWACC.FILE,REVISE.PROCESSES ELSE
|
||
|
|
PRINT "Can't find ":REVISE.PROCESSES
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
* --- Write the record out to the VOC.
|
||
|
|
WRITE NEWACC.RECORD TO DEVSYS.VOC.FILE,REVISE.PROCESSES
|
||
|
|
OPENCHECK '',REVISE.PROCESSES TO PROCESS.FILE ELSE
|
||
|
|
CALL *UVPRINTMSG(001601,REVISE.PROCESSES)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
READ PROCESS.ITEM FROM PROCESS.FILE , PROCESS ELSE
|
||
|
|
CALL *UVPRINTMSG(001602,PROCESS:@FM:REVISE.PROCESSES)
|
||
|
|
GO 5
|
||
|
|
END
|
||
|
|
IF PROCESS.ITEM<RV$PRO.FILE.NAME> NE '' THEN
|
||
|
|
IF FNAME THEN IF FNAME NE PROCESS.ITEM<RV$PRO.FILE.NAME> THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "This Process Definition specifies only file ":PROCESS.ITEM<2>
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
FNAME=PROCESS.ITEM<RV$PRO.FILE.NAME>
|
||
|
|
END
|
||
|
|
IF FNAME='' THEN
|
||
|
|
11: CALL *UVPRINTMSG(001603,"") ; * enter file name
|
||
|
|
INPUT FNAME
|
||
|
|
IF FNAME='' THEN GO 5
|
||
|
|
IF FNAME='?' THEN PRINT "Enter the name of the file you wish to modify." ; GO 11
|
||
|
|
END
|
||
|
|
GOSUB FNAME. ; IF FNAME='' THEN RETURN ELSE GO 20
|
||
|
|
FNAME.:
|
||
|
|
IF FIELD(FNAME,' ',1)='DICT' THEN
|
||
|
|
X='DICT'
|
||
|
|
Q=FIELD(FNAME,' ',2)
|
||
|
|
END ELSE
|
||
|
|
X=''
|
||
|
|
Q=FNAME
|
||
|
|
END
|
||
|
|
OPENCHECK X,Q TO DATA.FILE ELSE
|
||
|
|
15: X.TEXT = 'DICT '
|
||
|
|
IF X = 'DICT' THEN X.TEXT = ''
|
||
|
|
* Cannot open file
|
||
|
|
CALL *UVPRINTMSG(001601,X.TEXT:Q)
|
||
|
|
|
||
|
|
* --- Ensure that @SYSTEM.RETURN.CODE reflects the error. (SPAR 4034265).
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
|
||
|
|
FNAME='' ; RETURN
|
||
|
|
END
|
||
|
|
UpdateFilename = X:Q
|
||
|
|
OPENCHECK 'DICT',Q TO DICT.DATA.FILE ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
* Cannot open file
|
||
|
|
CALL *UVPRINTMSG(001601,'DICT ':Q)
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
20:*
|
||
|
|
*
|
||
|
|
* GET SCREEN TITLE ,NUMBER OF ATTRIBUTES AND AMC OF BATCH TOTAL IF ANY
|
||
|
|
*
|
||
|
|
IF PROCESS NE '' THEN TITLE=PROCESS.ITEM<RV$PRO.TITLE> ELSE PROCESS.ITEM='' ; TITLE=FNAME
|
||
|
|
BATCH.TOTAL.AMC=PROCESS.ITEM<RV$PRO.BATCH.TOTAL.AMC>
|
||
|
|
BATCH.AMC=PROCESS.ITEM<RV$PRO.BATCH.AMC>
|
||
|
|
ENTRY.DATE.AMC=PROCESS.ITEM<RV$PRO.ENTRY.DATE.AMC>
|
||
|
|
AUDIT.FILE=PROCESS.ITEM<RV$PRO.AUDIT.FILE>
|
||
|
|
IF AUDIT.FILE NE '' THEN
|
||
|
|
OPENCHECK '',AUDIT.FILE TO AF ELSE
|
||
|
|
PRINT @SYS.BELL:"Audit File",AUDIT.FILE,"is not defined on this Account." ; RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
MAX.LINES=10 ; * MAXIMUM NUMBER OF LINE ITEMS PER SECOND SCREEN FORMAT
|
||
|
|
*
|
||
|
|
* INITIALIZE BATCH TOTAL
|
||
|
|
*
|
||
|
|
BATCH.TOTAL=''
|
||
|
|
BATCH.NO='' ; * UNTIL NEEDED
|
||
|
|
FROM.SC2=''
|
||
|
|
X=@(0) ; * SHUT DOWN PAGING
|
||
|
|
NEXT.FILE=1
|
||
|
|
USING.NEXT.AVAILABLE=''
|
||
|
|
DISC.FILE.NOT.OPEN = 1 ; * NO NEED TO OPEN THE DISCUSSIONS FILE UNTIL NECESSARY
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
* DEVELOP PROMPTS
|
||
|
|
*
|
||
|
|
NO.PMTS=''
|
||
|
|
X=''
|
||
|
|
MAT D.D=''
|
||
|
|
MAT LAST.IN=''
|
||
|
|
MAT LAST.INPUT=''
|
||
|
|
MAT START.SCR=''
|
||
|
|
MAT END.SCR=''
|
||
|
|
MAT OLD=''
|
||
|
|
MAX.FMC=''
|
||
|
|
!
|
||
|
|
!
|
||
|
|
IF PROCESS EQ '' THEN
|
||
|
|
CALL @REVISE.ASSOC (MAT SYMBOLS,MAT MACRO,SENTENCE,NOUN,MAT D.D,PROCESS.ITEM,MAT VERIFY,
|
||
|
|
STRIPSTRINGS,EXPAND,DICT.DATA.FILE,FNAME,ORIGINAL.SENTENCE,NO.PMTS,MAX.PMTS)
|
||
|
|
NO.WDS=COUNT(SENTENCE,' ')+1
|
||
|
|
* CHECK FOR TEMPLATES, VERIFILES, VERIFIELDS AND MATCHINGS
|
||
|
|
LAST.PMT='' ; * FIELD NAME OF THE CURRENT PROMPT
|
||
|
|
FOR WDN=2 TO NO.WDS
|
||
|
|
WD=FIELD(SENTENCE,' ',WDN)
|
||
|
|
SNO=WD[2,99]
|
||
|
|
IF UNISEQ(WD) EQ NOUN THEN ; * KEEP TRACK OF WHAT FIELD IS BEING MODIFIED
|
||
|
|
GOSUB GET.NAME
|
||
|
|
LAST.PMT=GOT.NAME
|
||
|
|
GO NEXT.WD
|
||
|
|
END
|
||
|
|
IF UNISEQ(WD) NE KEYWORD THEN GO NEXT.WD
|
||
|
|
OP.CODE = SYMBOLS(SNO)<1>
|
||
|
|
|
||
|
|
IF OP.CODE = KW$USING THEN
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
IF TYPE EQ FILE THEN
|
||
|
|
GOSUB GET.NAME
|
||
|
|
PROCESS.FNAME=GOT.NAME
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
END ELSE
|
||
|
|
PROCESS.FNAME=REVISE.PROCESSES
|
||
|
|
END
|
||
|
|
GOSUB GET.NAME
|
||
|
|
PROCESS=GOT.NAME
|
||
|
|
GO NEXT.WD
|
||
|
|
END
|
||
|
|
|
||
|
|
IF OP.CODE = KW$VERIFILE THEN
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
GOSUB GET.NAME
|
||
|
|
IF TYPE NE FILE THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
CALL *UVPRINTMSG(001590,GOT.NAME) ; * invalid verification file
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
GOSUB GET.PMT
|
||
|
|
IF PMT='' THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "Verifile ":GOT.NAME:" doesn't address a field."
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
D.D(PMT)<1,RV$PRO.FLD.VERIFILE> = GOT.NAME
|
||
|
|
IF WDN GE NO.WDS THEN GO NEXT.WD
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
IF TYPE NE KEYWORD THEN WDN-=1 ; GO NEXT.WD
|
||
|
|
SNO=WD[2,99]
|
||
|
|
OP.CODE = SYMBOLS(SNO)<1>
|
||
|
|
|
||
|
|
IF OP.CODE NE KW$VERIFIELD THEN WDN-=1 ; GO NEXT.WD
|
||
|
|
IF FIELD(GOT.NAME,' ',1) EQ 'DICT' THEN
|
||
|
|
X=''
|
||
|
|
VFNAME='DICT.DICT'
|
||
|
|
END ELSE
|
||
|
|
X='DICT'
|
||
|
|
VFNAME=GOT.NAME
|
||
|
|
END
|
||
|
|
OPENCHECK X,VFNAME TO VFILE ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
* Dictionary of verification file ":VFNAME:" not found."
|
||
|
|
CALL *UVPRINTMSG(001593,VFNAME)
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
GOSUB GET.NAME
|
||
|
|
READ X FROM VFILE,GOT.NAME ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
* Verification field not found on dictionary of file
|
||
|
|
CALL *UVPRINTMSG(001594,GOT.NAME:@FM:VFNAME)
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
FMC=X<2>
|
||
|
|
IF X[1,1] NE 'D' OR NOT(NUM(FMC)) THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
* Verification field is not a data definition on the dictionary of file
|
||
|
|
CALL *UVPRINTMSG(001595,GOT.NAME:@FM:VFNAME)
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
D.D(PMT)<1,RV$PRO.FLD.VERIFIELD> = FMC+0
|
||
|
|
END
|
||
|
|
|
||
|
|
IF OP.CODE = KW$MATCHING THEN ; * MATCHING
|
||
|
|
GOSUB GET.NEXT.WD
|
||
|
|
GOSUB GET.NAME
|
||
|
|
GOSUB GET.PMT
|
||
|
|
IF PMT='' THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
* Matching clause must follow a field name
|
||
|
|
CALL *UVPRINTMSG(001591,"")
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
D.D(PMT)<1,RV$PRO.FLD.MATCHFIELD> = GOT.NAME
|
||
|
|
END
|
||
|
|
|
||
|
|
IF OP.CODE = KW$NEXT.AVAILABLE THEN ; * NEXT.AVAILABLE
|
||
|
|
D.D(1)<1,RV$PRO.FLD.REQUIRED> = RV$PRO.VAL.NEXTAVAILABLE
|
||
|
|
NEXT.AVAILABLE=1 ; * FLAG
|
||
|
|
END
|
||
|
|
|
||
|
|
NEXT.WD: NEXT WDN
|
||
|
|
IF PROCESS THEN GO PROMPT. ; * SOMEBODY USED A 'USING' IN AN '@' PHRASE
|
||
|
|
GO FIGGER
|
||
|
|
END ELSE
|
||
|
|
MATPARSE D.D FROM FIELD(PROCESS.ITEM,@FM,RV$PRO.FLD.BEG,RV$PRO.FLD.END),@FM
|
||
|
|
NO.PMTS=INMAT()<1,1>
|
||
|
|
GO FIGGER
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!
|
||
|
|
FIGGER:IF NO.PMTS=0 THEN PRINT "####### No prompts found for this File ######" ; RETURN
|
||
|
|
FILE.ERR=0
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
VERIFY(PMT)='' ; * FLAG FOR FILE VERIFICATION
|
||
|
|
REFILE=D.D(PMT)<1,RV$PRO.FLD.VERIFILE> ; * VERIFICATION FILE NAME
|
||
|
|
REFL=1 ; * VERIFILE
|
||
|
|
GOSUB 60
|
||
|
|
REFILE=D.D(PMT)<1,RV$PRO.FLD.PASSIVE.XREF>
|
||
|
|
REFL=2 ; * REFILE - PASSIVE CROSS REFERENCE FILE
|
||
|
|
GOSUB 60
|
||
|
|
REFILE=D.D(PMT)<1,RV$PRO.FLD.ACTIVE.XREF>
|
||
|
|
REFL=3 ; * CREFILE - ACTIVE CROSS REFERENCE FILE
|
||
|
|
GOSUB 60
|
||
|
|
GO 65
|
||
|
|
60:* OPENING REFERENCE AND VERIFICATION FILES
|
||
|
|
IF REFILE='' THEN RETURN
|
||
|
|
IF FIELD(REFILE,' ',1)='DICT' THEN
|
||
|
|
DX='DICT'
|
||
|
|
X=FIELD(REFILE,' ',2)
|
||
|
|
END ELSE
|
||
|
|
DX=''
|
||
|
|
X=REFILE
|
||
|
|
END
|
||
|
|
OPENCHECK DX,X TO VERIFILE(NEXT.FILE) ELSE
|
||
|
|
FILE.ERR=1
|
||
|
|
DX.TEXT = 'DICT '
|
||
|
|
IF DX = '' THEN DX.TEXT = ''
|
||
|
|
* Verficiation file is not a valid file
|
||
|
|
CALL *UVPRINTMSG(001590,DX.TEXT:X)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
VERIFY(PMT)<1,REFL> = NEXT.FILE
|
||
|
|
NEXT.FILE=NEXT.FILE+1
|
||
|
|
RETURN
|
||
|
|
65:* AFTER VERIFILE PROCESSING
|
||
|
|
IF FILE.ERR THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.ASSOCIATION> THEN LAST.IN(PMT)=1
|
||
|
|
Q=D.D(PMT)<1,RV$PRO.FLD.SCREEN.NO>
|
||
|
|
IF NOT(Q) THEN Q=1
|
||
|
|
IF Q > INMAT(START.SCR)<1,1> THEN
|
||
|
|
DIM START.SCR(Q + 5)
|
||
|
|
DIM END.SCR(Q + 5)
|
||
|
|
FOR X = Q TO Q+5
|
||
|
|
START.SCR(X)=''
|
||
|
|
END.SCR(X)=''
|
||
|
|
NEXT X
|
||
|
|
END
|
||
|
|
IF START.SCR(Q)='' THEN START.SCR(Q)=PMT
|
||
|
|
IF PMT LT START.SCR(Q) THEN START.SCR(Q)=PMT
|
||
|
|
IF END.SCR(Q)='' THEN END.SCR(Q)=PMT
|
||
|
|
IF PMT GT END.SCR(Q) THEN END.SCR(Q)=PMT
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.LOCATION> > MAX.FMC THEN MAX.FMC=D.D(PMT)<1,RV$PRO.FLD.LOCATION>
|
||
|
|
NEXT PMT
|
||
|
|
70: IF NO.PMTS=0 THEN PRINT "####### No prompts found for this File ######" ; RETURN
|
||
|
|
LINE.ITEMS=''
|
||
|
|
Q=''
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.NAME> = "LINE.ITEMS" THEN LINE.ITEMS=PMT
|
||
|
|
NEXT PMT
|
||
|
|
IF START.SCR(1)='' THEN START.SCR(1)=1
|
||
|
|
IF END.SCR(1)='' THEN END.SCR(1)=NO.PMTS
|
||
|
|
IF LINE.ITEMS THEN
|
||
|
|
END.SCR(1)=LINE.ITEMS
|
||
|
|
START.SCR(2)=LINE.ITEMS+1
|
||
|
|
END.SCR(2)=NO.PMTS
|
||
|
|
END
|
||
|
|
*
|
||
|
|
* GENERATE MASK FOR SCREEN
|
||
|
|
*
|
||
|
|
CVS='' ; * WHETHER OR NOT THERE ARE ANY CONVERSION
|
||
|
|
IF NOT(LINE.ITEMS) THEN LINE.ITEMS=NO.PMTS
|
||
|
|
IF LINE.ITEMS>19 THEN MAX.PMT=19 ELSE MAX.PMT=LINE.ITEMS ; * FOR TWO COLUMN SCREEN
|
||
|
|
MASK=''
|
||
|
|
FOR I=1 TO NO.PMTS
|
||
|
|
Q=D.D(I)<1,RV$PRO.FLD.FORMAT>
|
||
|
|
IF Q = '' THEN
|
||
|
|
X = 10
|
||
|
|
END ELSE
|
||
|
|
X=MATCHFIELD(Q,'0A0N0X',2)
|
||
|
|
END
|
||
|
|
IF END.SCR(1) > 19 THEN
|
||
|
|
IF X > 24 THEN X=24
|
||
|
|
END ELSE IF X > 63 THEN X = 63
|
||
|
|
LFMT(I)='L#':X
|
||
|
|
RFMT(I)='R#':X
|
||
|
|
IF X=0 THEN
|
||
|
|
LFMT(I)=0
|
||
|
|
RFMT(I)=0
|
||
|
|
END
|
||
|
|
CV(I)=D.D(I)<1,RV$PRO.FLD.CONVERSION>
|
||
|
|
IF CV(I) NE '' THEN CVS=1
|
||
|
|
NEXT I
|
||
|
|
LFMT1='L#60'
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* SET UP TABS FOR LINE ITEMS SCREEN AND SET JUSTIFICATIONS
|
||
|
|
FOR I=END.SCR(1)+1 TO NO.PMTS
|
||
|
|
IF INDEX(D.D(I)<1,RV$PRO.FLD.FORMAT>,'L',1) THEN RFMT(I)=LFMT(I)
|
||
|
|
IF INDEX(D.D(I)<1,RV$PRO.FLD.FORMAT>,'T',1) THEN RFMT(I)=LFMT(I)
|
||
|
|
NEXT I
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
* GET ITEM-WISE INPUT
|
||
|
|
*
|
||
|
|
LINE.NO=1
|
||
|
|
100: PRINT @(-1):
|
||
|
|
FILED='' ; * FLAG TO INDICATE PROCESS WAS TERMINATED WITH SHORT-CUT FILING
|
||
|
|
IF BATCH.AMC THEN PRINT 'Batch:':BATCH.NO:' ':
|
||
|
|
PRINT " ":TITLE<1>[1,31]:" REVISE.1 ":
|
||
|
|
GOSUB PRINT.TIMEDATE
|
||
|
|
PRINT ; PRINT MASK
|
||
|
|
DELETE.ID=""
|
||
|
|
MAT INP=''
|
||
|
|
*
|
||
|
|
* GET KEY
|
||
|
|
*
|
||
|
|
PMT =1 ; * KEY
|
||
|
|
SCR=1
|
||
|
|
110: READNEXT Q ELSE GO ASK.
|
||
|
|
IF VERIFY(PMT)#"" THEN ; * Verify the data ;* 003
|
||
|
|
GOSUB 600 ; * if required. ;* 003
|
||
|
|
IF REPAINT THEN INP(PMT)=Q ; GOSUB 130 ; * 003
|
||
|
|
IF Q='' THEN GO 110 ; * 003
|
||
|
|
END ; * 003
|
||
|
|
INP(1)=Q
|
||
|
|
READING.NEXT=1
|
||
|
|
GO 120
|
||
|
|
ASK.: GOSUB PROMPTER ; IF NOT(OK) THEN GO 110
|
||
|
|
READING.NEXT=''
|
||
|
|
INPUT.LEN = LEN(Q)
|
||
|
|
IF INPUT.LEN = 0 THEN INPUT.LEN = 1
|
||
|
|
IF UPCASE(Q) = RV$CMD.END OR UPCASE(Q) = RV$CMD.QUIT[1,INPUT.LEN] THEN GO 9900 ; * WRAP UP AND QUIT
|
||
|
|
IF Q THEN IF NOT(INDEX(STD.RESP0,@FM:Q:@FM,1)) THEN GO AROUND.STD ; *006
|
||
|
|
IF Q= RV$CMD.HELP THEN GOSUB 9000 ; GO 110
|
||
|
|
IF Q= RV$CMD.SKIP THEN
|
||
|
|
IF REQUIRED THEN GO 110
|
||
|
|
Q=''
|
||
|
|
GO AROUND.STD
|
||
|
|
END
|
||
|
|
IF UPCASE(Q)= RV$CMD.TOP THEN PROCESS='' ; GO 10
|
||
|
|
IF Q= RV$CMD.PROMPT THEN GO 110
|
||
|
|
IF Q= RV$CMD.REDRAW THEN START.PMT=1 ; END.PMT=END.SCR(1) ; GOSUB 130 ; GO 110
|
||
|
|
IF Q= RV$CMD.EXTENDED.HELP THEN GOSUB 9200 ; GO 100
|
||
|
|
AROUND.STD:
|
||
|
|
IF Q='' THEN
|
||
|
|
IF NEXT.AVAILABLE THEN GO 111 ; * THE IN-SENTENCE OPTION
|
||
|
|
IF PROCESS='' OR PROCESS='ENTER.DICT' THEN GO 9900 ; * DIRECT DICTIONARY PROMPTING
|
||
|
|
IF NOT(NEXT.AVAILABLE) THEN RETURN
|
||
|
|
* ASSIGN NEXT AVAILABLE
|
||
|
|
111: READU Q FROM DICT.DATA.FILE, '&NEXT.AVAILABLE&' ELSE Q=@AM:1
|
||
|
|
Q=Q<2>
|
||
|
|
IF NOT(NUM(Q)) OR Q='' THEN Q=1
|
||
|
|
WRITE 'X':@AM:Q+1 ON DICT.DATA.FILE, '&NEXT.AVAILABLE&'
|
||
|
|
FILL.C=D.D(PMT)<1,RV$PRO.FLD.FILL.CODE>
|
||
|
|
IF FILL.C#"" THEN Q=FMT(Q,RFMT(PMT):FILL.C)
|
||
|
|
READ X FROM DATA.FILE, Q ELSE GO 112
|
||
|
|
GO 111
|
||
|
|
112:
|
||
|
|
USING.NEXT.AVAILABLE=Q
|
||
|
|
PRINT "Next available ":D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:" is ":Q:" and is also a ":
|
||
|
|
END ELSE USING.NEXT.AVAILABLE=''
|
||
|
|
FILL.C=D.D(PMT)<1,RV$PRO.FLD.FILL.CODE>
|
||
|
|
IF FILL.C#"" THEN Q=FMT(Q,RFMT(PMT):FILL.C)
|
||
|
|
IF VERIFY(PMT)#"" THEN
|
||
|
|
GOSUB 600
|
||
|
|
IF REPAINT THEN INP(PMT)=Q ; GOSUB 130
|
||
|
|
IF Q='' THEN GO 110
|
||
|
|
END
|
||
|
|
INP(PMT)=Q
|
||
|
|
IF CV(PMT)#"" THEN Q=OCONV(Q,CV(PMT)) ; REPAINT=1
|
||
|
|
120:
|
||
|
|
LINE.NO=1
|
||
|
|
SCR=1
|
||
|
|
UpdateType = ''
|
||
|
|
125: READU ITEM FROM DATA.FILE, INP(1) LOCKED
|
||
|
|
PRINT "Sorry, but Record ":INP(1):" is currently locked for use by User number ":STATUS():"."
|
||
|
|
IF READING.NEXT THEN
|
||
|
|
PRINT "Press <RETURN> to try again or enter QUIT to skip it.":
|
||
|
|
INPUT Q
|
||
|
|
IF Q[1,1]='Q' THEN GO 110
|
||
|
|
GO 125
|
||
|
|
END ELSE GO ASK.
|
||
|
|
END ELSE
|
||
|
|
DF.ERROR = STATUS()
|
||
|
|
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
|
||
|
|
CALL *UVPRINTMSG(970012,INP(1))
|
||
|
|
PRINT "Press <RETURN> to continue":
|
||
|
|
INPUT Q
|
||
|
|
GO 100
|
||
|
|
END
|
||
|
|
ELSE IF DF.ERROR = 3 THEN
|
||
|
|
CALL *UVPRINTMSG(47007,INP(1))
|
||
|
|
PRINT "Press <RETURN> to continue":
|
||
|
|
INPUT Q
|
||
|
|
GO 100
|
||
|
|
END
|
||
|
|
ELSE IF DF.ERROR = 4 THEN
|
||
|
|
* Warning message already issued - no need to repeat ourselves
|
||
|
|
* CALL *UVPRINTMSG(47006,INP(1))
|
||
|
|
PRINT "Press <RETURN> to continue":
|
||
|
|
INPUT Q
|
||
|
|
GO 100
|
||
|
|
END
|
||
|
|
IF READING.NEXT THEN PRINT D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:'=':FMT(OCONV(Q,CV(PMT)),LFMT(PMT))
|
||
|
|
START.PMT=2
|
||
|
|
IF LINE.ITEMS EQ NO.PMTS THEN END.PMT=END.SCR(1) ELSE END.PMT=LINE.ITEMS-1
|
||
|
|
GOSUB 1000
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.VERIFIELD> THEN CALL !SLEEP$(2500)
|
||
|
|
IF Q= RV$CMD.PROMPT OR UPCASE(Q)= RV$CMD.TOP THEN
|
||
|
|
IF USING.NEXT.AVAILABLE THEN GOSUB RESET.NEXT.AVAILABLE
|
||
|
|
RELEASE DATA.FILE, INP(1)
|
||
|
|
GO 100
|
||
|
|
END
|
||
|
|
LAST.SCREEN = INMAT(START.SCR)<1,1>
|
||
|
|
FOR SCR=2 TO LAST.SCREEN
|
||
|
|
IF START.SCR(SCR) THEN GOSUB 700
|
||
|
|
IF FILED THEN GO 100
|
||
|
|
IF UPCASE(Q) = RV$CMD.TOP OR UPCASE(LINE.NO) = RV$CMD.TOP THEN SCR=INMAT(START.SCR)<1,1>
|
||
|
|
NEXT SCR
|
||
|
|
START.PMT=1
|
||
|
|
END.PMT=END.SCR(1)
|
||
|
|
SCR=1
|
||
|
|
GOSUB 130
|
||
|
|
GOSUB 500
|
||
|
|
IF UPCASE(PMT) = RV$CMD.TOP THEN
|
||
|
|
IF USING.NEXT.AVAILABLE THEN GOSUB RESET.NEXT.AVAILABLE
|
||
|
|
RELEASE DATA.FILE, INP(1)
|
||
|
|
END
|
||
|
|
GO 100
|
||
|
|
END
|
||
|
|
* ;*009
|
||
|
|
* Check to see if we arw working with a dictionary, and the type of ;*009
|
||
|
|
* record we have selected, ie. if an i-type or d-type. ;*009
|
||
|
|
* ;*009
|
||
|
|
ORIGINAL.TYPE = ITEM<2> ; * Store the original away;*009
|
||
|
|
IF DICT THEN
|
||
|
|
IF ITEM<1>[1,1] ='I' THEN ITYPE = 1
|
||
|
|
IF ITEM<1>[1,1] ='D' THEN DTYPE = 1
|
||
|
|
END
|
||
|
|
|
||
|
|
*
|
||
|
|
* EXTRACT ATTRIBUTES
|
||
|
|
*
|
||
|
|
* Give the user time to see any output from a VERIFEILD command. ;* 003
|
||
|
|
* ;* 003
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.VERIFIELD> THEN CALL !SLEEP$(2500) ; * 003
|
||
|
|
*
|
||
|
|
OLD(1)=INP(1)
|
||
|
|
FOR I=2 TO NO.PMTS
|
||
|
|
INP(I)=ITEM<D.D(I)<1,RV$PRO.FLD.LOCATION>>
|
||
|
|
OLD(I)=INP(I)
|
||
|
|
NEXT I
|
||
|
|
START.PMT=1
|
||
|
|
END.PMT=END.SCR(1)
|
||
|
|
SCR=1
|
||
|
|
GOSUB 130
|
||
|
|
GOSUB 500
|
||
|
|
GO 100
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* DISPLAY ITEM ON SCREEN
|
||
|
|
*
|
||
|
|
130: PRINT @(-1):
|
||
|
|
IF BATCH.NO THEN PRINT "Batch:":BATCH.NO:
|
||
|
|
PRINT TITLE[1,31]:" -Screen ":SCR:"-":PROCESS.ITEM<RV$PRO.SCREEN.HEADING,SCR>[1,20]:" ":
|
||
|
|
GOSUB PRINT.TIMEDATE
|
||
|
|
PRINT
|
||
|
|
IF START.PMT GT END.SCR(1) THEN
|
||
|
|
X=INP(1)
|
||
|
|
IF CV(1) # "" THEN X=OCONV(X,CV(1))
|
||
|
|
PRINT D.D(1)<1,RV$PRO.FLD.NAME>:"==>>":FMT(X,LFMT(1)):" Line==>> ":LINE.NO
|
||
|
|
END
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
X=INP(I)<1,LINE.NO>
|
||
|
|
IF CV(I)#"" THEN X=OCONV(X,CV(I))
|
||
|
|
PRINT FMT(I,'2L'):' ':FMT(D.D(I)<1,RV$PRO.FLD.NAME>,'L#10'):" ":
|
||
|
|
IF LFMT(I) NE 0 THEN PRINT X ELSE PRINT
|
||
|
|
NEXT I
|
||
|
|
IF SCR=1 THEN IF END.PMT EQ END.SCR(1) THEN
|
||
|
|
PRINT
|
||
|
|
I=1
|
||
|
|
LOOP X=PROCESS.ITEM<RV$PRO.SCREEN.HEADING,I> UNTIL X='' DO
|
||
|
|
PRINT "S":I:" == ":X
|
||
|
|
PRINT CHAR(13):
|
||
|
|
I+=1
|
||
|
|
REPEAT
|
||
|
|
PRINT
|
||
|
|
END
|
||
|
|
REPAINT=''
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
500:* MODIFY RECORD OR LINE ITEM ROUTINE
|
||
|
|
*
|
||
|
|
IF FROM.SC2 THEN IF START.PMT=END.PMT THEN
|
||
|
|
* ONLY ONE FIELD TO DEAL WITH
|
||
|
|
IF Q= RV$CMD.PROMPT THEN RETURN ; * DIDN'T WANT TO CHANGE IT AFTER ALL
|
||
|
|
PMT=END.PMT
|
||
|
|
GO 510
|
||
|
|
END
|
||
|
|
PRINT CHANGE<2>:"=":
|
||
|
|
INPUT PMT
|
||
|
|
IF PMT= RV$CMD.SKIP OR UPCASE(PMT) = RV$CMD.FILE THEN
|
||
|
|
GOSUB UpdateDatabase
|
||
|
|
IF NOT(UpdateSuccess) THEN GO 500
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
INPUT.LEN = LEN(PMT)
|
||
|
|
IF INPUT.LEN = 0 THEN INPUT.LEN = 1
|
||
|
|
IF UPCASE(PMT) = RV$CMD.QUIT[1,INPUT.LEN] THEN
|
||
|
|
IF NOT(READING.NEXT) THEN
|
||
|
|
PRINT @SYS.BELL:'There is no SELECT list active'
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
RELEASE DATA.FILE, INP(1)
|
||
|
|
CLEARSELECT
|
||
|
|
RETURN TO 100
|
||
|
|
END
|
||
|
|
IF INDEX(STD.RESP,@FM:PMT:@FM,1) THEN GO 550 ; *006
|
||
|
|
IF UPCASE(PMT) MATCHES "'S'0N" THEN
|
||
|
|
SCR=PMT[2,99]
|
||
|
|
IF SCR > INMAT(START.SCR)<1,1> THEN
|
||
|
|
PRINT "Invalid Screen number."
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
IF NOT(END.SCR(SCR)) THEN
|
||
|
|
* that screen is not defined in this process.
|
||
|
|
CALL *UVPRINTMSG(001588,"")
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
IF SCR=1 THEN GO 500 ELSE GO 508
|
||
|
|
END
|
||
|
|
505: IF NOT(NUM(PMT)) THEN GO 506
|
||
|
|
IF PMT<START.PMT OR PMT>END.PMT THEN
|
||
|
|
* invalid prompt number
|
||
|
|
506: CALL *UVPRINTMSG(001583,START.PMT:@FM:END.PMT)
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
IF NOT(FROM.SC2) THEN
|
||
|
|
SCR=D.D(PMT)<1,RV$PRO.FLD.SCREEN.NO>
|
||
|
|
IF SCR='' THEN SCR=1
|
||
|
|
IF NOT(NUM(SCR)) THEN SCR=1
|
||
|
|
IF SCR LT 1 THEN SCR=1
|
||
|
|
508: IF SCR GT 1 THEN
|
||
|
|
GOSUB 700 ; IF FILED THEN RETURN
|
||
|
|
START.PMT=1
|
||
|
|
END.PMT=END.SCR(1)
|
||
|
|
SCR=1
|
||
|
|
LINE.NO=1
|
||
|
|
GOSUB 130
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF NO.PMTS NE LINE.ITEMS THEN IF PMT EQ LINE.ITEMS THEN
|
||
|
|
SCR=2
|
||
|
|
GOSUB 700 ; IF FILED THEN RETURN
|
||
|
|
START.PMT=1
|
||
|
|
END.PMT=LINE.ITEMS
|
||
|
|
LINE.NO=1
|
||
|
|
GOSUB 130
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.DISPLAYONLY> THEN
|
||
|
|
* This field is displayed for your reference only
|
||
|
|
CALL *UVPRINTMSG(001586,"")
|
||
|
|
GO 500
|
||
|
|
END
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
!
|
||
|
|
* INSERT PROMPT SPECIFIC LOGIC HERE
|
||
|
|
!
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
510:
|
||
|
|
GOSUB PROMPTER ; IF NOT(OK) THEN GO 510
|
||
|
|
IF Q # "" THEN
|
||
|
|
IF INDEX(STD.RESP0,@FM:Q:@FM,1) THEN GO 560 ; *006
|
||
|
|
IF Q='"' THEN
|
||
|
|
IF FROM.SC2 THEN
|
||
|
|
IF LINE.NO EQ 1 THEN
|
||
|
|
* not valid on first screen
|
||
|
|
CALL *UVPRINTMSG(001577,"")
|
||
|
|
GO 510 ; *012
|
||
|
|
END ; *012
|
||
|
|
Q=INP(PMT)<1,LINE.NO-1>
|
||
|
|
GO 540
|
||
|
|
END ELSE
|
||
|
|
* not valid on first screen
|
||
|
|
CALL *UVPRINTMSG(001577,"")
|
||
|
|
GO 510
|
||
|
|
END
|
||
|
|
END
|
||
|
|
515: IF FROM.SC2 THEN
|
||
|
|
IF PMT=START.PMT THEN
|
||
|
|
IF Q='##' THEN
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
INP(I)=DELETE(INP(I),1,LINE.NO,0)
|
||
|
|
NEXT I
|
||
|
|
ALL.LINES-=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF Q[1,1]='>' THEN
|
||
|
|
IF Q='>' THEN
|
||
|
|
* inserting the following information at line
|
||
|
|
CALL *UVPRINTMSG(001579,LINE.NO)
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
INP(I)=INSERT(INP(I),1,LINE.NO,0,'')
|
||
|
|
NEXT I
|
||
|
|
GOSUB 1000
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
LINE.X=FIELD(Q,'#',2)
|
||
|
|
IF NOT(NUM(LINE.X)) THEN PRINT "WHAZZAT?" ; GO 510
|
||
|
|
IF LINE.X LE 0 OR LINE.X GT ALL.LINES THEN
|
||
|
|
* line number not defined
|
||
|
|
CALL *UVPRINTMSG(001580,LINE.X)
|
||
|
|
GO 510
|
||
|
|
END
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
INP(I)=INSERT(INP(I),1,LINE.NO,0,INP(I)<1,LINE.X>)
|
||
|
|
NEXT I
|
||
|
|
ALL.LINES+=1
|
||
|
|
Q = INP(START.PMT)<1,LINE.X+1>
|
||
|
|
GO 545
|
||
|
|
END
|
||
|
|
END
|
||
|
|
END
|
||
|
|
FILL.C=D.D(PMT)<1,RV$PRO.FLD.FILL.CODE>
|
||
|
|
IF FILL.C#"" THEN Q=FMT(Q,RFMT(PMT):FILL.C)
|
||
|
|
IF VERIFY(PMT)#"" THEN
|
||
|
|
GOSUB 600
|
||
|
|
IF REPAINT THEN INP(PMT)<1,LINE.NO> = Q ; GOSUB 130
|
||
|
|
IF Q='' THEN GO 510
|
||
|
|
END
|
||
|
|
IF NOT(UpdateType) THEN UpdateType = UpdateExisting
|
||
|
|
IF PMT=1 THEN
|
||
|
|
GOSUB 650
|
||
|
|
IF DELETE.ID='' THEN DELETE.ID=INP(1) ; * DELETE ON KEY CHANGE
|
||
|
|
END
|
||
|
|
END
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
!
|
||
|
|
* INSERT RESPONSE SPECIFIC LOGIC HERE
|
||
|
|
!
|
||
|
|
*
|
||
|
|
!
|
||
|
|
*
|
||
|
|
540:
|
||
|
|
IF SCR = 1 THEN
|
||
|
|
DMdelimiter = @FM
|
||
|
|
END ELSE
|
||
|
|
DMdelimiter = @VM
|
||
|
|
END
|
||
|
|
GOSUB ReplaceData
|
||
|
|
545:
|
||
|
|
IF NOT(UpdateType) THEN UpdateType = UpdateExisting
|
||
|
|
IF Q NE INP(PMT)<1,LINE.NO> THEN
|
||
|
|
PRINT "REPLACE error after 540 -- ":Q:" became ":INP(PMT)<1,LINE.NO>:"."
|
||
|
|
END
|
||
|
|
IF CV(PMT)#"" THEN Q=OCONV(Q,CV(PMT)) ; REPAINT=1
|
||
|
|
IF FROM.SC2 THEN IF START.PMT=END.PMT THEN REPAINT='' ; RETURN ; * ONLY ONE FIELD
|
||
|
|
GO 500
|
||
|
|
*
|
||
|
|
550:* STANDARD EXCEPTIONS
|
||
|
|
*
|
||
|
|
IF PMT= RV$CMD.HELP THEN PRINT CHANGE<10> ; GO 500
|
||
|
|
*---- PCC Added release.
|
||
|
|
IF UPCASE(PMT) = RV$CMD.TOP THEN RELEASE DATA.FILE, INP(1) ; RETURN
|
||
|
|
IF PMT='' THEN
|
||
|
|
IF REPAINT THEN GOSUB 130 ; GO 500
|
||
|
|
*------- PCC Added release.
|
||
|
|
IF FROM.SC2 THEN RELEASE DATA.FILE, INP(1) ; RETURN
|
||
|
|
GOSUB UpdateDatabase
|
||
|
|
IF NOT(UpdateSuccess) THEN GO 500
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF PMT= RV$CMD.PROMPT THEN GO 500
|
||
|
|
IF PMT= RV$CMD.REDRAW THEN GOSUB 130 ; GO 500
|
||
|
|
IF PMT= RV$CMD.EXTENDED.HELP THEN PMT=0 ; GOSUB 9200 ; GOSUB 130 ; GO 500
|
||
|
|
IF UPCASE(PMT) = RV$CMD.DELETE THEN
|
||
|
|
IF UpdateType = UpdateNew THEN RELEASE DATA.FILE, INP(1) ; RETURN
|
||
|
|
IF DELETE.ID#'' THEN INP(1)=DELETE.ID
|
||
|
|
IF AUDIT.FILE NE '' THEN
|
||
|
|
READ AUDIT.ITEM FROM DATA.FILE,INP(1) ELSE AUDIT.ITEM=''
|
||
|
|
A.KEY=FNAME:"@":OLD(1):"@":DATE():"@":TIME():"@DELETED"
|
||
|
|
WRITE AUDIT.ITEM ON AF,A.KEY
|
||
|
|
END
|
||
|
|
DELETE DATA.FILE,INP(1)
|
||
|
|
KEY=OLD(1)
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF VERIFY(PMT)<1,3> THEN GOSUB DeleteXReference
|
||
|
|
NEXT PMT
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF PMT= RV$CMD.PROMPT THEN GO 500
|
||
|
|
IF PMT= RV$CMD.SKIP THEN GO 500
|
||
|
|
GO 505 ; * INPUT OK, JUST LOOKED LIKE AN EXCEPTION (T,O,P,ETC.)
|
||
|
|
*
|
||
|
|
560:* MORE STANDARD EXCEPTIONS
|
||
|
|
*
|
||
|
|
IF Q= RV$CMD.HELP THEN GOSUB 9000 ; GO 510
|
||
|
|
IF UPCASE(Q) = RV$CMD.TOP THEN RETURN
|
||
|
|
IF UPCASE(Q) = RV$CMD.DELETE THEN PRINT @SYS.BELL:"Not valid here." ; GO 510
|
||
|
|
IF Q= RV$CMD.SKIP THEN GO 500
|
||
|
|
IF Q= RV$CMD.PROMPT THEN GO 500 ; * NOCHANGE
|
||
|
|
IF Q= RV$CMD.REDRAW THEN GOSUB 130 ; GO 510
|
||
|
|
IF Q= RV$CMD.EXTENDED.HELP THEN GOSUB 9200 ; GOSUB 130 ; GO 510
|
||
|
|
GO 515 ; * INPUT OK, JUST LOOKED LIKE AN EXCEPTION (T,O,P,ETC.)
|
||
|
|
600:* FILE VERIFICATION SUBROUTINE
|
||
|
|
*
|
||
|
|
* Remember the following: ;* 003
|
||
|
|
* ;* 003
|
||
|
|
* VERI.AMC = 0 The key to the file is the verify.field ;* 003
|
||
|
|
* VERI.AMC > 1 A non-key field is the verify.field ;* 003
|
||
|
|
* VERI.AMC = '' There is no verify.field ;* 003
|
||
|
|
*
|
||
|
|
REPAINT=''
|
||
|
|
VERI.AMC=D.D(PMT)<1,RV$PRO.FLD.VERIFIELD>
|
||
|
|
FILE.NO=VERIFY(PMT)<1,1>
|
||
|
|
IF FILE.NO='' THEN RETURN
|
||
|
|
READ X FROM VERIFILE(FILE.NO), Q ELSE
|
||
|
|
IF PMT=1 THEN IF VERI.AMC='' THEN RETURN ; * Changed NOT(VERI.AMC) *003
|
||
|
|
FILE.NO=VERIFY(PMT)<1,2>
|
||
|
|
IF FILE.NO THEN
|
||
|
|
START.PMT=START.SCR(SCR)
|
||
|
|
END.PMT=END.SCR(SCR)
|
||
|
|
READ X FROM VERIFILE(FILE.NO), Q ELSE GO 620
|
||
|
|
FMC=VERI.AMC
|
||
|
|
IF FMC='' THEN FMC=1
|
||
|
|
IF COUNT(X<1>,@VM) = 0 THEN Q = X<1> ; PRINT Q ; RETURN ; *005
|
||
|
|
PRINT @(-1):" Cross Reference Display "
|
||
|
|
PRINT "ITEM ":D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:" ":FMT("DESC",LFMT1)
|
||
|
|
LC=1
|
||
|
|
FILE.NO=VERIFY(PMT)<1,1>
|
||
|
|
I=1
|
||
|
|
LOOP Q=X<1,I> UNTIL Q='' DO
|
||
|
|
READ K FROM VERIFILE(FILE.NO),Q ELSE
|
||
|
|
K="not found on Master File."
|
||
|
|
GO 615
|
||
|
|
END
|
||
|
|
K=K<FMC>
|
||
|
|
615: PRINT FMT(LC,"R#3"):'==>':FMT(Q,LFMT(PMT)):' ':FMT(K,LFMT1)
|
||
|
|
PRINT
|
||
|
|
LC=LC+1
|
||
|
|
IF MOD(LC,11) = 0 THEN
|
||
|
|
617: PRINT "Which Item would you like? (<RETURN> to see next page, END to stop display)":
|
||
|
|
INPUT K
|
||
|
|
IF K='' THEN
|
||
|
|
PRINT @(-1):" Cross Reference Display"
|
||
|
|
PRINT "ITEM ":D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:" ":FMT("DESC",LFMT1)
|
||
|
|
PRINT
|
||
|
|
GO 618
|
||
|
|
END
|
||
|
|
IF UPCASE(K) = RV$CMD.END THEN GOSUB 130 ; Q='' ; RETURN
|
||
|
|
IF NUM(K) THEN
|
||
|
|
IF K LE 0 OR K GT LC THEN PRINT "That number is not displayed." ; GO 617
|
||
|
|
Q=X<1,K>
|
||
|
|
REPAINT=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
PRINT @SYS.BELL:"Enter the number of the line you wish, a <RETURN> or END."
|
||
|
|
GO 617
|
||
|
|
END
|
||
|
|
618: I=I+1
|
||
|
|
REPEAT
|
||
|
|
IF I#1 THEN
|
||
|
|
619: PRINT "Which Item would you like ":
|
||
|
|
INPUT K
|
||
|
|
IF NUM(K) THEN
|
||
|
|
IF K GT 0 AND K LE LC THEN
|
||
|
|
Q=X<1,K>
|
||
|
|
REPAINT=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF K='?' THEN
|
||
|
|
PRINT "Enter the Item number of the ":D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:" you wish or <RETURN> for previous prompt." ; *005
|
||
|
|
GO 619
|
||
|
|
END
|
||
|
|
Q=''
|
||
|
|
GOSUB 130 ; * Repaint and reprompt ;*005
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
620: PRINT @SYS.BELL:Q:" not found on ":D.D(PMT)<1,RV$PRO.FLD.VERIFILE>:"."
|
||
|
|
Q=''
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF PMT=1 THEN IF VERI.AMC = '' THEN ; * Changed NOT(VER.AMC) to ''. ;* 003
|
||
|
|
PRINT @SYS.BELL:Q:" already present on ":D.D(PMT)<1,RV$PRO.FLD.VERIFILE>:"." ; Q='' ; RETURN
|
||
|
|
END
|
||
|
|
*
|
||
|
|
* Only want to output the contents of the verify.field if it is not the ;* 003
|
||
|
|
* key to the verify.file (i.e. VERI.AMC > 0). ;* 003
|
||
|
|
*
|
||
|
|
IF VERI.AMC THEN PRINT X<VERI.AMC>
|
||
|
|
RETURN
|
||
|
|
650:* CHECK FOR PRE-EXISTING ITEM ON ID CHANGE
|
||
|
|
READ X FROM DATA.FILE, Q ELSE GO 655
|
||
|
|
PRINT @SYS.BELL:"WARNING: ":Q:" already exists on ":FNAME:"."
|
||
|
|
655:*
|
||
|
|
RETURN
|
||
|
|
700:* LINE ITEMS CONTROL ROUTINE
|
||
|
|
FROM.SC2=1
|
||
|
|
START.PMT=START.SCR(SCR)
|
||
|
|
END.PMT=END.SCR(SCR)
|
||
|
|
MIN.LINE.NO=1
|
||
|
|
ADD.FLAG=''
|
||
|
|
INSERT.FLAG=''
|
||
|
|
IF ISNULL(INP(START.PMT)) OR INP(START.PMT) = @null.str THEN
|
||
|
|
ALL.LINES=1
|
||
|
|
END ELSE
|
||
|
|
ALL.LINES=COUNT(INP(START.PMT),@VM)+1
|
||
|
|
IF ALL.LINES EQ 1 THEN
|
||
|
|
ALL.LINES=0
|
||
|
|
ADD.FLAG=1
|
||
|
|
FOR PMT = START.PMT TO END.PMT
|
||
|
|
IF LEN(INP(PMT)<1>) > 0 THEN
|
||
|
|
ALL.LINES=1
|
||
|
|
ADD.FLAG=0
|
||
|
|
GO 705
|
||
|
|
END
|
||
|
|
NEXT PMT
|
||
|
|
END
|
||
|
|
END
|
||
|
|
705: PRINT @(-1):
|
||
|
|
PRINT TITLE[1,31]:" -Screen ":SCR:"-":PROCESS.ITEM<RV$PRO.SCREEN.HEADING,SCR>[1,20]:" ":
|
||
|
|
GOSUB PRINT.TIMEDATE
|
||
|
|
PRINT
|
||
|
|
Q=INP(1)
|
||
|
|
IF CV(1) # "" THEN Q=OCONV(Q,CV(1))
|
||
|
|
PRINT D.D(1)<1,RV$PRO.FLD.NAME>:'==> ':Q
|
||
|
|
PRINT "No. ":
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
PRINT FMT(D.D(I)<1,RV$PRO.FLD.NAME>,RFMT(I)[3,5]:'.':RFMT(I)):" ":
|
||
|
|
NEXT I
|
||
|
|
PRINT
|
||
|
|
FOR NO.LINES=MIN.LINE.NO TO ALL.LINES
|
||
|
|
PRINT FMT(NO.LINES,'3R'):" ":
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
Q=INP(I)<1,NO.LINES>
|
||
|
|
IF CV(I)#"" THEN Q=OCONV(Q,CV(I)) ; REPAINT=1
|
||
|
|
IF I=END.PMT THEN IF Q='' THEN GO 710
|
||
|
|
* fix for formatting sql null correctly
|
||
|
|
IF ISNULL(Q) THEN
|
||
|
|
PRINT FMT(" ",RFMT(I)):" ":
|
||
|
|
END ELSE
|
||
|
|
PRINT FMT(Q,RFMT(I)):" ":
|
||
|
|
END
|
||
|
|
710: NEXT I
|
||
|
|
PRINT
|
||
|
|
IF NO.LINES-MIN.LINE.NO >= MAX.LINES THEN MAX.LINE.NO= NO.LINES ; GO 720
|
||
|
|
NEXT NO.LINES
|
||
|
|
NO.LINES=ALL.LINES+1
|
||
|
|
MAX.LINE.NO=MIN.LINE.NO+MAX.LINES
|
||
|
|
IF NO.LINES LE MAX.LINE.NO+1 THEN PRINT FMT(NO.LINES,'3R')
|
||
|
|
IF INSERT.FLAG THEN LINE.NO=INSERT.FLAG ; INSERT.FLAG='' ; GO 740
|
||
|
|
IF ADD.FLAG THEN LINE.NO=NO.LINES ; GO 740
|
||
|
|
720:
|
||
|
|
PRINT
|
||
|
|
CALL *UVPRINTMSG(001581,"") ; * change which line number
|
||
|
|
INPUT LINE.NO
|
||
|
|
IF LINE.NO='' THEN IF MAX.LINE.NO LE ALL.LINES THEN MIN.LINE.NO=MAX.LINE.NO+1 ; GO 705
|
||
|
|
IF UPCASE(LINE.NO) = RV$CMD.TOP OR LINE.NO='' THEN FROM.SC2='' ; LINE.NO=1 ; RETURN
|
||
|
|
IF LINE.NO= RV$CMD.SKIP OR UPCASE(LINE.NO) = 'FILE' THEN
|
||
|
|
GOSUB UpdateDatabase
|
||
|
|
IF NOT(UpdateSuccess) THEN GOTO 720
|
||
|
|
FROM.SC2=''
|
||
|
|
LINE.NO=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF LINE.NO= RV$CMD.HELP THEN
|
||
|
|
PRINT "Enter the number of the line you wish to change; <CR>/<NL> = none or done; ?? for HELP."
|
||
|
|
GO 720
|
||
|
|
END
|
||
|
|
IF LINE.NO= RV$CMD.REDRAW THEN GO 705
|
||
|
|
IF LINE.NO= RV$CMD.EXTENDED.HELP THEN PMT=NO.PMTS+1 ; GOSUB 9200 ; GO 705
|
||
|
|
IF LINE.NO= RV$CMD.PROMPT THEN GO 720
|
||
|
|
740: IF LINE.NO = MAX.LINE.NO + 1 THEN MIN.LINE.NO=LINE.NO ; GO 705
|
||
|
|
IF LINE.NO<MIN.LINE.NO OR LINE.NO>MAX.LINE.NO THEN
|
||
|
|
PRINT @SYS.BELL:"Just ":MIN.LINE.NO:" - ":MAX.LINE.NO:" . Try again."
|
||
|
|
GO 720
|
||
|
|
END
|
||
|
|
IF NOT(UpdateType) THEN UpdateType = UpdateExisting
|
||
|
|
IF ALL.LINES LT LINE.NO THEN ADD.FLAG=1 ELSE ADD.FLAG=''
|
||
|
|
IF ADD.FLAG THEN ; * ADDING A NEW LINE
|
||
|
|
GOSUB 1000
|
||
|
|
END ELSE
|
||
|
|
GOSUB 130 ; * REPAINT SCREEN IN VERTICAL FORMAT
|
||
|
|
GOSUB 500 ; * MODIFY LINE
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.VERIFIELD> THEN CALL !SLEEP$(2500)
|
||
|
|
END
|
||
|
|
IF FILED THEN RETURN
|
||
|
|
IF UPCASE(Q) = RV$CMD.TOP THEN ADD.FLAG=''
|
||
|
|
IF ADD.FLAG THEN IF START.PMT=END.PMT THEN
|
||
|
|
LINE.NO+=1
|
||
|
|
NO.LINES+=1
|
||
|
|
GO 740
|
||
|
|
END
|
||
|
|
GO 705
|
||
|
|
1000:* NEW RECORD OR LINE ITEM ROUTINE
|
||
|
|
IF NOT(FROM.SC2) THEN
|
||
|
|
CALL *UVPRINTMSG(001606,"") ; * new record
|
||
|
|
UpdateType = UpdateNew
|
||
|
|
ST.PMT=2
|
||
|
|
END ELSE ST.PMT=START.PMT
|
||
|
|
QUIT=''
|
||
|
|
FOR PMT=ST.PMT TO END.PMT
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.DISPLAYONLY> THEN Q='' ; GO 1040 ; * NO SHOW MAINTENANCE
|
||
|
|
QUIT+=1
|
||
|
|
IF LAST.IN(PMT)#"" THEN
|
||
|
|
IF LAST.INPUT(PMT) # "" THEN
|
||
|
|
IF FROM.SC2 THEN
|
||
|
|
IF LINE.NO NE 1 THEN Q=LAST.INPUT(PMT)<1,LINE.NO-1> ELSE Q=LAST.INPUT(PMT)
|
||
|
|
END ELSE
|
||
|
|
Q=LAST.INPUT(PMT)
|
||
|
|
END
|
||
|
|
PRINT D.D(PMT)<1,RV$PRO.FLD.LOCATION>:"= ":Q ; * DISPLAY AUTO-DUPLICATED VALUES
|
||
|
|
GO 1040
|
||
|
|
END
|
||
|
|
END
|
||
|
|
1010:
|
||
|
|
GOSUB PROMPTER ; IF NOT(OK) THEN GO 1010
|
||
|
|
IF Q#"" THEN
|
||
|
|
IF INDEX(STD.RESP0,@FM:Q:@FM,1) THEN GO 1050 ; *006
|
||
|
|
IF Q='"' THEN
|
||
|
|
IF FROM.SC2 THEN
|
||
|
|
IF LINE.NO EQ 1 THEN PRINT "Nothing to repeat." ; GO 1010
|
||
|
|
Q=INP(PMT)<1,LINE.NO-1>
|
||
|
|
PRINT OCONV(Q,CV(PMT))
|
||
|
|
GO 1040
|
||
|
|
END ELSE
|
||
|
|
PRINT "Not valid on first Screen."
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF Q='##' AND FROM.SC2 THEN
|
||
|
|
PRINT @SYS.BELL:"You are trying to delete before you enter. Try again."
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
IF Q[1,1]='>' AND FROM.SC2 THEN
|
||
|
|
LINE.X=FIELD(Q,'#',2)
|
||
|
|
IF NOT(NUM(LINE.X)) THEN PRINT "WHAZZAT?" ; GO 1010
|
||
|
|
IF LINE.X LE 0 OR LINE.X GT ALL.LINES THEN
|
||
|
|
PRINT "Line number ":LINE.X:" has not been defined."
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
FOR I=START.PMT TO END.PMT
|
||
|
|
INP(I)=INSERT(INP(I),1,LINE.NO,0,INP(I)<1,LINE.X>)
|
||
|
|
NEXT I
|
||
|
|
GOSUB 130
|
||
|
|
ALL.LINES+=1
|
||
|
|
GO 1000
|
||
|
|
END
|
||
|
|
1015:*
|
||
|
|
FILL.C=D.D(PMT)<1,RV$PRO.FLD.FILL.CODE>
|
||
|
|
IF FILL.C#"" THEN Q=FMT(Q,RFMT(PMT):FILL.C)
|
||
|
|
IF VERIFY(PMT)#"" THEN
|
||
|
|
GOSUB 600
|
||
|
|
IF REPAINT THEN
|
||
|
|
INP(PMT)<1,LINE.NO> = Q
|
||
|
|
J=END.PMT
|
||
|
|
END.PMT=PMT
|
||
|
|
IF Q='' THEN END.PMT-=1
|
||
|
|
GOSUB 130
|
||
|
|
END.PMT=J
|
||
|
|
END
|
||
|
|
IF Q='' THEN GO 1010
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.VERIFIELD> THEN ; * Check if the ;* 003
|
||
|
|
CALL !SLEEP$(2500) ; * verifield data ;* 003
|
||
|
|
END ; * needs displayed.;* 003
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
IF QUIT=1 THEN IF FROM.SC2 THEN Q = RV$CMD.TOP ; RETURN
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.REQUIRED> = RV$PRO.VAL.REQUIRED THEN
|
||
|
|
CALL *UVPRINTMSG(001578,"") ; * entry required
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
END
|
||
|
|
!
|
||
|
|
* INSERT PROMPT/RESPONSE SPECIFIC LOGIC HERE
|
||
|
|
!
|
||
|
|
1040:
|
||
|
|
DMdelimiter = @VM
|
||
|
|
GOSUB ReplaceData
|
||
|
|
NEXT PMT
|
||
|
|
1045: IF FROM.SC2 THEN ALL.LINES+=1
|
||
|
|
RETURN
|
||
|
|
1050:* STANDARD EXCEPTIONS
|
||
|
|
IF Q= RV$CMD.HELP THEN GOSUB 9000 ; GO 1010
|
||
|
|
IF UPCASE(Q)= RV$CMD.TOP THEN RETURN
|
||
|
|
IF Q= RV$CMD.PROMPT THEN
|
||
|
|
PMT=PMT-1
|
||
|
|
IF PMT<START.PMT THEN Q = RV$CMD.TOP ; RETURN
|
||
|
|
IF PMT=1 THEN Q = RV$CMD.TOP ; RETURN
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.DISPLAYONLY> THEN GO 1050 ; * DON'T BACK INTO A NO.SHOW
|
||
|
|
CALL *UVPRINTMSG(001576,"") ; * backing up
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
IF Q= RV$CMD.SKIP THEN
|
||
|
|
FOR I= PMT TO END.PMT
|
||
|
|
IF D.D(I)<1,RV$PRO.FLD.REQUIRED>= RV$PRO.VAL.REQUIRED THEN
|
||
|
|
PMT=I
|
||
|
|
GO 1010
|
||
|
|
END
|
||
|
|
NEXT I
|
||
|
|
GO 1045
|
||
|
|
END
|
||
|
|
IF Q= RV$CMD.REDRAW THEN GOSUB 130 ; GO 1010
|
||
|
|
IF Q= RV$CMD.EXTENDED.HELP THEN GOSUB 9200 ; GOSUB 130 ; GO 1010
|
||
|
|
IF UPCASE(Q) = RV$CMD.DELETE THEN PRINT @SYS.BELL:"Not valid here." ; GO 1010
|
||
|
|
GO 1015 ; * INPUT OK, JUST LOOKED LIKE AN EXCEPTION (T,O,P,ETC.)
|
||
|
|
9000:* EXPLAINAITON ROUTINE
|
||
|
|
IF PROCESS THEN
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.BRIEFHELP>='' THEN
|
||
|
|
9050: PRINT "No explanation has been provided for this Prompt."
|
||
|
|
RETURN
|
||
|
|
END ELSE
|
||
|
|
PRINT D.D(PMT)<1,RV$PRO.FLD.BRIEFHELP>
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
READ X FROM DICT.DATA.FILE,D.D(PMT)<1,RV$PRO.FLD.BRIEFHELP> ELSE GO 9050
|
||
|
|
X=FIELD(X<1>,' ',2,999)
|
||
|
|
IF LEN(X) LT 1 THEN GO 9050
|
||
|
|
PRINT X
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
9200:* PARAGRAPH ENTRY POINT
|
||
|
|
IF PMT=0 THEN
|
||
|
|
Q='REVISE*CHANGE'
|
||
|
|
END ELSE
|
||
|
|
IF PMT=NO.PMTS+1 THEN
|
||
|
|
Q='REVISE*CHANGEL'
|
||
|
|
END ELSE
|
||
|
|
Q=PROCESS:'*':D.D(PMT)<1,RV$PRO.FLD.DISPLAY>
|
||
|
|
Q = UPCASE(Q) ; *099
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF DISC.FILE.NOT.OPEN THEN
|
||
|
|
OPENCHECK '',REVISE.DISCUSSIONS TO DE ELSE
|
||
|
|
OPENCHECK '','NEWACC' TO NEWACC.FILE ELSE
|
||
|
|
PRINT "Can't open NEWACC"
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
READ NEWACC.RECORD FROM NEWACC.FILE,REVISE.DISCUSSIONS ELSE
|
||
|
|
PRINT "Can't find ":REVISE.DISCUSSIONS
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
* --- Write the record out to the VOC.
|
||
|
|
WRITE NEWACC.RECORD TO DEVSYS.VOC.FILE,REVISE.DISCUSSIONS
|
||
|
|
OPENCHECK '',REVISE.DISCUSSIONS TO DE ELSE
|
||
|
|
PRINT "The ":REVISE.DISCUSSIONS:" file cannot be found."
|
||
|
|
PRINT "Sorry, no extended explanations."
|
||
|
|
GO TO 9210
|
||
|
|
END
|
||
|
|
END
|
||
|
|
DISC.FILE.NOT.OPEN=''
|
||
|
|
END
|
||
|
|
READ X FROM DE,Q ELSE PRINT "No extended discussion has been provided for this Prompt." ; GO 9210
|
||
|
|
PRINT @(-1):"Discussion of ==>":D.D(PMT)<1,RV$PRO.FLD.DISPLAY>
|
||
|
|
PRINT
|
||
|
|
I=1
|
||
|
|
LOOP REMOVE Q FROM X SETTING XMARK
|
||
|
|
PRINT Q
|
||
|
|
I+=1
|
||
|
|
IF I > (@CRTHIGH - 4) THEN
|
||
|
|
PRINT "Press <RETURN> to continue...":
|
||
|
|
INPUT Q
|
||
|
|
IF Q[1,1] EQ 'Q' THEN RETURN
|
||
|
|
PRINT @(-1):
|
||
|
|
I=0
|
||
|
|
END
|
||
|
|
WHILE XMARK
|
||
|
|
REPEAT
|
||
|
|
9210: PRINT
|
||
|
|
PRINT "Press <RETURN>/<NEW LINE> to continue":
|
||
|
|
INPUT Q
|
||
|
|
RETURN
|
||
|
|
***********************************************************************
|
||
|
|
UpdateDatabase:
|
||
|
|
Q = ''
|
||
|
|
UpdateSuccess = TRUE
|
||
|
|
IF DELETE.ID NE "" AND DELETE.ID # INP(1) THEN
|
||
|
|
READU DF.RECORD FROM DATA.FILE, INP(1)
|
||
|
|
ELSE
|
||
|
|
DF.ERROR = STATUS()
|
||
|
|
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
|
||
|
|
CALL *UVPRINTMSG(970012,INP(1))
|
||
|
|
UpdateSuccess = FALSE
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
ELSE IF DF.ERROR = 3 THEN
|
||
|
|
CALL *UVPRINTMSG(47007,INP(1))
|
||
|
|
UpdateSuccess = FALSE
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
ELSE IF DF.ERROR = 4 THEN
|
||
|
|
* Warning message already issued - no need to repeat ourselves
|
||
|
|
* CALL *UVPRINTMSG(47006,INP(1))
|
||
|
|
UpdateSuccess = FALSE
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
END
|
||
|
|
FILED=1
|
||
|
|
IF NOT(UpdateType) THEN RELEASE DATA.FILE, INP(1) ; RETURN
|
||
|
|
|
||
|
|
* A call to SQLINTCHK is made with the RECORD that is going to
|
||
|
|
* be written so that we can determine if this write is going
|
||
|
|
* to pass integrity constraints before other files are updated
|
||
|
|
* therefore alleviating the need to worry about backing out any
|
||
|
|
* changes.
|
||
|
|
|
||
|
|
SQLcheck = ITEM
|
||
|
|
ProcessFileFlag = FALSE
|
||
|
|
|
||
|
|
IF UpdateType = UpdateNew THEN
|
||
|
|
SQLcheck = ''
|
||
|
|
IF BATCH.AMC THEN
|
||
|
|
IF NOT(BATCH.NO) THEN
|
||
|
|
READU PROCESS.ITEM FROM PROCESS.FILE,PROCESS ELSE
|
||
|
|
RELEASE PROCESS.FILE,PROCESS
|
||
|
|
PRINT "This Process Item has disappeared - ABORT!"
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
ProcessFileFlag = TRUE
|
||
|
|
SaveBATCH.NO = BATCH.NO
|
||
|
|
BATCH.NO=PROCESS.ITEM<RV$PRO.BATCH.NO>
|
||
|
|
IF BATCH.NO='' THEN BATCH.NO=1
|
||
|
|
PROCESS.ITEM<RV$PRO.BATCH.NO> = BATCH.NO+1
|
||
|
|
WRITE PROCESS.ITEM ON PROCESS.FILE, PROCESS
|
||
|
|
END
|
||
|
|
SQLcheck<BATCH.AMC> = BATCH.NO
|
||
|
|
END
|
||
|
|
IF ENTRY.DATE.AMC THEN SQLcheck<ENTRY.DATE.AMC> = DATE()
|
||
|
|
END
|
||
|
|
FOR PMT = 2 TO NO.PMTS
|
||
|
|
AMC = D.D(PMT)<1,RV$PRO.FLD.LOCATION>
|
||
|
|
SQLcheck<AMC> = INP(PMT)
|
||
|
|
NEXT PMT
|
||
|
|
IF DTYPE OR ITYPE THEN
|
||
|
|
TempRec = SQLcheck
|
||
|
|
GOSUB CLEAR.OPCODES
|
||
|
|
SQLcheck = TempRec
|
||
|
|
END
|
||
|
|
IO.VAR = 2
|
||
|
|
CALL @SQLINTCHK(SQLcheck,DATA.FILE,INP(1),UpdateFilename,IO.VAR)
|
||
|
|
IF IO.VAR<1> THEN
|
||
|
|
UpdateSuccess = FALSE
|
||
|
|
FILED = ""
|
||
|
|
SQLcheck = ""
|
||
|
|
IF ProcessFileFlag THEN
|
||
|
|
RELEASE PROCESS.FILE, PROCESS
|
||
|
|
BATCH.NO = SaveBATCH.NO
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
END ELSE
|
||
|
|
SQLcheck = ""
|
||
|
|
IF ProcessFileFlag THEN
|
||
|
|
PROCESS.ITEM<RV$PRO.BATCH.NO> = BATCH.NO + 1
|
||
|
|
WRITE PROCESS.ITEM ON PROCESS.FILE, PROCESS
|
||
|
|
END
|
||
|
|
IF BATCH.AMC THEN ITEM<BATCH.AMC> = SQLcheck<BATCH.AMC>
|
||
|
|
IF ENTRY.DATE.AMC THEN ITEM<ENTRY.DATE.AMC> = SQLcheck<ENTRY.DATE.AMC>
|
||
|
|
END
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF LAST.IN(PMT) #"" THEN LAST.INPUT(PMT)=INP(PMT)
|
||
|
|
NEXT PMT
|
||
|
|
|
||
|
|
IF DELETE.ID NE "" THEN
|
||
|
|
DELETE DATA.FILE, DELETE.ID
|
||
|
|
KEY=DELETE.ID
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF VERIFY(PMT)<1,3> THEN GOSUB DeleteXReference
|
||
|
|
NEXT PMT
|
||
|
|
END
|
||
|
|
|
||
|
|
IF UpdateType = UpdateExisting THEN
|
||
|
|
IF BATCH.TOTAL.AMC THEN
|
||
|
|
IF ITEM<BATCH.AMC>=BATCH.NO THEN
|
||
|
|
IF LINE.ITEMS NE NO.PMTS THEN
|
||
|
|
I=1
|
||
|
|
LOOP Q=ITEM<LINE.ITEMS+1,I> UNTIL Q='' DO
|
||
|
|
BATCH.TOTAL=BATCH.TOTAL-ITEM<BATCH.TOTAL.AMC,I>
|
||
|
|
I=I+1
|
||
|
|
REPEAT
|
||
|
|
END ELSE
|
||
|
|
BATCH.TOTAL=BATCH.TOTAL-ITEM<BATCH.TOTAL.AMC>
|
||
|
|
END
|
||
|
|
END
|
||
|
|
END
|
||
|
|
KEY=OLD(1)
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF VERIFY(PMT)<1,3> THEN
|
||
|
|
IF INP(PMT) NE OLD(PMT) THEN GOSUB DeleteXReference
|
||
|
|
END
|
||
|
|
NEXT PMT
|
||
|
|
IF AUDIT.FILE NE '' THEN
|
||
|
|
AUDIT.ITEM=''
|
||
|
|
FOR I=2 TO NO.PMTS
|
||
|
|
IF OLD(I) NE INP(I) THEN
|
||
|
|
AMC=D.D(I)<1,RV$PRO.FLD.LOCATION>
|
||
|
|
AUDIT.ITEM<AMC> = OLD(I)
|
||
|
|
END
|
||
|
|
NEXT I
|
||
|
|
A.KEY=FNAME:"@":OLD(1):"@":DATE():"@":TIME()
|
||
|
|
IF DELETE.ID NE "" THEN A.KEY=A.KEY:"@":INP(1)
|
||
|
|
WRITE AUDIT.ITEM ON AF,A.KEY
|
||
|
|
END
|
||
|
|
END
|
||
|
|
FOR PMT=2 TO NO.PMTS
|
||
|
|
AMC=D.D(PMT)<1,RV$PRO.FLD.LOCATION>
|
||
|
|
ITEM<AMC> = INP(PMT)
|
||
|
|
IF VERIFY(PMT)<1,3> THEN IF UpdateType = UpdateNew OR DELETE.ID NE '' OR OLD(PMT) NE INP(PMT) THEN
|
||
|
|
LOOP
|
||
|
|
REMOVE Q FROM INP(PMT) SETTING FMC
|
||
|
|
I = 1
|
||
|
|
LOOP
|
||
|
|
J = FIELD(Q,' ',I)
|
||
|
|
UNTIL J = '' DO
|
||
|
|
READU X FROM VERIFILE(VERIFY(PMT)<1,3>),J ELSE X=''
|
||
|
|
X = INSERT(X,1,-1,0,INP(1))
|
||
|
|
WRITE X ON VERIFILE(VERIFY(PMT)<1,3>),J
|
||
|
|
I += 1
|
||
|
|
REPEAT
|
||
|
|
WHILE FMC DO
|
||
|
|
REPEAT
|
||
|
|
END
|
||
|
|
NEXT PMT
|
||
|
|
IF DTYPE OR ITYPE THEN
|
||
|
|
TempRec = ITEM
|
||
|
|
GOSUB CLEAR.OPCODES
|
||
|
|
ITEM = TempRec
|
||
|
|
END
|
||
|
|
WRITE ITEM ON DATA.FILE,INP(1) ON ERROR
|
||
|
|
MSGID = STATUS()
|
||
|
|
MSGARG = ""
|
||
|
|
IF MSGID = 47006 OR MSGID = 47007 THEN
|
||
|
|
MSGARG = INP(1)
|
||
|
|
END
|
||
|
|
CALL *UVPRINTMSG(MSGID,MSGARG);
|
||
|
|
PRINT "Press <RETURN> to continue":
|
||
|
|
INPUT Q
|
||
|
|
UpdateSucess = FALSE
|
||
|
|
FILED = ""
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
ELSE
|
||
|
|
IF STATUS() = IntegrityViolation THEN
|
||
|
|
IO.VAR = 2
|
||
|
|
CALL @SQLINTCHK(ITEM,DATA.FILE,INP(1),UpdateFilename,IO.VAR)
|
||
|
|
UpdateSucess = FALSE
|
||
|
|
FILED = ""
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF BATCH.TOTAL.AMC THEN
|
||
|
|
IF ITEM<BATCH.AMC>=BATCH.NO THEN
|
||
|
|
IF LINE.ITEMS NE NO.PMTS THEN
|
||
|
|
I = 1
|
||
|
|
LOOP
|
||
|
|
Q = ITEM<LINE.ITEMS+1,I>
|
||
|
|
UNTIL Q = '' DO
|
||
|
|
BATCH.TOTAL += ITEM<BATCH.TOTAL.AMC,I>
|
||
|
|
I += 1
|
||
|
|
REPEAT
|
||
|
|
END ELSE
|
||
|
|
BATCH.TOTAL += ITEM<BATCH.TOTAL.AMC>
|
||
|
|
END
|
||
|
|
END
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
***********************************************************************
|
||
|
|
DeleteXReference:
|
||
|
|
K = 1
|
||
|
|
LOOP
|
||
|
|
REMOVE L FROM OLD(PMT) SETTING FMC
|
||
|
|
I = 1
|
||
|
|
LOOP
|
||
|
|
Q = FIELD(L,' ',I)
|
||
|
|
UNTIL Q = '' DO
|
||
|
|
READU X FROM VERIFILE(VERIFY(PMT)<1,3>), Q THEN
|
||
|
|
J = 0
|
||
|
|
LOOP
|
||
|
|
J += 1
|
||
|
|
UNTIL X<1,J> = "" DO
|
||
|
|
IF X<1,J> = KEY THEN
|
||
|
|
X = DELETE(X,1,J,0)
|
||
|
|
J -= 1
|
||
|
|
END
|
||
|
|
REPEAT
|
||
|
|
IF X NE '' THEN
|
||
|
|
WRITE X ON VERIFILE(VERIFY(PMT)<1,3>),Q
|
||
|
|
END ELSE
|
||
|
|
DELETE VERIFILE(VERIFY(PMT)<1,3>),Q
|
||
|
|
END
|
||
|
|
END
|
||
|
|
I += 1
|
||
|
|
REPEAT
|
||
|
|
K += 1
|
||
|
|
WHILE FMC DO
|
||
|
|
REPEAT
|
||
|
|
RETURN
|
||
|
|
***********************************************************************
|
||
|
|
9900:* WRAP UP AND QUIT ROUTINE
|
||
|
|
IF BATCH.TOTAL THEN
|
||
|
|
FOR PMT=1 TO NO.PMTS
|
||
|
|
IF D.D(PMT)<1,RV$PRO.FLD.LOCATION>=BATCH.TOTAL.AMC THEN GO 9910
|
||
|
|
NEXT PMT
|
||
|
|
IF ASSIGNED(DEVSYS.VOC.FILE) THEN
|
||
|
|
CLOSE DEVSYS.VOC.FILE
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
9910: IF CV(PMT)#"" THEN BATCH.TOTAL=OCONV(BATCH.TOTAL,CV(PMT))
|
||
|
|
PRINT @(-1):'Total of ':D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:' in Batch #':BATCH.NO
|
||
|
|
PRINT "was ": BATCH.TOTAL
|
||
|
|
PRINT
|
||
|
|
END
|
||
|
|
9920:* Close the VOC file and exit
|
||
|
|
IF ASSIGNED(DEVSYS.VOC.FILE) THEN
|
||
|
|
CLOSE DEVSYS.VOC.FILE
|
||
|
|
END
|
||
|
|
DEVSYS.DICT.SWITCH = 0
|
||
|
|
IF ASSIGNED(DEVSYS.DICT.FILE) THEN
|
||
|
|
CLOSE DEVSYS.DICT.FILE
|
||
|
|
END
|
||
|
|
DEVSYS.DICT.FILE.NAME = ""
|
||
|
|
IF ASSIGNED(DEVSYS.DATA.FILE) THEN
|
||
|
|
CLOSE DEVSYS.DATA.FILE
|
||
|
|
END
|
||
|
|
DEVSYS.DATA.FILE.NAME = ""
|
||
|
|
IF ASSIGNED(DEVSYS.R.FILE) THEN
|
||
|
|
CLOSE DEVSYS.R.FILE
|
||
|
|
END
|
||
|
|
DEVSYS.R.FILE.NAME = ""
|
||
|
|
RETURN
|
||
|
|
RESET.NEXT.AVAILABLE:
|
||
|
|
READU Q FROM DICT.DATA.FILE, '&NEXT.AVAILABLE&' ELSE Q='X':@FM
|
||
|
|
Q<2> = USING.NEXT.AVAILABLE
|
||
|
|
WRITE Q ON DICT.DATA.FILE,'&NEXT.AVAILABLE&'
|
||
|
|
RETURN
|
||
|
|
PROMPTER:* PATTERN MATCHING SUBROUTINE
|
||
|
|
VALID=D.D(PMT)<1,RV$PRO.FLD.MATCHFIELD>
|
||
|
|
REQUIRED=D.D(PMT)<1,RV$PRO.FLD.REQUIRED>
|
||
|
|
|
||
|
|
* SETUP VARIABLES
|
||
|
|
ANS=""
|
||
|
|
OK=0
|
||
|
|
*MAINTAIN PROMPTING
|
||
|
|
BOTTOM.SCR:
|
||
|
|
PRINT D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:"=":
|
||
|
|
|
||
|
|
PMT.LOOP:
|
||
|
|
|
||
|
|
INPUT ANS
|
||
|
|
IF UPCASE(ANS[1,2]) EQ "C/" THEN
|
||
|
|
FROM.STRING = FIELD(ANS,"/",2)
|
||
|
|
TO.STRING = FIELD(ANS,"/",3)
|
||
|
|
CURRENT.DATA = OCONV(INP(PMT)<1,LINE.NO>,CV(PMT))
|
||
|
|
LEN.OF.FROM.STRING = LEN(FROM.STRING)
|
||
|
|
START.POS.OF.FROM.STRING = INDEX(CURRENT.DATA,FROM.STRING,1)
|
||
|
|
IF START.POS.OF.FROM.STRING EQ 0 THEN
|
||
|
|
ANS = CURRENT.DATA
|
||
|
|
END ELSE
|
||
|
|
CHANGED.DATA=CURRENT.DATA[1,START.POS.OF.FROM.STRING-1]
|
||
|
|
CHANGED.DATA:=TO.STRING
|
||
|
|
CHANGED.DATA:=CURRENT.DATA[START.POS.OF.FROM.STRING+LEN.OF.FROM.STRING,9999]
|
||
|
|
ANS = CHANGED.DATA
|
||
|
|
END
|
||
|
|
PRINT ANS
|
||
|
|
END
|
||
|
|
Q=ANS
|
||
|
|
IF ANS # "" THEN
|
||
|
|
IF INDEX(STD.RESP0,@FM:UPCASE(ANS):@FM,1) THEN
|
||
|
|
ANS = UPCASE(ANS)
|
||
|
|
Q = ANS
|
||
|
|
OK = 1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
IF FROM.SC2 THEN
|
||
|
|
IF INDEX(STD2.RESP,@FM:ANS:@FM,1) THEN OK=1 ; RETURN ; *006
|
||
|
|
END
|
||
|
|
INPUT.LEN = LEN(ANS)
|
||
|
|
IF INPUT.LEN = 0 THEN INPUT.LEN = 1
|
||
|
|
IF PMT=1 THEN IF UPCASE(ANS) = RV$CMD.END OR UPCASE(ANS) = RV$CMD.QUIT[1,INPUT.LEN] THEN OK=1 ; RETURN
|
||
|
|
END ELSE
|
||
|
|
IF FROM.SC2 THEN OK=1 ; RETURN
|
||
|
|
IF REQUIRED = RV$PRO.VAL.REQUIRED THEN
|
||
|
|
* entry required
|
||
|
|
CALL *UVPRINTMSG(001578,"")
|
||
|
|
GO BOTTOM.SCR
|
||
|
|
END
|
||
|
|
Q=ANS
|
||
|
|
OK=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
GOSUB COMPARE
|
||
|
|
IF OK THEN
|
||
|
|
IF CV(PMT)#"" THEN
|
||
|
|
OK=0
|
||
|
|
GOSUB CONVERT
|
||
|
|
IF NOT(OK) THEN
|
||
|
|
GO BOTTOM.SCR
|
||
|
|
END
|
||
|
|
END
|
||
|
|
Q=ANS
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
GO BOTTOM.SCR
|
||
|
|
COMPARE:
|
||
|
|
* START VALIDATION LOOP
|
||
|
|
IF VALID="" THEN
|
||
|
|
OK=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
INPUT.LEN = LEN(ANS)
|
||
|
|
IF INPUT.LEN = 0 THEN INPUT.LEN = 1
|
||
|
|
IF PMT=1 THEN IF UPCASE(ANS) = RV$CMD.QUIT[1,INPUT.LEN] OR UPCASE(ANS) = RV$CMD.END THEN OK=1 ; RETURN
|
||
|
|
I=0
|
||
|
|
LOOP
|
||
|
|
I += 1
|
||
|
|
VUNIT=FIELD(VALID,@SVM,I)
|
||
|
|
UNTIL VUNIT='' DO
|
||
|
|
IF VUNIT[1,1] = "(" THEN
|
||
|
|
* Range check required if VUNIT looks like "(LOW,HIGH)":
|
||
|
|
IF VUNIT MATCHES "'('0N','0N')'" THEN
|
||
|
|
IF NOT(NUM(ANS)) THEN GO TRY.NEXT
|
||
|
|
LOW=MATCHFIELD(VUNIT,"1X0N1X0N1X",2)
|
||
|
|
HIGH=MATCHFIELD(VUNIT,"1X0N1X0N1X",4)
|
||
|
|
IF ANS < LOW OR ANS > HIGH THEN GOTO TRY.NEXT
|
||
|
|
OK=1
|
||
|
|
GOTO TRY.NEXT
|
||
|
|
END
|
||
|
|
* Upper bound check required if VUNIT looks like "(NNNN)":
|
||
|
|
VUNIT=FIELD(VUNIT[2,99],')',1)
|
||
|
|
IF NUM(VUNIT) THEN
|
||
|
|
IF NOT(NUM(ANS)) THEN GO TRY.NEXT
|
||
|
|
IF ANS LT 0 OR ANS GT VUNIT THEN GO TRY.NEXT
|
||
|
|
OK=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
* Date conversion check required if VUNIT looks like "D...":
|
||
|
|
IF VUNIT[1,1]="D" THEN
|
||
|
|
GOSUB DATE.CONVERSION
|
||
|
|
GOTO TRY.NEXT
|
||
|
|
END
|
||
|
|
* Number conversion check required if VUNIT looks like "MD...":
|
||
|
|
IF VUNIT[1,2]="MD" THEN
|
||
|
|
GOSUB DECIMAL.CONVERSION
|
||
|
|
GO TRY.NEXT
|
||
|
|
END
|
||
|
|
END
|
||
|
|
* ITS NOT A CONVERSION, MUST BE A PATTERN *
|
||
|
|
IF ANS MATCHES VUNIT THEN
|
||
|
|
OK=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
TRY.NEXT:IF OK THEN RETURN
|
||
|
|
REPEAT
|
||
|
|
* invalid conversion code (or pattern, or range check)
|
||
|
|
* Message = "%s" does not pass input validation (%s)
|
||
|
|
CALL *UVPRINTMSG(001570,ANS:@FM:CONVERT(@SVM, '/', VALID))
|
||
|
|
OK=0
|
||
|
|
RETURN
|
||
|
|
DATE.CONVERSION:
|
||
|
|
ANS1 = ICONV(ANS,VUNIT)
|
||
|
|
IF STATUS() THEN
|
||
|
|
IF ANS = @NULL.STR THEN
|
||
|
|
OK = 1
|
||
|
|
END ELSE
|
||
|
|
GO BAD.CONV
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
OK = 1
|
||
|
|
ANS=ANS1
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
DECIMAL.CONVERSION:
|
||
|
|
IF NUM(ANS) THEN ANS1 = ICONV(ANS,VUNIT) ELSE RETURN
|
||
|
|
IF STATUS() THEN
|
||
|
|
IF ANS = @NULL.STR THEN
|
||
|
|
OK = 1
|
||
|
|
END ELSE
|
||
|
|
GO BAD.CONV
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
OK = 1
|
||
|
|
ANS = ANS1
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
CONVERT:
|
||
|
|
ANS1 = ICONV(ANS,CV(PMT))
|
||
|
|
IF STATUS() THEN
|
||
|
|
IF ANS = @NULL.STR THEN
|
||
|
|
OK = 1
|
||
|
|
END ELSE
|
||
|
|
GO BAD.CONV
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
OK = 1
|
||
|
|
ANS = ANS1
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
BAD.CONV:
|
||
|
|
IF STATUS() EQ 3 THEN PRINT "WARNING - That is a funny looking date!" ; ANS=ANS1 ; OK=1 ; RETURN
|
||
|
|
IF STATUS() EQ 2 THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT D.D(PMT)<1,RV$PRO.FLD.DISPLAY>:" has an invalid conversion (":CV(PMT):")"
|
||
|
|
GO 9920
|
||
|
|
END
|
||
|
|
PRINT @SYS.BELL:"'":ANS:"' is not a legal ":
|
||
|
|
X=CV(PMT)
|
||
|
|
IF X[1,1] EQ 'D' THEN PRINT 'date (':X:').' ; RETURN
|
||
|
|
IF X[1,2] EQ 'MD' THEN PRINT 'decimal number (':X:').' ; RETURN
|
||
|
|
IF X[1,2] EQ 'MB' THEN PRINT 'binary number (':X:').' ; RETURN
|
||
|
|
IF X[1,2] EQ 'MO' THEN PRINT 'octal number (':X:').' ; RETURN
|
||
|
|
IF X[1,2] EQ 'MX' THEN PRINT 'hexadecimal number (':X:').' ; RETURN
|
||
|
|
IF X[1,2] EQ 'MT' THEN PRINT 'time of day (':X:').' ; RETURN
|
||
|
|
PRINT "Conversion error."
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
CLEAR.OPCODES:
|
||
|
|
IF ORIGINAL.TYPE # TempRec<2> THEN
|
||
|
|
MATPARSE ITEM.ARRAY FROM TempRec, @FM
|
||
|
|
TempRec = ""
|
||
|
|
BEGIN CASE
|
||
|
|
CASE ITYPE = 1
|
||
|
|
FOR I = 1 TO 13
|
||
|
|
TempRec := ITEM.ARRAY(I):@FM
|
||
|
|
NEXT I
|
||
|
|
CASE DTYPE = 1
|
||
|
|
FOR I = 1 TO 7
|
||
|
|
TempRec := ITEM.ARRAY(I):@FM
|
||
|
|
NEXT I
|
||
|
|
TempRec = TempRec[1,LEN(TempRec)-1]
|
||
|
|
END CASE
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
PRINT.TIMEDATE:
|
||
|
|
DATE.CREATED = DATE()
|
||
|
|
TIME.CREATED = TIME()
|
||
|
|
DATETIME = OCONV(DATE.CREATED,'DWAL')[1,3]:' '
|
||
|
|
DATETIME := OCONV(DATE.CREATED,'DMAL')[1,3]:' '
|
||
|
|
DATETIME := OCONV(DATE.CREATED,'DD'):' '
|
||
|
|
DATETIME := OCONV(TIME.CREATED,'MTS'):' '
|
||
|
|
DATETIME := OCONV(DATE.CREATED,'DY4')
|
||
|
|
PRINT DATETIME
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
ReplaceData:
|
||
|
|
PMTstring = ""
|
||
|
|
PMTsubstring = ""
|
||
|
|
PMTvalues = 0
|
||
|
|
IF ISNULL(Q) THEN
|
||
|
|
PMTinput = @null.str
|
||
|
|
END ELSE
|
||
|
|
PMTinput = Q
|
||
|
|
END
|
||
|
|
ReplaceDone = FALSE
|
||
|
|
LOOP
|
||
|
|
REMOVE PMTtoken FROM INP(PMT) SETTING RMdelimiter
|
||
|
|
IF ISNULL(PMTtoken) THEN
|
||
|
|
PMTtoken = @null.str
|
||
|
|
END
|
||
|
|
WHILE RMdelimiter DO
|
||
|
|
RMdelimiter = CHAR(256 - RMdelimiter)
|
||
|
|
BEGIN CASE
|
||
|
|
CASE RMdelimiter = DMdelimiter
|
||
|
|
PMTvalues += 1
|
||
|
|
IF PMTvalues = LINE.NO THEN
|
||
|
|
PMTsubstring = PMTinput:RMdelimiter
|
||
|
|
ReplaceDone = TRUE
|
||
|
|
END ELSE
|
||
|
|
PMTsubstring := PMTtoken:RMdelimiter
|
||
|
|
END
|
||
|
|
PMTstring := PMTsubstring
|
||
|
|
PMTsubstring = ""
|
||
|
|
CASE RMdelimiter < DMdelimiter
|
||
|
|
IF PMTvalues = LINE.NO ELSE
|
||
|
|
PMTsubstring := PMTtoken:RMdelimiter
|
||
|
|
END
|
||
|
|
CASE RMdelimiter > DMdelimiter
|
||
|
|
PRINT "Invalid data"
|
||
|
|
END CASE
|
||
|
|
REPEAT
|
||
|
|
|
||
|
|
IF ReplaceDone THEN
|
||
|
|
PMTsubstring := PMTtoken
|
||
|
|
END ELSE
|
||
|
|
PMTvalues += 1
|
||
|
|
IF PMTvalues = LINE.NO THEN
|
||
|
|
PMTsubstring = ""
|
||
|
|
END ELSE
|
||
|
|
PMTsubstring := PMTtoken:DMdelimiter
|
||
|
|
END
|
||
|
|
PMTsubstring := PMTinput
|
||
|
|
END
|
||
|
|
PMTstring := PMTsubstring
|
||
|
|
INP(PMT) = PMTstring
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
END
|