Well, I made it this far and I'm still interested. Can I install and play with it?
Sure, copy and paste the following to TCL in your development account and you're off:
These should compile as is for Universe. For D3 or others, the compiler will catch any compatiblity issues (there should not be many).
CREATE.BFILE BP.WRM DYNAMIC
CREATE.FILE HELP.WRM DYNAMIC DYNAMIC
CREATE.FILE LOCK.WRM DYNAMIC DYNAMIC
CREATE.FILE NEXT.IDS DYNAMIC DYNAMIC
ED BP.WRM BILD
I
************************************************************
******************** BILD
************************************************************
PROGRAM = "BILD"
******************** PROGRAMMERS LOG ********************
* 01-23-13 WRM 11511 ADDED ACCESS CONTROL.
* 01-16-13 WRM 11308 CHANGE ALL 'FILE.REC<0>' TO 'KEY'.
* 08-28-12 WRM 10663 ADDED NO.KEY.IN.LOOKUP & LOOKUP.ALL FLAGS.
* 11-23-10 WRM 10663 PUT IN COMMENTS EXPLAINING WHAT COMMON.CODE DOES.
* 11-08-10 WRM 10663 IF FIELD LENGTH IS LESS THAN 3, REPRINT SCREEN AFTER PROMPT.
* BILLM - 01/26/2009 - REQUEST#: 10294 ADDED ABILITY TO CHANGE KEY, HOME & FIELD PROMPTS.
* 10-22-10 WRM NONE. USE FIELD 7 OF DICTIONARY FOR CONVERSION IF NOTHING IN FIELD 8.
* 08-26-10 BILLM TBD ADDED REQUIRED FLAGS.
* 08-18-09 BILLM FIXED BUG WHEN LAST FIELD IS DISPLAY ONLY.
* 07-28-09 BILLM CHANGE MV.CNT FROM L#5 BACK TO L#4 TO GAIN MORE SCREEN REAL ESTATE.
* WRM - 05/30/2007 - ADDED PRINTING OF TOP & BOTTOM BORDER.
* WRM - 03/30/2007 - SLOWED DOWN PROCESSING FOR DEMO PURPOSES...
* WRM - 12/14/2006 - IF INVALID DICTIONARY, STOP INSTEAD OF SKIP.
* WRM - 09/28/2006 - START PRINTING ACCOUNT NAME HERE.
* WRM - 02/23/2006 - CHANGED MAIN FILE OPEN LINE TO WORK WITH FILEWRITE.
* WRM LOOK FOR 01/26/2006 TO FIND THESE CHANGES: HAD TO MOVE 'LOOP' FOR MV PROMPTS.
* WRM LOOK FOR 01/26/2006 TO FIND THESE CHANGES: ADDED AFTER.READ LOGIC.
* bmontg - 12/28/2004 - TOOK OUT ALL GO(TO)S.
* BILL - 10/10/2003 - ADDED CODE FOR SIMPLE UNIDATA TRANS() TYPE DICTIONARIES.
* BILL - 10/10/2003 - MODIFIED FOR UNIDATA.
* WRM - 01/04/1999 - DISPLAY MV COUNTER L#4 INSTEAD OF L#4
* WRM - 01/04/1999 - IF FIELD IS SECONDARY KEY, ONLY USE CONVERSION FOR CHECKING AGAINST SECONDARY FILE.
* WRM - 01/19/1998 - BUG FIX! IF DIFFERENT MV.DISPLAY SIZES, SHOULD BE USING THE SMALLER OF THE TWO. IT WAS USING THE LARGEST.
* WRM.WIN - 04/22/1997 - TOOK OUT 'IF CHG = P LOGIC. (USE F & B NOW)
* WRM - 03/03/1997 - CLEANED UP A BIT...
*********************************************************
*
* THIS PROGRAM WILL GENERATE CODE BASED ON THE SCREEN YOU PASS IT.
* $OPTIONS EXT
* $BASICTYPE "P"
*
*
* FOR THIS TO WORK, SEVERAL ASSUMPTIONS MUST BE MADE:
* 1. ALL MAINTAINABLE PROMPTS WILL BE NUMBERED AS SUCH 1. 2. 3. ... 11. 12.
* 2. ONLY SIMPLE DICTIONARY ITEMS WILL BE USED (NOTHING IN ATTB 8)
* 3. DICTIONARY ITEMS WILL BE SURROUNDED BY [ ]
* 4. A MAXIMUM OF 40 MAINTAINABLE PROMPTS.
* 5. MULTIVALUED FIELDS WILL BE IDENTIFIED BY THE SAME PROMPT NUMBER ON
* IMMEDIATELY FOLLOWING LINES. IE: 17. [INVENTORY.NUMBER INVENTORY.DESC]
* 17.
* 17.
* 17.
* 6. THE MAIN FILENAME WILL BE IN THE 1ST ATTRIBUTE OF THE SCREEN RECORD.
* 7. ASSOCIATED DICTIONARY ITEMS WILL BE CONTAINED IN THE SAME BRACKETS.
* SEE ITEM 5 ABOVE FOR AN EXAMPLE.
* 8. THE PRIMARY KEY FIELD WILL BE IDENTIFIED BY 0.
* 9. AT LEAST ONE SPACE PRECEDES ALL PROMPT NUMBERS.
*************************************************************************
*
$INCLUDE START
USER = 'TXT'
PROMPT ""
SENTENCE = ''
SCREEN.REC = ''
CRT 'SCREEN FILE:'
CRT 'ENTER PICK FILENAME, FULL PATH TO OS FILE OR "P" TO PASTE...'
INPUT SCREEN.FILE
CRT SCREEN.FILE
SLEEP 1
BEGIN CASE
CASE SCREEN.FILE = ''
STOP
CASE OCONV(SCREEN.FILE,'MCU') = 'P'
CRT 'BEGIN PASTE '
CRT 'NOTE: IF SCREEN IS LESS THAN 23 LINES, YOU WILL HAVE TO PRESS (ENTER)'
CRT ' A FEW TIMES WHEN PASTING IS FINISHED.'
FOR LINE = 1 TO 20
INPUT STRING
SCREEN.REC = STRING
NEXT LINE
CASE INDEX(SCREEN.FILE,'/',1)
EXECUTE 'SH -C "CAT ':SCREEN.FILE:'"' CAPTURING SCREEN.REC
CASE 1
OPEN SCREEN.FILE TO SF.VAR ELSE CRT "UNABLE TO OPEN FILE" ; STOP
CRT 'ENTER SCREEN ITEM ID:':
INPUT SCREEN.ID
CRT SCREEN.ID
SLEEP 1
IF SCREEN.ID = '' THEN STOP
READ SCREEN.REC FROM SF.VAR,SCREEN.ID ELSE CRT "UNABLE TO READ SCREEN.REC" ; STOP
END CASE
CONVERT CHAR(13) TO '' IN SCREEN.REC
TEMP.PGM.ID = FIELD(SCREEN.REC<1>,' ',1):'.MAINT'
CRT "TARGET PROGRAM FILE NAME ":
INPUT PGM.FILENAME
CRT PGM.FILENAME
SLEEP 1
OPEN PGM.FILENAME TO PGM.FILE.VAR ELSE CRT "UNABLE TO OPEN ":PGM.FILENAME ; STOP
READU PGM.REC FROM PGM.FILE.VAR,TEMP.PGM.ID THEN TEMP.PGM.ID = ''
CRT
LOOP
CRT 'ENTER TARGET PROGRAM NAME ':
IF TEMP.PGM.ID # '' THEN CRT 'OR (ENTER) TO ACCEPT ':TEMP.PGM.ID:' ':
INPUT PGM.ID
IF PGM.ID = '' AND TEMP.PGM.ID = '' THEN STOP
IF PGM.ID = '' THEN PGM.ID = TEMP.PGM.ID
CRT PGM.ID
SLEEP 1
READ PGM.REC FROM PGM.FILE.VAR,PGM.ID THEN CRT "PROGRAM ":PGM.ID:" ALREADY EXISTS!" ELSE EXIT
REPEAT
PGM.REC = ""
PRINT @(-1):
FOR LINE = 1 TO 23
PRINT @(0,LINE-1):SCREEN.REC[1,79]:
NEXT LINE
*
FILENAME = TRIM(SCREEN.REC<1>)
OPEN "DICT",FILENAME TO DICT.FILE.VAR ELSE CRT "UNABLE TO OPEN DICT ":FILENAME ; STOP
MIN.DEPTH = 999
PGM.ARRAY = ""
WHERE = 26
FOR NBR = 0 TO 40
SEQ = " ":NBR:"."
FOR LINE = 1 TO 23
IF INDEX(SCREEN.REC,SEQ,1) THEN
POS = INDEX(SCREEN.REC,SEQ,1)
STRING = SCREEN.REC[POS,80]
ROW = LINE - 1
DEPTH = 1
FOR MV = 1 TO MV+1 UNTIL INDEX(SCREEN.REC,SEQ,1) = 0
DEPTH = DEPTH + 1
NEXT MV
IF DEPTH > 1 AND DEPTH < MIN.DEPTH THEN MIN.DEPTH = DEPTH
DICT.STRING = FIELD(STRING,"[",2)
DICT.STRING.COL = INDEX(SCREEN.REC,DICT.STRING,1)
DICT.STRING.COL = DICT.STRING.COL - 1 ; * REMEMBER, BASE COLUMN IS 0, NOT 1
IF DICT.STRING # "" THEN
DISPLAY.STRING = FIELD(DICT.STRING,"]",1)
DICT.STRING = TRIM(DISPLAY.STRING)
FOR ASSOC.MV.COUNTER = 1 TO ASSOC.MV.COUNTER+1 UNTIL FIELD(DICT.STRING," ",ASSOC.MV.COUNTER) = ""
DICT.ID = FIELD(DICT.STRING," ",ASSOC.MV.COUNTER)
COL = INDEX(DISPLAY.STRING,DICT.ID,1) + DICT.STRING.COL
BILD.COL = COL-1
IF ASSOC.MV.COUNTER = 1 THEN
IF DEPTH > 1 THEN
COL = INDEX(STRING,'.',1)+POS
END ELSE
COL = COL - 1 ; * OVERLAY [
END
END
COL = COL-1 ; * REMEMBER, BASE COLUMN IS 0, NOT 1
CRT @(0,23):('(':COL:',':ROW:')') 'L#10':
CRT @(BILD.COL,ROW):RV.ON:DICT.ID:RV.OFF:
RQM
READ DICT.REC FROM DICT.FILE.VAR,DICT.ID THEN
ATTB = DICT.REC<2>
DICT.DESC = DICT.REC<3>
*** DICT.DESC = DICT.REC<4> ; * UNIDATA
IF DICT.DESC = "" THEN DICT.DESC = DICT.ID
CONVERT CHAR(253) TO " " IN DICT.DESC
FLENGTH = DICT.REC<10>
*** FLENGTH = OCONV(DICT.REC<5>,'MCN') ; * FOR UNIDATA
****************************************************************
* UNIDATA CODE TO HANDLE (SIMPLE) I DESCRIPTORS.
IF TRIM(ATTB)[1,6] = 'TRANS(' THEN
CONVERT '"' TO '' IN ATTB
STRING = FIELD(ATTB,'(',2)
STRING = FIELD(STRING,')',1)
TFILE = FIELD(STRING,',',1)
TDICTID = FIELD(STRING,',',2)
TFIELD = OCONV(FIELD(STRING,',',3),'MCN')
READV ATTB FROM DICT.FILE.VAR, TDICTID, 2 ELSE ATTB = '????'
CONVERSION = 'T':TFILE:';X;':TFIELD:';':TFIELD
END ELSE
IF DICT.REC<8> # "" THEN
CONVERSION = DICT.REC<8>
END ELSE
CONVERSION = DICT.REC<7>
END
*** CONVERSION = DICT.REC<3>
END
************************************************************************
IF CONVERSION[1,1] = "T" AND INDEX(CONVERSION,';X;0',1) THEN
FILE.POS = INDEX(CONVERSION,";",1)
XFILE = CONVERSION[2,FILE.POS-2]
END ELSE
XFILE = ""
XFILE.ATTB = ""
END
IF COL + FLENGTH > 79 THEN FLENGTH = 79 - COL
SCREEN.REC = DICT.ID
SCREEN.REC = COL
SCREEN.REC = ROW
SCREEN.REC = FLENGTH
SCREEN.REC = ATTB
SCREEN.REC = DEPTH
SCREEN.REC = CONVERSION
SCREEN.REC = XFILE
SCREEN.REC = ASSOC.MV.COUNTER
FOREIGN.KEY = INDEX(CONVERSION,';X;0;0',1)
SCREEN.REC = FOREIGN.KEY
SCREEN.REC = DICT.DESC
WHERE = WHERE + 1
END ELSE
CRT @(0,23): 'CANNOT READ DICTIONARY *':DICT.ID:'*. ABORT!':
STOP
CRT @(0,23):@(-4):
END
NEXT ASSOC.MV.COUNTER
LINE = 23
END
END
NEXT LINE
NEXT NBR
PRINT @(0,23):
***
OPEN 'VOC' TO VOC THEN
WRITE SCREEN.REC ON VOC, 'SCREEN.REC'
END
*
CRT 'START BILDING PROGRAM...'
SLEEP 1
*
PGM.REC<-1> = STR('*',20):' PROGRAMMERS LOG ':STR('*',20)
PGM.REC<-1> = "* ":@LOGNAME:' - ':OCONV(DATE(),'D4/'):' - CREATED BY BILD.'
PGM.REC<-1> = STR("*",57)
PGM.REC<-1> = "*"
PGM.REC<-1> = "********************* OPTIONAL COMMAND LINE ARGUMENTS PASSED IN *****************************"
PGM.REC<-1> = "* 'WALK' - FOR WALK MODE, TO WALK THRU ALL THE PROMPTS."
PGM.REC<-1> = "* 'INQ' - FOR INQUIRY ONLY, NO UPDATE ALLOWED."
PGM.REC<-1> = "* KEYS PASSED IN, SEPERATED BY SPACES"
PGM.REC<-1> = STR('*',57)
PGM.REC<-1> = "*"
PGM.REC<-1> = "$INCLUDE COMMON.CODE"
PGM.REC<-1> = "*"
PGM.REC<-1> = "* COMMON.CODE DOES THE FOLLOWING (IN ORDER):"
PGM.REC<-1> = "* INITIALIZE VARIABLES"
PGM.REC<-1> = "* GOSUB OPEN.FILES"
PGM.REC<-1> = "* TOP: CLEARS OUT APPLICABLE VARIABLES"
PGM.REC<-1> = "* GOSUB PRINT.SCREEN"
PGM.REC<-1> = "* GOSUB DISPLAY.DATA (NO DATA YET, JUST CLEARS OLD STUFF, SKIPPED IN COMMON.CODE.SUB)"
PGM.REC<-1> = "* GOSUB GET.KEY (IF NO KEYS PASSED INTO PGM, SKIPPED IN COMMON.CODE.SUB)"
PGM.REC<-1> = "* GOSUB PROMPT (GET KEY, SKIPPED IN COMMON.CODE.SUB)"
PGM.REC<-1> = "* READ FILE.REC (NEXT.PROMPT = 1 IF NEW, SKIPPED IN COMMON.CODE.SUB)"
PGM.REC<-1> = "* GOSUB AFTER.READ"
PGM.REC<-1> = "* GOSUB DISPLAY.DATA"
PGM.REC<-1> = "* HOME.LINE: IF NEXT.PROMPT, THEN CHG = NEXT.PROMPT, ELSE:"
PGM.REC<-1> = "* GOSUB PROMPT (GET CHG)"
PGM.REC<-1> = "* CHECK CHG FOR OTHER COMMANDS (PAGE, END, ETC.)"
PGM.REC<-1> = "* GOSUB SPECIAL.HOME.LINE"
PGM.REC<-1> = "* ON CHG GOSUB PROMPT___"
PGM.REC<-1> = "* GOSUB PROMPT (INDIVIDUAL FIELDS)"
PGM.REC<-1> = "* GOSUB DISPLAY.DATA"
PGM.REC<-1> = "* GOTO HOME.LINE"
PGM.REC<-1> = "*"
*
PGM.REC<-1> = "*"
PGM.REC<-1> = "PRINT.SCREEN:"
PGM.REC<-1> = "PRINT DIM.ON:"
PGM.REC<-1> = "FOR LINE = 1 TO 30; PRINT; NEXT LINE" ; * SO SCROLL BACK WILL WORK ON ALL TELNET CLIENTS.
PGM.REC<-1> = 'PRINT @(0,0):'
FOR LINE = 1 TO 23
BEGIN CASE
CASE LINE = 2
PGM.REC<-1> = 'PRINT TOP.LINE'
CASE LINE = 21
PGM.REC<-1> = 'PRINT BOTTOM.LINE'
CASE 1
NBR.OF.BRACKETS = COUNT(SCREEN.REC,"[")
FOR BRACKET.NBR = 1 TO NBR.OF.BRACKETS
START.LOC = INDEX(SCREEN.REC,"[",1)
END.LOC = INDEX(SCREEN.REC,"]",1)
SPACE.BLOCK = STR(" ",(END.LOC-START.LOC)+1)
SCREEN.REC = SCREEN.REC[1,START.LOC-1]:SPACE.BLOCK:SCREEN.REC[END.LOC+1,80]
NEXT BRACKET.NBR
PGM.REC<-1> = 'PRINT "':(SCREEN.REC:SPACE(79))[1,79]:'"'
END CASE
NEXT LINE
PGM.REC<-1> = 'PRINT @(0,0):@(-4):@(0,0):"':PGM.ID:'":'
PGM.REC<-1> = 'PRINT @(69,0):OCONV(DATE(),"D4/"):'
PGM.REC<-1> = 'PRINT @(ACCOUNT.LOC,0):ACCOUNT.STRING:'
PGM.REC<-1> = 'PRINT DIM.OFF:'
PGM.REC<-1> = 'RETURN'
PGM.REC<-1> = '*'
*
CRT 'OPEN FILES SUBROUTINE'
SLEEP 1
*
PGM.REC<-1> = "OPEN.FILES:"
PGM.REC<-1> = "************************* PROGRAMMER CHANGABLE VARIABLES ***********************************"
PGM.REC<-1> = "ACCESS = '' ; * EVERYONE HAS FULL ACCESS"
PGM.REC<-1> = "* ACCESS<1> = ARRAY OF USER IDs WITH FULL ACCESS."
PGM.REC<-1> = "* ACCESS<2> = ARRAY OF USER IDs WHO CAN INQUIRE ONLY."
PGM.REC<-1> = "* MAKE ACCESS<2> = USER.ID IF EVERYONE ELSE IS INQUIRE ONLY."
PGM.REC<-1> = "* EVERYONE ELSE WILL BE DENIED ACCESS (IF ACCESS # '')."
PGM.REC<-1> = "FIELD.PROMPT = ''"
PGM.REC<-1> = "FIELD.PROMPT2 = ''"
PGM.REC<-1> = "HOME.PROMPT = ''"
PGM.REC<-1> = "HOME.PROMPT2 = ''"
PGM.REC<-1> = "KEY.PROMPT = ''"
PGM.REC<-1> = "KEY.PROMPT2 = ''"
PGM.REC<-1> = "UPDATE.MESSAGE = 'SAVE CHANGES? ':H.ON:'Y':H.OFF:'es OR ':H.ON:'N':H.OFF:'o ' ; * DEFAULT"
PGM.REC<-1> = "ERROR.MESSAGE = 'SORRY, THAT IS INCORRECT.' ; * DEFAULT"
PGM.REC<-1> = "ALLOW.NEW = 1 ; * DEFAULT"
PGM.REC<-1> = "NO.KEY.IN.LOOKUP = '' ; * DEFAULT"
PGM.REC<-1> = "LOOKUP.ALL = 1 ; * DEFAULT"
PGM.REC<-1> = STR('*',57)
PGM.REC<-1> = "HELP.ID = '":PGM.ID:"'"
PGM.REC<-1> = "MAIN.FILE.NAME = '":FILENAME:"'"
PGM.REC<-1> = "OPEN '":FILENAME:"' TO MAIN.FILE ELSE CRT 'UNABLE TO OPEN ":FILENAME:"'; STOP"
PGM.REC<-1> = "XFILE.ATTB = 1; * IF THIS IS NOT TRUE, CHANGE IT HERE."
PGM.REC<-1> = "MV.DISPLAY = ":MIN.DEPTH
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'GET.KEY SUBROUTINE:'
SLEEP 1
*
PGM.REC<-1> = "GET.KEY:"
PGM.REC<-1> = "COL = ":SCREEN.REC<26,2>:"; ROW = ":SCREEN.REC<26,3>:"; FLENGTH = ":SCREEN.REC<26,4>:"; ATTB = 0; ORG.DATA = ''; XFILE = '":FILENAME:".XFILE":"'"
IF SCREEN.REC<26,7> # '' THEN
PGM.REC<-1> = "LOOP"
PGM.REC<-1> = "GOSUB PROMPT"
PGM.REC<-1> = "IF ANSWER # '' THEN"
PGM.REC<-1> = "IF ICONV(ANSWER,'":SCREEN.REC<26,7>:"') = '' THEN GOSUB ERRMSG ELSE EXIT"
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "EXIT"
PGM.REC<-1> = "END"
PGM.REC<-1> = "REPEAT"
END ELSE
PGM.REC<-1> = "GOSUB PROMPT"
END
PGM.REC<-1> = "KEY = ANSWER"
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'AFTER.READ SUBROUTINE:'
SLEEP 1
*
PGM.REC<-1> = "AFTER.READ: *"
PGM.REC<-1> = "*"
PGM.REC<-1> = "* SPECIAL AFTER READ LOGIC GOES HERE"
PGM.REC<-1> = "*"
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'SPECIAL.HOME.LINE SUBROUTINE:'
SLEEP 1
*
PGM.REC<-1> = "SPECIAL.HOME.LINE:"
PGM.REC<-1> = "*"
PGM.REC<-1> = "IF INQUIRY.ONLY THEN RETURN"
PGM.REC<-1> = "IF NOT(NUM(CHG)) THEN GOSUB ERRMSG; RETURN"
STRING = "ON CHG GOSUB "
MFC = 1
LAST.PROMPT = DCOUNT(SCREEN.REC,CHAR(254))
FOR NBR.PROMPTS = 27 TO LAST.PROMPT
IF NOT(INDEX(SCREEN.REC,";X;",1)) OR INDEX(SCREEN.REC,';X;0',1) THEN
IF SCREEN.REC = 1 THEN ; * ASSOCIATED MV COUNTER
STRING = STRING:"PROMPT":MFC:", "
END
MFC = MFC + 1
END
NEXT NBR.PROMPTS
STRING = STRING:'ERRMSG'
STRING = TRIM(STRING)
PGM.REC<-1> = STRING
PGM.REC<-1> = "*"
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'CUSTOM.UPDATE SUBROUTINE:'
SLEEP 1
*
PGM.REC<-1> = "CUSTOM.UPDATE:"
PGM.REC<-1> = "*"
PGM.REC<-1> = "* SPECIAL UPDATE LOGIC GOES HERE"
PGM.REC<-1> = "*"
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'DISPLAY.DATA SUBROUTINE:'
SLEEP 1
*
PGM.REC<-1> = "DISPLAY.DATA:"
PGM.REC<-1> = "PRINT RV.ON:"
PGM.REC<-1> = "PRINT @(":SCREEN.REC<26,2>:",":SCREEN.REC<26,3>:"): (KEY:UL) 'L#":SCREEN.REC<26,4>:"':"
FOR FLD = 27 TO DCOUNT(SCREEN.REC,CHAR(254))
COL = SCREEN.REC
ROW = SCREEN.REC
FLENGTH = SCREEN.REC
ATTB = SCREEN.REC
DEPTH = SCREEN.REC
CONVERSION = SCREEN.REC
ASSOC.MV.CNT = SCREEN.REC
FOREIGN.KEY = SCREEN.REC
IF DEPTH > 1 THEN
PGM.REC<-1> = "IF DCOUNT(FILE.REC<":ATTB:">,CHAR(253)) > MAX.MV THEN MAX.MV = DCOUNT(FILE.REC<":ATTB:">,CHAR(253))"
PGM.REC<-1> = "MV.CNT = PAGE.MV"
PGM.REC<-1> = "FOR LINE = ":ROW:" TO ":ROW+DEPTH-1
IF CONVERSION # "" AND NOT(FOREIGN.KEY) THEN
IF ASSOC.MV.CNT = 1 THEN
PGM.REC<-1> = "PRINT @(":COL:",LINE): RV.OFF:MV.CNT 'L#4':RV.ON:(OCONV(FILE.REC<":ATTB:",MV.CNT>,'":CONVERSION:"'):UL) 'L#":FLENGTH:"':"
END ELSE
PGM.REC<-1> = "PRINT @(":COL:",LINE):PROMPT.DELIM:(OCONV(FILE.REC<":ATTB:",MV.CNT>,'":CONVERSION:"'):UL) 'L#":FLENGTH:"':"
END
END ELSE
IF ASSOC.MV.CNT = 1 THEN
PGM.REC<-1> = "PRINT @(":COL:",LINE): RV.OFF:MV.CNT 'L#4':RV.ON:(FILE.REC<":ATTB:",MV.CNT>:UL) 'L#":FLENGTH:"':"
END ELSE
PGM.REC<-1> = "PRINT @(":COL:",LINE):PROMPT.DELIM:(FILE.REC<":ATTB:",MV.CNT>:UL) 'L#":FLENGTH:"':"
END
END
PGM.REC<-1> = "MV.CNT = MV.CNT + 1"
PGM.REC<-1> = "NEXT LINE"
END ELSE
IF CONVERSION # "" AND NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "PRINT @(":COL:",":ROW:"):PROMPT.DELIM:(OCONV(FILE.REC<":ATTB:">,'":CONVERSION:"'):UL) 'L#":FLENGTH:"':"
END ELSE
PGM.REC<-1> = "PRINT @(":COL:",":ROW:"):PROMPT.DELIM:(FILE.REC<":ATTB:">:UL) 'L#":FLENGTH:"':"
END
END
NEXT FLD
PGM.REC<-1> = "PRINT RV.OFF:"
PGM.REC<-1> = "RETURN"
PGM.REC<-1> = "*"
*
CRT 'BUILDING PROMPT SUBROUTINES:'
SLEEP 1
*
PROMPT.CNT = 1
FOR FLD = 27 TO DCOUNT(SCREEN.REC,CHAR(254))
COL = SCREEN.REC
ROW = SCREEN.REC
FLENGTH = SCREEN.REC
ATTB = SCREEN.REC
DEPTH = SCREEN.REC
CONVERSION = SCREEN.REC
IF SCREEN.REC # "" THEN XFILE = SCREEN.REC:'.XFILE' ELSE XFILE = ""
ASSOC.MV.COUNTER = SCREEN.REC
FOREIGN.KEY = SCREEN.REC
DICT.DESC = SCREEN.REC
IF NOT(INDEX(CONVERSION,";X;",1)) OR FOREIGN.KEY THEN
IF DEPTH = 1 THEN
PGM.REC<-1> = "PROMPT":PROMPT.CNT:":"
PGM.REC<-1> = '* ':DICT.DESC
PGM.REC<-1> = "FIELD.PROMPT = '' ; * USE DEFAULT"
PGM.REC<-1> = "FIELD.PROMPT2 = '' ; * DEFAULT"
PGM.REC<-1> = "ERROR.MESSAGE = 'SORRY, THAT IS INCORRECT.' ; * DEFAULT"
PGM.REC<-1> = "REQUIRED = '' ; * DEFAULT"
IF CONVERSION # "" THEN
IF NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "COL = ":COL:"; ROW = ":ROW:"; FLENGTH = ":FLENGTH:"; ATTB = ":ATTB:"; ORG.DATA = OCONV(FILE.REC,'":CONVERSION:"'); XFILE = '":XFILE:"'"
END ELSE
PGM.REC<-1> = "COL = ":COL:"; ROW = ":ROW:"; FLENGTH = ":FLENGTH:"; ATTB = ":ATTB:"; ORG.DATA = FILE.REC; XFILE = '":XFILE:"'"
END
PGM.REC<-1> = "LOOP"
PGM.REC<-1> = "GOSUB PROMPT"
PGM.REC<-1> = "IF ANSWER # '' THEN"
IF CONVERSION = 'P(Y)' THEN PGM.REC<-1> = "ANSWER = OCONV(ANSWER,'MCU')"
PGM.REC<-1> = "IF ICONV(ANSWER,'":CONVERSION:"') = '' THEN GOSUB ERRMSG ELSE EXIT"
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "EXIT"
PGM.REC<-1> = "END"
PGM.REC<-1> = "REPEAT"
IF NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "FILE.REC = ICONV(ANSWER,'":CONVERSION:"')"
END ELSE
PGM.REC<-1> = "FILE.REC = ANSWER"
END
END ELSE
PGM.REC<-1> = "COL = ":COL:"; ROW = ":ROW:"; FLENGTH = ":FLENGTH:"; ATTB = ":ATTB:"; ORG.DATA = FILE.REC; XFILE = '":XFILE:"'"
PGM.REC<-1> = "GOSUB PROMPT"
PGM.REC<-1> = "FILE.REC = ANSWER"
END
IF FLENGTH < 3 THEN
PGM.REC<-1> = "GOSUB PRINT.SCREEN"
END ELSE
PGM.REC<-1> = "* GOSUB PRINT.SCREEN"
END
IF SCREEN.REC # "" THEN
PGM.REC<-1> = "IF NEW THEN NEXT.PROMPT = CHG + 1"
END
PGM.REC<-1> = "RETURN"
END ELSE
PGM.REC<-1> = "PROMPT":PROMPT.CNT:":"
PGM.REC<-1> = '* ':DICT.DESC
PGM.REC<-1> = "FIELD.PROMPT = '' ; * USE DEFAULT"
PGM.REC<-1> = "FIELD.PROMPT2 = '' ; * DEFAULT"
PGM.REC<-1> = "ERROR.MESSAGE = 'SORRY, THAT IS INCORRECT.' ; * DEFAULT"
PGM.REC<-1> = "REQUIRED = '' ; * DEFAULT"
IF ASSOC.MV.COUNTER = 1 THEN
PGM.REC<-1> = "ARRAY = ''"
COL = COL+4
END
*
IF CONVERSION # "" THEN
PGM.REC<-1> = "LOOP"
PGM.REC<-1> = "COL = ":COL:"; ROW = ":ROW:"; FLENGTH = ":FLENGTH:"; ATTB = ":ATTB:";XFILE = '":XFILE:"'"
PGM.REC<-1> = "IF INSERT.FLAG THEN"
PGM.REC<-1> = "ORG.DATA = ''"
PGM.REC<-1> = "END ELSE"
IF NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "ORG.DATA = OCONV(FILE.REC,'":CONVERSION:"')"
END ELSE
PGM.REC<-1> = "ORG.DATA = FILE.REC"
END
PGM.REC<-1> = "END"
PGM.REC<-1> = "GOSUB PROMPT"
PGM.REC<-1> = "IF ANSWER # '' THEN"
IF CONVERSION = 'P(Y)' THEN PGM.REC<-1> = "ANSWER = OCONV(ANSWER,'MCU')"
PGM.REC<-1> = "IF ICONV(ANSWER,'":CONVERSION:"') = '' THEN GOSUB ERRMSG ELSE EXIT"
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "EXIT"
PGM.REC<-1> = "END"
PGM.REC<-1> = "REPEAT"
PGM.REC<-1> = "IF INSERT.FLAG THEN"
IF NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "FILE.REC = INSERT(FILE.REC,ATTB,MV,0,ICONV(ANSWER,'":CONVERSION:"'))"
END ELSE
PGM.REC<-1> = "FILE.REC = INSERT(FILE.REC,ATTB,MV,0,ANSWER)"
END
PGM.REC<-1> = "END ELSE"
IF NOT(FOREIGN.KEY) THEN
PGM.REC<-1> = "FILE.REC = ICONV(ANSWER,'":CONVERSION:"')"
END ELSE
PGM.REC<-1> = "FILE.REC = ANSWER"
END
PGM.REC<-1> = "END"
END ELSE
PGM.REC<-1> = "COL = ":COL:"; ROW = ":ROW:"; FLENGTH = ":FLENGTH:"; ATTB = ":ATTB:"; XFILE = '":XFILE:"'"
PGM.REC<-1> = "IF INSERT.FLAG THEN"
PGM.REC<-1> = "ORG.DATA = ''"
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "ORG.DATA = FILE.REC"
PGM.REC<-1> = "END"
PGM.REC<-1> = "GOSUB PROMPT"
PGM.REC<-1> = "IF INSERT.FLAG THEN"
PGM.REC<-1> = "FILE.REC = INSERT(FILE.REC,ATTB,MV,0,ANSWER)"
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "FILE.REC = ANSWER"
PGM.REC<-1> = "END"
END
PGM.REC<-1> = "ARRAY<1,-1> = FILE.REC"
PGM.REC<-1> = "ARRAY<2,-1> = ATTB"
IF FLENGTH < 3 THEN
PGM.REC<-1> = "GOSUB PRINT.SCREEN"
END ELSE
PGM.REC<-1> = "* GOSUB PRINT.SCREEN"
END
LAST.MV = 1
FOR CNT = FLD+1 TO LAST.PROMPT UNTIL SCREEN.REC LE 1
IF NOT(INDEX(SCREEN.REC,";X;",1)) OR INDEX(SCREEN.REC,';X;0',1) THEN LAST.MV = ""
NEXT CNT
***************************************************************************
IF LAST.MV THEN
PGM.REC<-1> = "IF ARRAY<1> = '' THEN"
PGM.REC<-1> = "FOR CNT = 1 TO CNT+1 UNTIL ARRAY<2,CNT> = ''"
PGM.REC<-1> = "FILE.REC = DELETE(FILE.REC,ARRAY<2,CNT>,MV,0)"
PGM.REC<-1> = "NEXT CNT"
PGM.REC<-1> = "END"
PGM.REC<-1> = "IF ARRAY<1,1> # '' AND FILE.REC,MV+1> = '' THEN"
PGM.REC<-1> = "NEXT.PROMPT = CHG:'.':MV+1"
IF SCREEN.REC # "" THEN
IF INDEX(SCREEN.REC,';X;',1) AND NOT(SCREEN.REC) THEN
********** DISPLAY ONLY FIELD - SKIP
END ELSE
PGM.REC<-1> = "END ELSE"
PGM.REC<-1> = "IF NEW THEN NEXT.PROMPT = CHG + 1"
END
END
PGM.REC<-1> = "END"
PGM.REC<-1> = "RETURN"
END
***************************************************************************
END
PROMPT.CNT = PROMPT.CNT + 1
PGM.REC<-1> = "*"
END
NEXT FLD
NBR.LINES = DCOUNT(PGM.REC,@AM)
IF INDEX(PGM.REC,'NEXT.PROMPT = CHG + 1',1) THEN
PGM.REC = DELETE(PGM.REC, NBR.LINES-2,0,0)
END
PGM.REC<-1> = "END"
PGM.REC = CHANGE(PGM.REC,'FILE.REC<0>','KEY')
WRITE PGM.REC ON PGM.FILE.VAR, PGM.ID
EXECUTE 'FORMAT ':PGM.FILENAME:' ':PGM.ID
SLEEP 1
EXECUTE 'BASIC ':PGM.FILENAME:' ':PGM.ID
SLEEP 1
EXECUTE 'LC ':PGM.FILENAME:' ':PGM.ID
SLEEP 1
END
FI
ED BP.WRM COMMON.CODE
I
************************************************************
******************** COMMON.CODE
************************************************************
* Do NOT put PROGRAM = 'COMMON.CODE' HERE (IT MESSES UP THE STAMP).
******************** PROGRAMMERS LOG ********************
* 08-12-13 WRM TBD IF REGULAR LOOKUP FAILS, DO A SOUNDEX LOOKUP.
* 06-13-13 WRM 11561 REMOVED INPUT AFTER ERROR MESSAGE.
* 03-12-13 WRM 11583 IF INQUIRY.ONLY, DO A READ INSTEAD OF A READU.
* 01-21-13 WRM ADDED ACCESS CHECKING.
* 10-18-12 WRM 11430 FIXED 'END' AND 'TOP' TO WORK BETTER WITH PASSWORDS.
* 02-15-12 WRM 11201 ADDED CALL GET.NEXT.IDS.
* 12-29-11 WRM 11211 ADDED CALL TO CLEAN.RECORD
* 12-01-11 WRM 11184 SET ANSWER = ORG.DATA IF 'TOP'ING OUT OF POPUP LOOKUP.
* 11-29-11 WRM NONE REMOVED NEXT.MV LOGIC.
* 09-22-11 WRM NONE NEXT.MV LOGIC
* 08-17-11 WRM 11122 MOVED SNAPSHOT OF FILE.REC (OLD.REC = FILE.REC) BACK TO AFTER GOSUB AFTER.READ.
* 12-16-10 WRM 10932 REMOVED 'PROGRAM = "COMMON.CODE"', HOPEFULLY FOR GOOD.
* 12-16-10 WRM 10663 ADDED LOOKUP.ALL FLAG
* 11-18-10 WRM 10663 SET NO.KEY.IN.LOOKUP
* 11-11-10 WRM 10663 JIM DOESN'T WANT TO SEE CONO IN KEYS ON LOOKUP SO EASIEST TO NOT SHOW KEYS.
* 08-19-10 WRM 10663 CHANGES PER JIM.
* 01-28-10 WRM 10699 IF INQUIRY.ONLY THEN ALLOW.NEW DEFAULTS TO 0.
* 10-02-09 BILLM 10588 DO NOT LOCK NEW RECORDS PER JIM & JAMES.
* 10-01-09 BILLM 10588
* 08-28-09 BILLM TBD ADDED REQUIRED FIELD LOGIC
* 08-17-09 BILLM 10588 DO NOT ASSIGN NEXT NEW ID UNTIL DONE.
* BILLM - 07/09/2009 - REQUEST#: 10579 ADDED DEFAULT VALUES FOR VARIABLES FOR BACKWARD COMPATIBILITY.
* 05-05-09 JFF 10536: Chg underline (UL) to be null
* BILLM - 01/26/2009 - REQUEST#: 10294 ADDED ABILITY TO CHANGE KEY, HOME & FIELD PROMPTS.
* BILLM - 02/05/2008 - EFFECTIVELY REMOVED RV.ON & RV.OFF FROM DISPLAY.DATA ROUTINE PER JIM.
* BILLM - 12/27/2007 - CLEANED UP A LITTLE.
* BILLM - 12/10/2007 - ADDED NOTE FLAG TO POPUP.PARAMS<6>.
* BILLM - 12/06/2007 - CHANGED HELP SCREEN TO POPUP.
* BILLM - 12/05/2007 - DIFFERENT HELP REC.
* BILLM - 12/05/2007 - IF KEY(S) PASSED IN, DON'T PROMPT FOR KEY WHEN 'END' OR 'TOP'.
* BILLM - 11/21/2007 - IF 'TOP' CLEAR ARRAY TOO.
* BILLM - 11/07/2007 - ALSO ADDED LOGIC FOR HOME.LINE.PROMPT2
* BILLM - 11/07/2007 - CHANGED 'TOP' LOGIC TO ACTUALLY GO BACK TO TOP:
* WRM - 08/10/2007 - PUT IN TERM FOR POPUP.
* WRM - 08/08/2007 - BUG FIX - IF ON OTHER PAGE THAN 1, (PROMPT#).1 WAS NOT REDISPLAYING PAGE PROPERLY.
* WRM - 07/24/2007 - CHANGED HOME LINE PROMPT A BIT...
* WRM - 06/06/2007 - ADDED SLEEP 1 AFTER ERRMSG.
* WRM - 05/08/2007 - ALLOW CUSTOM HOME LINE PROMPT.
* WRM - 05/02/2007 - ALLOW 'N' FOR NEW RECORD.
* WRM - 03/14/2007 - CHANGING PROMPT INPUT ROUTINE.
* WRM - 01/31/2007 - DISPLAY '-' OPTION ONLY IF FLENGTH > 10
* WRM - 01/03/2007 - PUT IN BETTER SCREEN BORDERS
* WRM - 12/14/2006 - DEFAULT NEXT.PGM TO THIS.PGM
* WRM - 07/19/2006 - ADDED OPTIONAL POPUP.
* WRM - 06/02/2006 - REMOVE DUPLICATES IN LOOKUP.
* WRM - 05/16/2006 - FIXED SORTING OF ALL XFILE RECORDS.
* WRM LOOK FOR 01/20/2006 TO FIND THESE CHANGES: ADDED GOSUB AFTER.READ.
* WRM LOOK FOR 09/23/2005 TO FIND THESE CHANGES: REMOVED '.' OPTION FOR ABORTING OUT. BANNER USES IT IN ORDER ENTRY TO FILE OUT.
* WRM - 08/18/2005 - LOADED IN BP.WRM START @ TOP
* WRM - 06/17/2005 - IF NOT OK.TO.UPDATE THEN DO NOT GO BACK TO HOME.LINE
* WRM - 05/20/2005 - NEW LOOKUP LOGIC.
* BILL - 01/20/2004 - CLEAN UP FIELD PROMPT
* BILL - 01/19/2004 - NULL OUT DATA IF ANSWER = '*'
* BILL - 01/19/2004 - @ PROMPT:, DISPLAY 'WAS:' AT LINE 21 INSTEAD OF COL,ROW
* BILL - 12/23/2003 - MADE CREATE.XFILE A GOSUB...
* BILL - 12/22/2003 - EXECUTE CREATE.XFILE
* BILL - 12/19/2003 - IGNORE RECORD LOCKS IF SAME PERSON.
* BILL - 12/18/2003 - ALLOW DIFFERENT XFILE.VAR
* BILL - 12/17/2003 - TOOK OUT 'BY F2' WHEN SSELECTING XFILE AS IT IS ALREADY SORTED.
* BILL - 12/17/2003 - ALLOW '??' AND ALWAYS PROMPT FOR STRING TO SEARCH FOR IF NOT ?STRING.
* BILL - 12/15/2003 - ADDED ALLOW.NEW FLAG
* BILL - 12/12/2003 - ADDED OPTIONS PASSED IN SENTENCE (INQUIRY.ONLY = ?, WALK.MODE = 'WALK' OR KEY)
* BILL - 12/11/2003 - TESTING ROI F2 & F3 KEYS...
* BILL - 12/11/2003 - ADDED AUTO-ASSIGN OF NEXT KEY.
*
*
$INCLUDE START
*
*
OPTIONS = @SENTENCE
* PASSED IN OPTIONS:
* 'INQ' = INQUIRY ONLY (NO CHANGES ALLOWED)
* ANYTHING LEFT IS ASSUMED TO BE A RECORD KEY BEING PASSED IN.
*
CONVERT ' ' TO @VM IN OPTIONS
THIS.PGM = OPTIONS<1,1>
NEXT.PGM = THIS.PGM
OPTIONS = DELETE(OPTIONS,1,1,0)
LOCATE 'INQ' IN OPTIONS<1> SETTING LOC THEN
INQUIRY.ONLY = 1
ALLOW.NEW = ''
OPTIONS = DELETE(OPTIONS,1,LOC,0)
END ELSE
INQUIRY.ONLY = ''
ALLOW.NEW = 1
END
MV.DISPLAY = ''
OPEN "HELP.WRM" TO HELP ELSE STOP 'UNABLE TO OPEN HELP.FILE'
OPEN "LOCK.WRM" TO LOCK.FILE ELSE STOP 'UNABLE TO OPEN LOCK.FILE'
OPEN "NEXT.IDS" TO NEXT.IDS ELSE STOP 'UNABLE TO OPEN NEXT.IDS FILE'
ACCOUNT.LOC = 40 - INT(LEN(ACCOUNT)/2)
*
INSERTMODE = ''
CHG = ''
NEXT.PROMPT = ''
ARRAY = ''
*
UL = ''
DIM.ON = @(-11)
DIM.OFF = @(-12)
H.ON = @(-13)
H.OFF = @(-14)
RV.ON = ''
RV.OFF = ''
PROMPT.DELIM = ''
POPUP.PARAMS = ''
DATE = OCONV(DATE(),"D4/")
PROMPT ""
CLEAR.ERROR.LINE = @(0,23):BELL:@(-4):@(0,23)
UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
LOWER = "abcdefghijklmnopqrstuvwxyz"
ACCOUNT.STRING = H.ON:ACCOUNT:H.OFF
XFILE.FILENAME = ''
XFILE.SELECT = ''
KEY.PROMPT = ''
KEY.PROMPT2 = ''
HOME.PROMPT = ''
HOME.PROMPT2 = ''
FIELD.PROMPT = ''
FIELD.PROMPT2 = ''
*** ADDED FOR BACKWARD COMPATIBILITY ***
UPDATE.MESSAGE = 'SAVE CHANGES? ':H.ON:'Y':H.OFF:'es OR ':H.ON:'N':H.OFF:'o '
ERROR.MESSAGE = 'THAT IS INCORRECT. PLEASE TRY AGAIN.'
REQUIRED = ''
ALLOW.PASTE = ''
NO.KEY.IN.LOOKUP = ''
LOOKUP.ALL = 1
FILE.REC = "" ; OLD.REC = "" ; KEY = "" ; NEW = "" ; MV = 1 ; PAGE.MV = MV ; MAX.MV = '' ; MV.CNT = MV
ACCESS = '' ; * EVERYONE HAS FULL ACCESS
* ACCESS<1> = ARRAY OF USER IDs WITH FULL ACCESS.
* ACCESS<2> = ARRAY OF USER IDs WHO CAN INQUIRE ONLY.
* MAKE ACCESS<2> = USER.ID IF EVERYONE ELSE IS INQUIRE ONLY.
* EVERYONE ELSE WILL BE DENIED ACCESS (IF ACCESS # '').
GOSUB OPEN.FILES
IF ACCESS # '' THEN
INQUIRY.ONLY = ''
OK = ''
LOCATE USER.ID IN ACCESS<1> SETTING OK ELSE
OK = ''
LOCATE USER.ID IN ACCESS<2> SETTING OK THEN
INQUIRY.ONLY = 1
END ELSE
CRT @(0,23):
STOPM 'ACCESS DENIED.'
END
END
END
*
IF KEY.PROMPT = '' THEN
KEY.PROMPT = 'TYPE ID, ':H.ON:'HELP':H.OFF:', '
IF (OCONV(MAIN.FILE.NAME,'TNEXT.IDS;X;0;0') # "") AND ALLOW.NEW THEN
KEY.PROMPT = KEY.PROMPT: ' ':H.ON:'NEW':H.OFF:' FOR A NEW ITEM, '
END
END
IF XFILE.FILENAME = '' THEN XFILE.FILENAME = MAIN.FILE.NAME:'.XFILE'
OPEN XFILE.FILENAME TO XFILE.VAR ELSE XFILE.FILENAME = ''
IF OPTIONS<1> # '' THEN KEYS.PASSED.IN = 1 ELSE KEYS.PASSED.IN = ''
TOP:*
DELETE LOCK.FILE,MAIN.FILE.NAME:'|':KEY
FILE.REC = "" ; OLD.REC = "" ; KEY = "" ; NEW = "" ; MV = 1 ; PAGE.MV = MV ; MAX.MV = '' ; MV.CNT = MV
REQUIRED = ''
CHG = ''
RELEASE
CLEARDATA ; * THIS NEEDS TO BE HERE. SORRY.
GOSUB PRINT.SCREEN ; PRINT @(ACCOUNT.LOC,0):ACCOUNT.STRING:
CRT @(0,1):TOP.LINE:
CRT @(0,20):BOTTOM.LINE:
GOSUB DISPLAY.DATA
*
IF OPTIONS<1,1> # '' THEN
KEY = OPTIONS<1,1>
OPTIONS = DELETE(OPTIONS,1,1,0)
END ELSE
IF KEYS.PASSED.IN THEN CRT @(0,23): ; RELEASE ; STOP
GOSUB GET.KEY
END
IF KEY[1,1] = '?' THEN GO TOP
*
CONVERT LOWER TO UPPER IN KEY
IF KEY = '' OR KEY = '.' THEN CRT @(0,23): ; STOP
IF KEY = 'HELP' THEN GO TOP
IF ALLOW.NEW THEN
IF KEY = "N" THEN KEY = "NEW"
END
CONVERT " " TO "." IN KEY
CONVERT LOWER TO UPPER IN KEY
NEW = ''
IF INQUIRY.ONLY THEN
READ FILE.REC FROM MAIN.FILE, KEY ELSE
ERROR.MESSAGE = 'RECORD ':KEY:' NOT ON FILE!'
GOSUB ERRMSG
ERROR.MESSAGE = ''
GO TOP
END
END ELSE
READU FILE.REC FROM MAIN.FILE,KEY LOCKED
READV WHO.LOCKED FROM LOCK.FILE,MAIN.FILE.NAME:'|':KEY,1 ELSE WHO.LOCKED = 'SOMEBODY'
CRT CLEAR.ERROR.LINE:WHO.LOCKED:' HAS THIS ITEM LOCKED!':
INPUT PAUSE:
GO TOP
END ELSE
RELEASE MAIN.FILE, KEY
IF INQUIRY.ONLY OR NOT(ALLOW.NEW) THEN
ERROR.MESSAGE = 'RECORD ':KEY:' NOT ON FILE!'
GOSUB ERRMSG
ERROR.MESSAGE = ''
GO TOP
END
IF OCONV(MAIN.FILE.NAME,'TNEXT.IDS;X;0;0') # '' THEN
IF KEY # "NEW" THEN
ERROR.MESSAGE = 'ONLY ENTER "NEW" FOR NEW ITEMS.'
GOSUB ERRMSG
ERROR.MESSAGE = ''
GO TOP
END
END
FILE.REC = ""
NEW = 1
NEXT.PROMPT = 1
PRINT CLEAR.ERROR.LINE:"*** NEW RECORD ***":
END
IF NOT(NEW) THEN WRITEV WHO ON LOCK.FILE,MAIN.FILE.NAME:'|':KEY,1
END
OLD.REC = ''
GOSUB AFTER.READ
IF OLD.REC = '' THEN OLD.REC = FILE.REC ; * DO NOT MOVE THIS AGAIN.
IF KEY = '' THEN GO TOP
*
IF HOME.PROMPT = '' THEN
IF INQUIRY.ONLY THEN
HOME.PROMPT = H.ON:'INQUIRY ONLY: ':H.OFF
END ELSE
HOME.PROMPT = 'TYPE FIELD# TO CHANGE OR '
END
IF INDEX(FILE.REC,CHAR(253),1) THEN
HOME.PROMPT = HOME.PROMPT:' PAGE ':H.ON:'F':H.OFF:'orward or ':H.ON:'B':H.OFF:'ack or'
END
HOME.PROMPT = HOME.PROMPT:' (ENTER)'
END
GOSUB DISPLAY.DATA
*
HOME.LINE:*
* 0 GOSUBS DEEP
REQUIRED = ''
ARRAY = ''
ALLOW.PASTE = ''
ERROR.MESSAGE = ''
MV = 1
IF NEXT.PROMPT AND CHG # NEXT.PROMPT THEN
CHG = NEXT.PROMPT
IF CHG < 1 THEN CHG = 1
END ELSE
PRINT @(0,22):@(-4):
COL = 72
NEW = ''
ROW = 22
ORG.DATA = ''
FLENGTH = 6
XFILE = ''
IF NOT(NUM(CHG)) THEN CHG = 1
GOSUB DISPLAY.DATA
GOSUB PROMPT
IF NEXT.PROMPT = '!' THEN CHG = '!' ELSE CHG = ANSWER
END
CHG = OCONV(CHG,'MCU')
IF CHG = "HELP" THEN CHG = "?"
IF CHG = '!' THEN GO TOP
IF CHG = "?" THEN GOSUB HELP.ME ; GO HOME.LINE
IF CHG = "" OR CHG = '.' THEN
IF OLD.REC # FILE.REC AND NOT(INQUIRY.ONLY) THEN
IF CHG = '' THEN
IF UPDATE.MESSAGE = '' THEN
UPDATE.MESSAGE = 'SAVE CHANGES? ':H.ON:'Y':H.OFF:'es OR ':H.ON:'N':H.OFF:'o '
END
PRINT CLEAR.ERROR.LINE:UPDATE.MESSAGE:
INPUT ANSWER:
CRT @(0,23):CEOL:
END ELSE
ANSWER = 'Y'
END
ANSWER = OCONV(ANSWER,'MCU')
IF ANSWER = 'y' OR ANSWER = 'Y' THEN
OK.TO.UPDATE = 1
CONVERT INVALID TO NOTHING IN FILE.REC
GOSUB CUSTOM.UPDATE
IF OK.TO.UPDATE THEN
IF KEY = "NEW" THEN
CALL GET.NEXT.IDS(MAIN.FILE.NAME, NEW.KEY)
KEY = NEW.KEY
ERROR.MESSAGE = "NEW ":MAIN.FILE.NAME:" ID = ":KEY
GOSUB ERRMSG
INPUT WAIT:
ERROR.MESSAGE = ''
END
WRITE FILE.REC ON MAIN.FILE,KEY
IF XFILE.FILENAME # '' THEN GOSUB BUILD.XFILE
END ELSE
GO HOME.LINE
END
END ELSE
IF ANSWER # 'N' AND ANSWER # 'N' THEN GO HOME.LINE
END
END
DELETE LOCK.FILE,MAIN.FILE.NAME:'|':KEY
GO TOP
END
*
IF CHG[1,1] = 'I' THEN
CHG = TRIM(CHG[2,9])
INSERT.FLAG = 1
END ELSE
INSERT.FLAG = ''
END
*
IF INDEX(CHG,'.',1) THEN
MV = FIELD(CHG,'.',2)
CHG = FIELD(CHG,'.',1)
END
*
IF MV.DISPLAY = '' THEN MV.DISPLAY = MV.CNT - PAGE.MV
IF CHG[1,1] = 'B' THEN
IF OCONV(CHG,'MCN') # '' THEN MV.DISPLAY = OCONV(CHG,'MCN')
PAGE.MV = PAGE.MV - MV.DISPLAY
IF PAGE.MV < 1 THEN
IF ABS(PAGE.MV) < (MV.DISPLAY - 1) THEN
PAGE.MV = 1
END ELSE
PAGE.MV = MAX.MV - MV.DISPLAY + 1
END
IF PAGE.MV < 1 THEN PAGE.MV = 1
END
GOSUB DISPLAY.DATA
GO HOME.LINE
END
*
IF CHG[1,1] = 'F' THEN
IF OCONV(CHG,'MCN') # '' THEN MV.DISPLAY = OCONV(CHG,'MCN')
PAGE.MV = PAGE.MV + MV.DISPLAY
IF PAGE.MV > MAX.MV THEN PAGE.MV = 1
GOSUB DISPLAY.DATA
GO HOME.LINE
END
*
GOSUB SPECIAL.HOME.LINE
*
GOSUB DISPLAY.DATA
GO HOME.LINE
*
PROMPT:*
*
* 1 GOSUB DEEP FROM GET.KEY & HOME.LINE
* 3 GOSUBS DEEP FROM ALL OTHER PROMPTS (GOSUB SPECIAL.HOME.LINE, GOSUB PROMPTnn, GOSUB PROMPT)
NEXT.PROMPT = ''
IF ROW # 22 AND MV THEN
IF ARRAY = '' THEN
* 1st MV ATTB IS CONTROLLING VALUE & ARRAY WILL BE NULL AT THIS POINT.
NEXT.MV = DCOUNT(FILE.REC,@VM) + 1
IF MV > NEXT.MV THEN MV = NEXT.MV
END
IF MV > MV.DISPLAY THEN
PAGE.MV = MV - MV.DISPLAY + 1
ROW = ROW + MV.DISPLAY - 1 ; * LAST ROW OF DISPLAY
END ELSE
PAGE.MV = 1
ROW = ROW + MV - 1
END
GOSUB DISPLAY.DATA
END
JUST = "L#":FLENGTH
PROMPT.AGAIN:*
BEGIN CASE
CASE ROW = 22
PROMPT.STRING = HOME.PROMPT
PROMPT.STRING2 = HOME.PROMPT2
CASE KEY = ''
PROMPT.STRING = KEY.PROMPT
IF XFILE # '' THEN PROMPT.STRING = PROMPT.STRING:' OR ':H.ON:'?':H.OFF:' FOR LOOKUP '
PROMPT.STRING2 = KEY.PROMPT2
CASE 1
IF FIELD.PROMPT # "" THEN
PROMPT.STRING = FIELD.PROMPT
END ELSE
PROMPT.STRING = '(ENTER) TO ACCEPT OR TYPE NEW, '
IF ORG.DATA # "" THEN
PROMPT.STRING = PROMPT.STRING:H.ON:'*':H.OFF:' TO REMOVE, '
IF LEN(ORG.DATA) > 10 THEN PROMPT.STRING = PROMPT.STRING:H.ON:'-':H.OFF:' TO REPLACE '
END
IF XFILE # '' THEN PROMPT.STRING = PROMPT.STRING:' OR ':H.ON:'?':H.OFF:' FOR LOOKUP '
END
PROMPT.STRING2 = FIELD.PROMPT2
END CASE
PRINT @(0,22):@(-4):PROMPT.STRING:
ANSWER = ORG.DATA
CRT @(0,21):PROMPT.STRING2:
CRT H.ON:
CRT @(COL,ROW):ANSWER JUST:@(COL,ROW):
IF ALLOW.PASTE THEN
* TO ALLOW AUTO CRLF WHEN PASTING TEXT...
CRT H.OFF:
INPUT ANSWER,FLENGTH:
END ELSE
* AUTO CRLF IS SUPPRESSED WHEN DOING INPUT @(C,R):
INPUT @(COL,ROW):ANSWER, FLENGTH:
CRT H.OFF:
END
CONVERT INVALID TO NOTHING IN ANSWER
PRINT @(0,23):STR(" ",79):
PRINT @(0,21):STR(" ",79):
PROMPT.STRING2 = ''
IF ANSWER = '!' THEN GO TOP
IF KEY # "" THEN
IF ANSWER = '.' THEN
NEXT.PROMPT = ''
GOSUB DISPLAY.DATA
GO HOME.LINE
END
END
IF ANSWER = "-" AND ORG.DATA # "" THEN
PRINT @(COL,ROW):H.ON: ORG.DATA JUST :H.OFF:
TEXT = ORG.DATA
PRINT CLEAR.ERROR.LINE:
PRINT @(0,22):@(-4):@(0,22):"REPLACE ":
INPUT OLDVAL:
PRINT " WITH ":
INPUT NEWVAL:
START.POS = INDEX(TEXT,OLDVAL,1)
IF START.POS THEN
TEXT = TEXT[1,START.POS-1]:NEWVAL:TEXT[START.POS+LEN(OLDVAL),999]
END
ORG.DATA = TEXT
GO PROMPT.AGAIN
END
IF COL = 22 OR KEY = "" THEN
IF OCONV(ANSWER,'MCU') = 'HELP' THEN GOSUB HELP.ME
END
IF ANSWER[1,1] = "?" THEN
OPEN XFILE TO XFILE.VAR THEN
SEARCH.STRING = TRIM(ANSWER[2,99])
IF SEARCH.STRING = '' THEN
CRT @(0,23):CLEAR.ERROR.LINE:'TYPE TEXT TO SEARCH FOR ':
IF LOOKUP.ALL THEN CRT 'OR (enter) FOR ALL ':
INPUT SEARCH.STRING:
END
IF SEARCH.STRING # '' THEN
CONVERT '?' TO '' IN SEARCH.STRING
SEARCH.STRING = OCONV(SEARCH.STRING,'MCU')
READ XFILE.REC FROM XFILE.VAR,SEARCH.STRING ELSE
SEARCH.STRING = SOUNDEX(SEARCH.STRING)
READ XFILE.REC FROM XFILE.VAR,SEARCH.STRING ELSE XFILE.REC = ''
END
END ELSE
IF NOT(LOOKUP.ALL) THEN
GOSUB PRINT.SCREEN
GOSUB DISPLAY.DATA
GO PROMPT.AGAIN
END
XFILE.REC = ''
CLEARSELECT
CRT @(0,23):'SELECTING ALL RECORDS...' "L#79": ; RQM
EXECUTE 'SELECT ':XFILE CAPTURING JUNK
LOOP
READNEXT XFILE.ID,ALL.MV ELSE EXIT
READ TEMP.REC FROM XFILE.VAR,XFILE.ID THEN
NBR.ITEMS = DCOUNT(TEMP.REC<2>,@VM)
FOR ALL.MV = 1 TO NBR.ITEMS
TEST.ID = TEMP.REC<1,ALL.MV>
LOCATE TEST.ID IN XFILE.REC<1> SETTING THERE.IT.IS ELSE
TEST.STRING = TEMP.REC<2,ALL.MV>
LOCATE TEST.STRING IN XFILE.REC<2> BY 'AL' SETTING ALL.POS ELSE NULL
XFILE.REC = INSERT(XFILE.REC,1,ALL.POS,0,TEST.ID)
XFILE.REC = INSERT(XFILE.REC,2,ALL.POS,0,TEST.STRING)
END
NEXT ALL.MV
END
REPEAT
END
*
XMV = 1
FOR LINE = 1 TO 30
CRT
NEXT LINE
NEXT.PAGE:*
FOR LINE = 1 TO 20
IF NO.KEY.IN.LOOKUP THEN
CRT @(0,LINE):XMV "R#4":" ":H.ON:(XFILE.REC<2,XMV>:STR('_',70)) "L#70":H.OFF:
END ELSE
CRT @(0,LINE):XMV "R#4":" ":H.ON:(XFILE.REC<2,XMV>:STR('_',50)) "L#50":" ":(XFILE.REC<1,XMV>:STR('_',20)) "L#20":H.OFF:
END
XMV = XMV + 1
NEXT LINE
HOME.LINE.XFILE:*
CRT @(0,22):'TYPE SELECTION#, PAGE ':H.ON:'F':H.OFF:'orward or ':H.ON:'B':H.OFF:'ack, OR (enter)':
INPUT RESPONSE:
BEGIN CASE
CASE RESPONSE = ''
IF KEY # "" THEN
XFILE.POS = INDEX(XFILE,'XFILE',1)
IF XFILE.POS THEN
PGM.NAME = XFILE[1,XFILE.POS-2]:'.MAINT'
IF OCONV(PGM.NAME,'TVOC;X;1;1') = 'V' THEN EXECUTE PGM.NAME ; * COULDN'T FIND WHAT THEY WERE LOOKING FOR. ALLOW THEM TO ENTER A NEW ONE.
END
END
GOSUB PRINT.SCREEN
GOSUB DISPLAY.DATA
GO PROMPT.AGAIN
CASE NUM(RESPONSE)
ANSWER = XFILE.REC<1,RESPONSE>
CASE OCONV(RESPONSE,'MCU') = 'B'
XMV = XMV - 40
IF XMV < 1 THEN
IF XMV + 20 = 1 THEN
XMV = DCOUNT(XFILE.REC<1>,CHAR(253)) - 19
END
IF XMV < 1 THEN XMV = 1
END
GO NEXT.PAGE
CASE OCONV(RESPONSE,'MCU') = 'F'
IF XFILE.REC<1,XMV> = "" THEN XMV = 1
GO NEXT.PAGE
CASE 1
GO HOME.LINE.XFILE
END CASE
END ELSE
IF XFILE = MAIN.FILE.NAME:'.XFILE' THEN
CRT CLEAR.ERROR.LINE:'NO CROSS REFERENCE FILE. BUILD IT NOW? ':
INPUT MAKE.XFILE:
IF OCONV(MAKE.XFILE[1,1],'MCU') = 'Y' THEN
GOSUB BUILD.XFILE
GOSUB PRINT.SCREEN ; PRINT @(ACCOUNT.LOC,0):ACCOUNT.STRING:
CRT @(0,1):TOP.LINE:
CRT @(0,20):BOTTOM.LINE:
GOSUB DISPLAY.DATA
DATA ANSWER
GO PROMPT.AGAIN
END
END ELSE
IF XFILE # '' THEN
* XFILE IS SIMPLE "SORT" STATEMENT FOR POPUP.
EXECUTE 'TERM 32000,32000'
SEARCH.STRING = TRIM(ANSWER[2,99])
IF SEARCH.STRING # "" AND XFILE.SELECT # "" THEN
SEARCH.STRING1 = '"[':SEARCH.STRING:']" '
SEARCH.STRING1 := '"[':OCONV(SEARCH.STRING,'MCU'):']" '
SEARCH.STRING1 := '"[':OCONV(SEARCH.STRING,'MCL'):']" '
SEARCH.STRING1 := '"[':OCONV(SEARCH.STRING,'MCT'):']" '
EXECUTE XFILE.SELECT:' = ':SEARCH.STRING1 CAPTURING JUNK
END
EXECUTE XFILE CAPTURING DATA.ARRAY
EXECUTE 'TERM 79,24'
CALL POPUP(POPUP.PARAMS, DATA.ARRAY)
ANSWER = DATA.ARRAY
IF ANSWER = '' THEN ANSWER = ORG.DATA
IF ANSWER = '' AND KEY = '' THEN ANSWER = '?'
END
***
END
END
*
GOSUB PRINT.SCREEN ; PRINT @(ACCOUNT.LOC,0):ACCOUNT.STRING:
CRT @(0,1):TOP.LINE:
CRT @(0,20):BOTTOM.LINE:
GOSUB DISPLAY.DATA
END
IF ANSWER = "" THEN ANSWER = ORG.DATA
IF TRIM(ANSWER) = "" OR ANSWER = '*' THEN ANSWER = ""
IF ANSWER = '' AND REQUIRED THEN
ERROR.MESSAGE = 'DATA IS REQUIRED HERE'
GOSUB ERRMSG
ERROR.MESSAGE = ''
GO PROMPT.AGAIN
END
RETURN
*
BUILD.XFILE:
IF XFILE.SELECT # '' THEN
EXECUTE XFILE.SELECT CAPTURING JUNK
IF SYSTEM(11) THEN
EXECUTE 'CREATE.XFILE ':MAIN.FILE.NAME:' ':XFILE.ATTB:' ':XFILE.FILENAME PASSLIST CAPTURING JUNK
END
END ELSE
EXECUTE 'CREATE.XFILE ':MAIN.FILE.NAME:' ':XFILE.ATTB:' ':XFILE.FILENAME CAPTURING JUNK
END
RETURN
*
ERRMSG:*
IF ERROR.MESSAGE = '' THEN ERROR.MESSAGE = 'THAT IS INCORRECT. PLEASE TRY AGAIN.'
PRINT CLEAR.ERROR.LINE:(H.ON:ERROR.MESSAGE:H.OFF) 'L#79':
RETURN
*
HELP.ME:*
IF HELP.ID = '' THEN
HELP.ID = MAIN.FILE.NAME:'.MAINT'
END
READ HELP.REC FROM HELP,HELP.ID ELSE
HELP.REC = ''
HELP.REC<-1> = 'NAVIGATION SHORTCUTS:'
HELP.REC<-1> = ' ! to clear data & get back to top of screen'
HELP.REC<-1> = ' . to finish & save changes'
HELP.REC<-1> = ' - to replace part of the data w/o having to retype the entire line.'
HELP.REC<-1> = ' I(n.n) - to insert before a multi-valued line'
HELP.REC<-1> = ' ?(string) - to do a lookup, where applicable.'
END
DATA.ARRAY = HELP.REC
CONVERT @VM TO @AM IN DATA.ARRAY
POPUP.PARAMS = ''
POPUP.PARAMS<1> = 4
POPUP.PARAMS<2> = 4
POPUP.PARAMS<3> = 74
POPUP.PARAMS<4> = 16
POPUP.PARAMS<6> = 1
CALL POPUP(POPUP.PARAMS, DATA.ARRAY)
POPUP.PARAMS = ''
GOSUB PRINT.SCREEN ; PRINT @(ACCOUNT.LOC,0):ACCOUNT.STRING:
CRT @(0,1):TOP.LINE:
CRT @(0,20):BOTTOM.LINE:
GOSUB DISPLAY.DATA
RETURN
*
****************************************************************************
* END GENERIC STUFF
****************************************************************************
*
FI
ED BP.WRM CREATE.XFILE
I
************************************************************
******************** CREATE.XFILE
************************************************************
******************** PROGRAMMERS LOG ********************
* bmontg - 05/23/2005 - WRITE OUT 'STRING' DICT ITEM.
* BANNER\hc - 05/20/2005 - BUILD XREF FOR ALL WORDS AND SOUNDEX.
* BILL - 12/17/2003 - ADDED ABILITY TO INPUT DIFFERENT XFILE NAME.
* BILL - 12/03/2003 - NOW CAN BUILD LOOKUP ON UNIDATA DICTIONARIES.
* WRM - 07/24/1998 - MADE IT BACKWARD COMPATIBLE IN CASE THEY WANT TO USE
* WRM - 07/23/1998 - NOW HAVE THE ABILITY TO BUILD LOOKUP ON DICTIONARY IT
******************** CREATE.XFILE
************************************************************
* $BASICTYPE "P"
*
$INCLUDE START
*
FILENAME = FIELD(@SENTENCE," ",2)
ATTB = FIELD(@SENTENCE,' ',3)
XREF.NAME = FIELD(@SENTENCE,' ',4)
IF SYSTEM(11) THEN
LIST.ACTIVE = 1
EXECUTE 'SAVE-LIST XFILE.':@LOGNAME
END ELSE
LIST.ACTIVE = ''
END
* TCLREAD SENTENCE
IF FILENAME = '' THEN
CRT 'INPUT FILE NAME TO BUILD XFILE ON ':
INPUT FILENAME
END
OPEN FILENAME TO FILE ELSE STOP 'UNABLE TO OPEN FILE'
IF FIELD(FILENAME,' ',1) = 'DICT' THEN
ATTB = 4
CONVERT ' ' TO '.' IN FILENAME
END ELSE
OPEN "DICT", FILENAME TO D.FILE ELSE STOP 'UNABLE TO OPEN DICT ':FILENAME
*
IF ATTB = '' THEN
CRT 'INPUT DICTIONARY ITEM TO BUILD XFILE ON ':
INPUT ATTB
END
IF ATTB = '' THEN ATTB = 0
IF NOT(NUM(ATTB)) THEN
READ CHECK.DICT FROM D.FILE,ATTB ELSE STOP 'NOT A VALID DICTIONARY ITEM'
END
END
*
IF XREF.NAME = '' THEN XREF.NAME = FILENAME:'.XFILE'
OPEN XREF.NAME TO XFILE THEN
CLEARFILE XFILE
END ELSE
EXECUTE 'CREATE.FILE ':XREF.NAME:' DYNAMIC DYNAMIC'
OPEN XREF.NAME TO XFILE ELSE STOP 'UNABLE TO OPEN ':XREF.NAME
END
*
IF LIST.ACTIVE THEN
EXECUTE 'GET-LIST XFILE.':@LOGNAME
END
IF NOT(NUM(ATTB)) THEN
EXECUTE 'LIST ':FILENAME:' WITH ':ATTB:' # "" ':ATTB:' COL-HDR-SUPP COUNT.SUP' CAPTURING OUTPUT
END ELSE
EXECUTE 'LIST ONLY ':FILENAME:' COL-HDR-SUPP COUNT.SUP' CAPTURING OUTPUT
END
CONVERT INVALID TO NOTHING IN OUTPUT
NBR.LINES = DCOUNT(OUTPUT,@AM)
FOR LINE = 1 TO NBR.LINES
STRING = TRIM(OUTPUT<LINE>)
ITEM.ID = FIELD(STRING,' ',1)
READ TEST FROM FILE, ITEM.ID THEN
STRING = STRING[COL2(),9999]
IF NUM(ATTB) THEN
IF ATTB > 0 THEN
STRING = TEST<ATTB>
CONVERT @VM TO ' ' IN STRING
END ELSE
STRING = ITEM.ID
END
END
STRING = TRIM(STRING)
NBR.WORDS = DCOUNT(STRING,' ')
FOR CNT = 1 TO NBR.WORDS
WORD = FIELD(STRING,' ',CNT)
WORD = OCONV(WORD,'MCU')
SOUNDEX.WORD = SOUNDEX(WORD)
READ XFILE.REC FROM XFILE,WORD ELSE XFILE.REC = ""
LOCATE ITEM.ID IN XFILE.REC<1> SETTING DMY ELSE
LOCATE STRING IN XFILE.REC<2> BY 'AL' SETTING LOC ELSE NULL
XFILE.REC = INSERT(XFILE.REC,1,LOC,0,ITEM.ID)
XFILE.REC = INSERT(XFILE.REC,2,LOC,0,STRING)
WRITE XFILE.REC ON XFILE,WORD
END
READ XFILE.REC FROM XFILE,SOUNDEX.WORD ELSE XFILE.REC = ""
LOCATE ITEM.ID IN XFILE.REC<1> SETTING DMY ELSE
LOCATE STRING IN XFILE.REC<2> BY 'AL' SETTING LOC ELSE NULL
XFILE.REC = INSERT(XFILE.REC,1,LOC,0,ITEM.ID)
XFILE.REC = INSERT(XFILE.REC,2,LOC,0,STRING)
WRITE XFILE.REC ON XFILE,SOUNDEX.WORD
END
NEXT CNT
*
END
NEXT LINE
*
OPEN 'DICT', XREF.NAME TO DICT.XFILE THEN
READ REC FROM DICT.XFILE, 'STRING' ELSE
REC = ''
REC<1> = 'A'
REC<2> = '2'
REC<9> = 'T'
REC<10> = '30'
WRITE REC ON DICT.XFILE,'STRING'
END
END
*
END
FI
ED BP.WRM POPUP
I
SUBROUTINE POPUP(POPUP.PARAMS, DATA.ARRAY)
******************** PROGRAMMERS LOG ********************
* 09-11-12 WRM 11267 ADDED "MORE..." IF ANOTHER PAGE OF DATA.
* 07-19-11 WRM 10934 SHOW 'Y' TO ACKNOWLEDGE FOR PRESTOCK RECEIPTS ONLY.
* 11-29-10 WRM 10710 FIXED BUG (ALLOWED ALPHA RESPONSES).
* 09-28-09 BILLM 10577 IF HIDE CODE, REMOVE FIRST COLUMN OF HEADING.
* 09-17-09 BILLM 10606 CHANGES FOR SPECIAL PO REQUIREMENTS.
* BILLM - 12/15/2008 - REQUEST#: 10294 ADDED ABILITY TO PAGE BACK.
* BILLM - 11/24/2008 - REQUEST#: 10294 ANYTHING OTHER THAN A SPACE OR NUMBER IS SAME AS 'TOP'
* BILLM - 01/28/2008 - REQUEST#: NONE. FIXED BUG IN NOTE.
* BILLM - 12/10/2007 - ADDED NOTE FLAG.
* WRM - 09/04/2007 - ADDED TRIMF
* WRM - 08/10/2007 - REMOVE [H[2J FROM ENTIRE POPUP, NOT JUST FIRST LINE.
* WRM - 07/26/2007 - REMOVE [H[2J
* WRM - 03/07/2007 - ADDED HIDE.CODE FLAG AS POPUP.PARAMS<5>
* WRM - 01/22/2007 - TOP OR END
* WRM - 01/04/2007 - REPLACED CHAR(152) WITH BLOCK (ASSIGNED IN START).
* WRM - 12/06/2006 - NEVER PUT SELECTION NUMBER ON FIRST LINE OF POPUP.
* WRM - 09/21/2006 - TOOK OUT HTML WRITE.
* WRM - 03/14/2006 - CHANGED DEFAULT POPUP.PARAMS.
* WRM LOOK FOR 02/08/2006 TO FIND THESE CHANGES: ADDED HTML POPUP LOGIC.
* WRM LOOK FOR 11/03/2005 TO FIND THESE CHANGES: ANSWER = ' ' WILL GET PASSED BACK IN DATA.ARRAY.
* WRM - 09/02/2005 - USE LINE NUMBERS FOR SELECTION NOW.
* WRM - 06/24/2005 - BUILD VALID FIRST.
* WRM - 06/24/2005 - ALLOW THEM TO 'SPACE' OUT.
* WRM - 06/24/2005 - TAKE 'records listed.' OUT OF VALID.
* WRM - 06/23/2005 - VALIDATE RESPONSE.
* WRM - 02/11/2005 - CREATED.
*********************************************************
*
$INCLUDE START
*
CONVERT INVALID TO NOTHING IN DATA.ARRAY
*
DATA.ARRAY = CHANGE(DATA.ARRAY,'[H[2J','')
START.COLUMN = POPUP.PARAMS<1>
IF OCONV(START.COLUMN,'MCN') = '' THEN START.COLUMN = 20
START.ROW = POPUP.PARAMS<2>
IF OCONV(START.ROW,'MCN') = '' THEN START.ROW = 6
LENGTH = POPUP.PARAMS<3>
IF OCONV(LENGTH,'MCN') = '' THEN LENGTH = 50
DEPTH = POPUP.PARAMS<4>
IF OCONV(DEPTH,'MCN') = '' THEN DEPTH = 10
FORMAT = 'L#':(LENGTH-2)
HIDE.CODE = POPUP.PARAMS<5>
NOTE = POPUP.PARAMS<6>
CRT @(START.COLUMN,START.ROW):STR(BLOCK,LENGTH):
FOR LINE = 1 TO DEPTH - 2
CRT @(START.COLUMN,START.ROW+LINE): BLOCK:STR(' ',LENGTH-2):BLOCK:
NEXT LINE
CRT @(START.COLUMN,START.ROW+LINE):STR(BLOCK,LENGTH):
CRT @(START.COLUMN+2, START.ROW+2):'PLEASE WAIT...':
*
VALID = ''
IF NOTE THEN VALID = 'Y'
NEW.ARRAY = ''
TOP = ''
NBR.LINES = DCOUNT(DATA.ARRAY,AM)
FOR ATTB = 1 TO NBR.LINES
STRING = DATA.ARRAY<1>
DATA.ARRAY = DELETE(DATA.ARRAY,1,0,0)
BEGIN CASE
CASE NOTE
NEW.ARRAY = STRING
CASE TRIM(STRING) = ''
NULL
CASE INDEX(STRING,'...',1) OR ATTB = 1
IF HIDE.CODE THEN STRING = STRING[INDEX(STRING,' ',1)+1,99]
LOCATE STRING IN TOP SETTING JUNK ELSE
TOP<-1> = STRING
END
CASE INDEX(STRING,'records listed',1)
NULL
CASE 1
WORD = FIELD(TRIM(STRING),' ', 1)
IF HIDE.CODE THEN STRING = TRIMF(STRING[COL2(),99])
LOCATE WORD IN VALID<1> SETTING TEST ELSE
VALID<1,-1> = WORD
COUNT = DCOUNT(VALID<1>,VM)
NEW.ARRAY<-1> = COUNT 'R#4':' ':STRING
END
END CASE
NEXT ATTB
*
NBR.LINES = DCOUNT(NEW.ARRAY, AM)
IF NOTE THEN
IF MYNAME = 'STK.REC' THEN
INSTRUCTIONS = ''
IF NBR.LINES > (DEPTH-2) THEN
INSTRUCTIONS = ' TO SCROLL,'
END
INSTRUCTIONS = INSTRUCTIONS:' ':RV.ON:'Y':RV.OFF:'es to acknowledge, or ':RV.ON:'TOP':RV.OFF:' to exit.'
NOTE = ''
END ELSE
INSTRUCTIONS = 'Press to continue...'
END
END ELSE
INSTRUCTIONS = 'Enter Line#, (enter) to Page (or ':RV.ON:'F':RV.OFF:'orward/':RV.ON:'B':RV.OFF:'ack) OR ':RV.ON:'!':RV.OFF
END
*
ATTB = 1
NBR.VALIDS = DCOUNT(VALID<1>,@VM)
PAGE.BACK = (DEPTH - 2 - DCOUNT(TOP,@AM)) * 2
LOOP
FOR LINE = 1 TO DEPTH-2
IF TOP # "" THEN
STRING = ' ':TOP
END ELSE
STRING = NEW.ARRAY
ATTB = ATTB + 1
END
CRT @(START.COLUMN+1,START.ROW+LINE):STRING FORMAT
NEXT LINE
IF NEW.ARRAY # '' THEN
CRT @(START.COLUMN+4,START.ROW+LINE):'More...':
END ELSE
CRT @(START.COLUMN,START.ROW+LINE):STR(BLOCK,LENGTH):
END
CRT @(0,23):CEOL:@(0,23):INSTRUCTIONS:
INPUT ANSWER:
TEST = ANSWER
CONVERT INVALID TO NOTHING IN TEST
IF TEST # ANSWER THEN ANSWER = ''
ANSWER = OCONV(ANSWER,'MCU')
BEGIN CASE
CASE ANSWER = 'F'
NULL
CASE ANSWER = 'B'
ATTB = ATTB - PAGE.BACK
CASE ANSWER = ' '
DATA.ARRAY = ' '
EXIT
CASE OCONV(ANSWER,'MCN') > 0
ANSWER = OCONV(ANSWER,'MCN')
ANSWER = VALID<1,ANSWER>
IF ANSWER # '' THEN
DATA.ARRAY = ANSWER
EXIT
END
CASE ANSWER = '!'
IF NOTE THEN DATA.ARRAY = ' ' ELSE DATA.ARRAY = ''
EXIT
CASE 1
* ALLOW THEM TO ENTER THE CODE DIRECTLY.
LOCATE ANSWER IN VALID<1> SETTING POS THEN
DATA.ARRAY = ANSWER
EXIT
END
END CASE
IF ATTB > NBR.LINES THEN
IF NOTE THEN
DATA.ARRAY = ' '
EXIT
END
ATTB = 1
END
IF ATTB < 1 THEN ATTB = 1
REPEAT
RETURN
END
FI
ED BP.WRM START
I
*********************************************************
******************** START
*********************************************************
******************** PROGRAMMERS LOG ********************
* BILLM - 12/19/2007 - REQUEST#: NONE. ADDED ADDITIONAL HTML STUFF.
* BILLM - 12/04/2007 - ADDED HTCD
* WRM - 11/01/2007 - ADDED CRLF
* HC - 09/20/2007 - CHANGE USER.ID FROM HC TO WRM
* WRM - 12/20/2006 - PUT IN RV.ON & RV.OFF
* WRM - 04/28/2006 - ADDED DATA FROM SESSIONS RECORD.
*********************************************************
$OPTIONS PICK
*
AM = CHAR(254)
VM = CHAR(253)
SVM = CHAR(252)
BELL = CHAR(7)
TAB = CHAR(9)
CR = CHAR(13)
LF = CHAR(10)
CRLF = CR:LF
IF @TERM.TYPE = 'ANSI' THEN
TOP.LINE = STR(CHAR(223),79)
BOTTOM.LINE = STR(CHAR(220),79)
BLOCK = CHAR(219)
END ELSE
TOP.LINE = STR(CHAR(149),79)
SIDE.LINE = CHAR(186)
BOTTOM.LINE = STR(CHAR(150),79)
BLOCK = CHAR(152)
END
NBSP = ' '
HTCD = '</td><td>' ; * HTML TABLE COLUMN DELIMITER
HTHD = '</th><th>' ; * HTML TABLE HEADING DELIMITER
HTML.HEADING = '<html>'
HTML.HEADING<-1> = '<body bgcolor=blue>'
HTML.HEADING<-1> = '<table border width="100%">'
HTML.FOOTING = '</table>'
HTML.FOOTING<-1> = '</body>'
HTML.FOOTING<-1> = '</html>'
CEOL = @(-4)
WHO = @LOGNAME
ACCOUNT = @WHO
USER.ID = FIELD(WHO,'\',2)
USER.ID = OCONV(USER.ID,'MCU')
IF USER.ID = 'HC' THEN USER.ID = 'WRM'
TODAY = DATE()
OTODAY = OCONV(TODAY,'D4/')
MONTH = FIELD(OTODAY,'/',1)
DAY = FIELD(OTODAY,'/',2)
YEAR = FIELD(OTODAY,'/',3)
NOW = TIME()
TIME = OCONV(NOW, 'MT')
RV.ON = @(-13)
RV.OFF = @(-14)
*
INVALID = ""
NOTHING = ""
FOR XXX = 0 TO 31
INVALID = INVALID:CHAR(XXX)
NEXT XXX
FOR XXX = 127 TO 250
INVALID = INVALID:CHAR(XXX)
NEXT XXX
*
LOWER = 'abcdefghijklmnopqrstuvwxyz'
UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
*
CONO = "001"
STRING = SENTENCE()
MYNAME = FIELD(STRING,' ',DCOUNT(STRING,' '))
FI
ED BP.WRM GET.NEXT.IDS
I
************************************************************
******************** GET.NEXT.IDS
************************************************************
SUBROUTINE GET.NEXT.IDS(FILENAME, NEXT.ID)
******************** PROGRAMMERS LOG ********************
* 03-08-12 WRM 11201 ADDED STARTING POINT FIELD (3) TO NEXT.IDS
* 02-24-11 WRM 10990 PUT IN LIMIT LOGIC.
* WRM - 10/31/2007 - CREATED.
*********************************************************
$INCLUDE START
*
OPEN 'NEXT.IDS' TO F.NEXT.IDS ELSE STOPM 'CANNOT OPEN NEXT.IDS FILE'
OPEN FILENAME TO F.FILENAME THEN
READU R.NEXT.IDS FROM F.NEXT.IDS, FILENAME ELSE R.NEXT.IDS = ''
NEXT.ID = R.NEXT.IDS<1>
LIMIT = R.NEXT.IDS<2>
STARTING.POINT = R.NEXT.IDS<3>
IF STARTING.POINT = '' THEN STARTING.POINT = 1
IF NEXT.ID = '' THEN NEXT.ID = STARTING.POINT
LOOP
IF LIMIT AND NEXT.ID > LIMIT THEN NEXT.ID = STARTING.POINT
READ TEST FROM F.FILENAME, NEXT.ID ELSE EXIT
NEXT.ID = NEXT.ID + 1
REPEAT
WRITEV NEXT.ID+1 ON F.NEXT.IDS, FILENAME, 1
RELEASE F.NEXT.IDS, FILENAME
END
*
RETURN
END
FI
ED BP.WRM LC
I
************************************************************
******************** LC
************************************************************
PROGRAM = "LC"
*
* 08-23-12 WRM 11308 MAKE IT WORK LIKE BP.WORK GC.
* WRM - 10/29/2004 - TO LOCALLY CATALOG PROGRAMS
*
IF OCONV(@WHO,'MCU') # 'TEST' THEN STOPM 'MUST BE RUN IN THE TEST ACCOUNT ONLY!'
OPEN 'VOC' TO VOC ELSE CRT 'UNABLE TO OPEN VOC FILE' ; STOP
FILENAME = FIELD(SENTENCE(),' ',2)
ITEM = FIELD(SENTENCE(),' ',3)
IF ITEM = '' THEN
ITEM = FILENAME
FILENAME = 'BP.WORK'
END
IF FILENAME = '' OR ITEM = '' THEN CRT 'SYNTAX: LC (ProgramName) (ItemName)' ; STOP
READ VOC.REC FROM VOC, ITEM THEN
IF VOC.REC<1> # 'V' AND VOC.REC<1>[1,2] # "V " THEN CRT 'VOC RECORD ALREADY EXISTS & IT IS NOT A CATALOGED PROGRAM' ; STOP
END
VOC.REC = ''
VOC.REC<1> = 'V'
VOC.REC<2> = FILENAME:'.O\':ITEM
VOC.REC<3> = 'B'
WRITE VOC.REC ON VOC, ITEM
CRT
CRT FILENAME:' ':ITEM:' LOCALLY CATALOGED!'
END
FI
BASIC BP.WRM BILD
CATALOG BP.WRM BILD
BASIC BP.WRM CREATE.XFILE
CATALOG BP.WRM CREATE.XFILE
BASIC BP.WRM POPUP
CATALOG BP.WRM POPUP
BASIC BP.WRM GET.NEXT.IDS
CATALOG BP.WRM GET.NEXT.IDS
BASIC BP.WRM LC
CATALOG BP.WRM LC