* Direct Access entry fields
* 1.01 - handles lines with blanks
* DA filename {initial fields, separated with |}
* If filename is omitted, it will include code to run itself (try it!)
* Returns edit variables: L.0 = number of vars
* L.I - answer #I

* Data file format:
* fll TEXT
* f is field type:
* D - Digits
* S - String
* Example of restricted string input
* S1 Group type (G/1)
* R - Read only
* N - Non-empty
* M - (multiple) digits & spaces
* I - Invisible - for password entry
* ll is optional field length

PARSE ARG FIL PARMS
IF FIL='' THEN CALL INCLUDE_MYSELF


'KEDIT' FIL
IF SIZE.1()=0 THEN CALL ABORT 'DA: File' FIL 'not found'
'RIGHT 3'
'SET WORDWRAP OFF'


IF PARMS<>'' THEN CALL GETPARMS
'SET ALT 0 0' /* later we can use ALT() to sUe if there are changes */

':1'
DO I=1
   RO=0
   L=CURLINE.3()
   IF LEFT(L,1)='R' THEN RO=1
   CU=POS(':', L)
   'CURSOR FILE' LINE.1() CU+2

   L=GETL()
   IF WORD(L,1)='PASSWORD' THEN DO
      'EDITV SET L.0 1'
      'EDITV SET L.1' WORD(L,2)
      'QQUIT'
      EXIT
   END

   IF L='CURU' THEN DO; IF LINE.1()>1 THEN 'UP'; END
   ELSE IF L='CURD' THEN DO; IF LINE.1()<SIZE.1() THEN 'NEXT'; END
   ELSE IF L='C-PGUP' THEN ':1'
   ELSE IF L='C-PGDN' THEN ':'SIZE.1()
   ELSE IF (L='F10') & PARMS<>'' THEN LEAVE
   ELSE IF L='ESC' THEN DO
     IF FNAME.1()='THRAWN' THEN ITERATE
     IF PARMS='' THEN CALL ABORT
     IF NEED_TO_SAVE() THEN LEAVE
     ELSE CALL ABORT
   END
   ELSE DO
      'NEXT'
      IF RC>0 THEN LEAVE
   END
END
':1'
'TOP'
DO I=1
   'NEXT'
   IF RC>0 THEN LEAVE
   L=CURLINE.3()
   PARSE VAR L A ':' L
   'EDITV SETL L.'I L
END
'EDITV SET L.0' I-1 /* number of vars */

IF ALT() THEN 'EDITV SET RESULT 0'
ELSE 'EDITV SET RESULT 1'
'QQUIT'
EXIT

*GET GETL
*Like GINSBERG, but reads from filearea
GETL: PROCEDURE
* Version 1.11, with datatypes
* 1.02 - more cursor control
* 1.03 - check field length, jump to next field when end reached
*'POINT .TTT'; 'SET DEBUGG ON'; 'LOCATE .TTT'; TRACE ?R
L=CURLINE.3()
CU=POS(':', L)
IF CU=0 THEN CALL ABORT 'Field name must be terminated by colon'

PW=''
DCL=SUBSTR(L, 1, 1)
IF DCL='S' THEN DO
   IF POS(':)',L)>0 THEN DO
/* Example: S1  Code(G/1): */
      PARSE VAR L '(' CH ')'
      CH=SPACE(TRANSLATE(CH,' ','/'),0)
   END
   ELSE CH=''
END
LEN=SUBSTR(L, 2, 2)
IF ^DATATYPE(LEN,'N') & LEN<>'' THEN CALL ABORT 'Format: S|D|R xx Message'
IF LEN='' THEN LEN=500
SIZ=SIZE.1()
DO FOREVER
  'READV KEY'
  'NOMSG RESER 4 OFF'
  K=READV.1
  IF K='F1' THEN DO
     'SOS SAVE'
     'KEDIT' FNAME.1()'.HLP (PROF helpscr) Edit'
     'SOS RESTORE'
     ITERATE
  END

  IF K='F2' THEN DO
     'SOS SAVE'
     TX=PROMPT(L)
     'SOS RESTORE'
     IF TX<>'' THEN 'TEXT' TX
  END

  IF K='F4' & FNAME.1()='CORRECT' THEN DO
     'SOS SAVE'
     'MACRO AUTOMATE'
     'EDITV GET C'
     ':9'
     L=CURLINE.3()
     IF LEFT(L,1)='R' THEN RO=1
     CU=POS(':', L)
     'CURSOR FILE' LINE.1() CU+2
     'SOS ENDCHAR'
     'TEXT ,' C
  END

  IF K='ENTER' THEN LEAVE
  IF K='ESC' | K='F10' | K='CURU' | K='CURD' | K='C-PGUP' | K='C-PGDN' THEN RETURN K

  IF (DCL='R') THEN RETURN '' /* read/only line, no other keys allowed */
  IF K='C-HOME' THEN RETURN ''

  IF K='CURL' | K='C-CURL' | K='BKSP' THEN DO
     IF CURSOR.4()>CU+2 THEN 'MACRO' K
     ITERATE
  END

  IF K='HOME' THEN DO
     'SOS FIRSTCOL'
     'RIGHT 3'
     'CURSOR FILE' LINE.1() CU+2
     ITERATE
  END

  IF (READV.2=' ' & READV.1<>'SPACE') THEN DO
     R=READV.1
     IF R='END' | R='C-CURR' | R='CURR' | R='DEL' | R='INS' | R='C-END' THEN 'MACRO' K
  END
  ELSE DO
    C=READV.2
    NUM=DATATYPE(C,'N')
    IF (DCL='D' & ^NUM) | (DCL='M' & ^NUM & C<>' ') THEN DO
       'RESER 4 RED ON WHITE' CENTER(' This is numeric field ',80,'²')
       ITERATE
    END
    ELSE DO
      IF DCL='S' & CH<>'' & POS(C,CH)=0 THEN DO
         'RESER 4 RED ON WHITE' CENTER(' Allowed values are 'CH,80,'²')
         ITERATE
      END
      'RESET UNDO' /* so that we can undo just the next stmt */
      L=CURLINE.3()
      OL=LENGTH(L)
      IF DCL<>'I' THEN 'TEXT' C
      ELSE DO
        'TEXT *'
        PW=PW||C
      END
      L=CURLINE.3()
      WH=LENGTH(L) - CU - 1
      IF WH > LEN & LENGTH(L) > OL THEN DO
      'NOMSG UNDO'
      'RESER 4 RED ON WHITE' CENTER(' End of field reached ',80,'±')
      CALL BEE
      END
    END
  END
END
IF DCL<>'I' THEN RETURN CURLINE.3()
ELSE RETURN 'PASSWORD' PW

INCLUDE_MYSELF: PROCEDURE
"I PARSE SOURCE . . ME ."
"I PARSE VAR ME ME '.'"
"I 'MACRO DA' ME'.DAT'"
"I 'EDITV GET L.0';  DO I=1 TO L.0; 'EDITV GET L.'I; END"
EXIT
RETURN


*GET ABORT
ABORT: PROCEDURE
* CUSTOMIZED: sets edit variable RESULT
*Version 2.01 - show current module name
PARSE ARG A
PARSE SOURCE . . ME .
PARSE VAR ME ME '.'
IF A<>'' THEN 'ALERT' DELIMIT(A) 'TITLE' DELIMIT(UPPER(ME))
'EDITV SET L.0 0'
'EDITV SET RESULT 2'
'QQUIT'
EXIT
RETURN

GETPARMS:

*'POINT .TTT'; 'SET DEBUGG ON'; 'LOCATE .TTT'; TRACE ?I
L=PARMS
DO I=1
   PARSE VAR L L.I '|' L
   IF L.I='' & L='' THEN LEAVE
   ':'I
   'NOMSG CAP  'STRIP(L.I)
END
L.0=I-1
RETURN

NEED_TO_SAVE:
IF PARMS='' | ALT()=0 THEN RETURN 0
Y=YESNO('Record has been modified. Save changes ?')
IF Y='YES' THEN RETURN 1
RETURN 0

*GET YESNO
YESNO: PROCEDURE
*Version 2.00, allows any KEDIT button combo
PARSE ARG MSG, DEF, KIND
IF KIND='' THEN KIND='YESNO'
IF DEF='' THEN DEF=1
IF DEF='YES' THEN DEF=1
IF DEF='NO' THEN DEF=2
'DIALOG' DELIMIT(MSG) KIND 'DEFBUTTON' DEF
RETURN DIALOG.2

*GET BEE
BEE: PROCEDURE
'SET BEEP ON 50 1'
'SOS BEEP'
'SET BEEP OFF'
RETURN

*GET USERID
USERID: PROCEDURE
RETURN DOSENV('USER')

PROMPT: PROCEDURE
parse ARG L
* Like in RSMAIN, will popup a box with valid values for the field
PARSE VAR L ':'
L=STRIP(DELSTR(L,1,3))
FN=FNAME.1()'.'SUBSTR(L,1,3)
'SOS SAVE'
IF ^EXISTS(FN) THEN RETURN ''
A=LIST(FN,L)
'SOS RESTORE'
RETURN WORD(A,1)
/* Either 1 word altogether, or 1st word is the actual code */

*get list
LIST:
* 2.05 - will load list from current file if LABELS=''
*  also, passes ESC parm to POKE (which maybe INSDEL or just non-empty)
* Version 2.02 - restore statusline & mousebar settings
* Version 2.03 - supports different screen sizes, centers properly
* Version 2.04 - if filename is omitted, displays curfile
'COLOR C'COLOR.3() /* same as block */
STL=STATUSLINE.1()
MOU=MOUSEBAR.1()
'POINT .LJOB'
PARSE ARG LABELS,MSG,ESC
IF LABELS<>'' THEN 'KEDIT' LABELS '(NOPROF)'
LBLS=SIZE.1()
LINES=LBLS+3
ST= (PSCREEN.1() - LINES) % 2
IF ST<0 THEN ST=1
CALL CLEAR
CALL SMALLBOX ST,ST+2,'BRIGHT WHITE on CYAN', MSG, D2C(176)
'SET CURLINE' ST+4

LON=LONGEST()
':1'
LE=LENGTH(CURLINE.3())
SH=(80-LE) % 2
IF SIZE.1()>0 & SH>0 & VERSHIFT.1()=0 THEN 'LEFT' SH

T=POKE(SH+1,LON,ESC)
IF LABELS<>'' THEN 'QQUIT'
'LOCATE .LJOB'
'SET STATUSLINE' STL
'SET MOUSEBAR' MOU
RETURN STRIP(T)

LONGEST:
'TOP'
LO=0
DO FOREVER
   'NEXT'
   IF RC>0 THEN LEAVE
   L=CURLINE.3()
   LL=LENGTH(L)
   IF LL>LO THEN LO=LL
END
RETURN LO

*GET CLEAR
CLEAR:PROCEDURE
'STATUSLINE OFF'
'IDLINE OFF'
'PRE OFF'
'SCALE OFF'
'ARROW OFF'
'MOUSEBAR OFF'
IF RESER.0()>0 THEN DO
   WR=WORDS(RESER.1())
   R=RESER.1()
   DO I=1 TO WR
      W=WORD(R,I)
      'RESER' W 'OFF'
   END
END
RETURN

*GET SMALLBOX
SMALLBOX: PROCEDURE
*Version 2.04 - defaults in the middle of screen
*Version 2.03 - REALLY fixed centering. 2.02 broke it
PARSE ARG Y1,Y2, COLOR, TEXT, FILLC
IF Y1='' THEN Y1=11
IF Y2='' THEN Y2=13
IF TEXT='' THEN CALL ERR "Programmer's error in SMALLBOX procedure - no text specified"
IF FILLC=='' THEN FILLC=D2C(177)  /* Exact match, SPACE will fail  */

LT=LENGTH(TEXT)+2
BEF=(80 - LT - 4) % 2
BEFORE=COPIES(FILLC,BEF)
AFTER=COPIES(FILLC,BEF+3)

IF COLOR='' THEN COLOR='RED ON WHITE'
'RESER' Y1 COLOR BEFORE || 'É' || COPIES('Í',LT) || '»' || AFTER
'RESER' Y2 COLOR BEFORE || 'È' || COPIES('Í',LT) || '¼' || AFTER
DO I=Y1+1 TO Y2-1
   'RESER' I COLOR BEFORE || 'º' COPIES(' ',LT) || 'º' || AFTER
END
MI=Y1+1
'RESER' MI COLOR BEFORE || 'º' TEXT 'º' || AFTER

RETURN

*GET ERR
ERR: PROCEDURE
'ALERT' DELIMIT(CURLINE.3()) 'TITLE' DELIMIT(ARG(1))
EXIT

*GET POKE
POKE: PROCEDURE
* 2.6 - when ESC is set to INSDEL, allows these keys, sets EDITV VAR SPEC
*Version 2.05 - supports configurable ESC key
*Version 2.04 - does not use buggy SOS CURRENT
* 2.01 - LS fix, 2.02 - fix for LIST speedsearch,
* 2.03 - no PgUp/Dn for short files
ARG SH, LE, ESC
IF SH='' THEN SH=1
IF LE='' THEN LE=79
'CURSOR FILE' LINE.1()
'SOS FIRSTCHAR'
SIZ=SIZE.1()
DO FOREVER
   'RESET BLOCK'
    'MARK BOX'
    'CURSOR =' SH+LE
    'MARK BOX'
    'CURSOR =' SH
   'READV KEY'
   IF READV.1 = 'CURU' THEN DO
      IF LINE.1()=1 THEN NOP
      ELSE 'CURSOR UP'
   END
   ELSE IF READV.1 = 'CURD' THEN DO
      IF LINE.1()=SIZE.1() THEN NOP
      ELSE 'CURSOR DOWN'
   END
   ELSE IF READV.1 = 'PGUP' THEN DO
      IF SIZE.1()>20 THEN DO
         'BACKWARD'
         IF LINE.1()=0 THEN 'CURSOR DOWN'
      END
   END
   ELSE IF READV.1 = 'PGDN' THEN DO
      IF SIZE.1()>20 THEN DO
         'FORWARD'
         IF EOF() THEN 'CURSOR UP'
      END
   END
   ELSE IF READV.1 = 'HOME' THEN DO
      IF LINE.1()<>1 THEN ':1'
   END
   ELSE IF READV.1 = 'END' THEN DO
      'BOT'
   END
   ELSE IF READV.1 = 'ESC' THEN DO
      IF ESC<>'' THEN RETURN -1
   END
   ELSE IF READV.1 = 'INS' | READV.1='DEL' THEN DO
      IF ESC='INSDEL' THEN DO
         'EDITV SET SPEC' READV.1
         RETURN CURLINE.3()
      END
   END
   ELSE IF READV.1 = 'ENTER' THEN DO
      RETURN CURLINE.3()
   END
   ELSE IF DATATYPE(READV.2,'A') THEN DO
      TRG=UPPER(READV.2)
      CALL SPEEDSEARCH
   END
END
RETURN -1

SPEEDSEARCH:
SL=LINE.1()
IF ^DATATYPE(LS,'N') THEN LS=1
DO FOREVER
   'NEXT'
   IF RC>0 THEN ':'LS
   L=LINE.1()
   IF L=SL THEN LEAVE
   N=CURLINE.3()
   N=UPPER(SUBSTR(STRIP(N),1,1))
   IF N=TRG THEN LEAVE
END
RETURN

*GET EXISTS
EXISTS: PROCEDURE
* Version 2.01
ARG A
IF POS('.',A)=0 THEN A=A'.'
'NOMSG DIR' ARG(1)
IF RC=0 THEN DO
   'QQUIT'
   RETURN 1
END
ELSE RETURN 0

CHEKA:
IF O.1<>'C' & L.1<>'C' THEN DO
/* This is check for STA being changed to C */
   JOB=L.3
   RN=L.2
   'X' JOB'.TEL'
   'TOP'
   'NOMSG /#'RN
   PC=RC
   'QUIT'
END

RETURN