- DIR01 ;SFISC/MKO-FIELD EDITOR ;12DEC2004
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- I DIR0A]"",DIR0C=1 D F X IOXY Q:DIR0QT ;There's a default answer; single-char READ
- F D E X IOXY Q:DIR0QT
- Q
- ;
- F D READ(.DIR0CH)
- I "?^"'[DIR0CH=$L(DIR0CH) S DIR0A="" D REP,DEOF Q
- D:DIR0CH]"" E1
- Q
- ;
- E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),DIR0F>DX,DIR0M>$L(DIR0A),'$D(DIR0KD) D
- . D PREAD($$MIN(DIR0F-DX,DIR0M-DIR0C+1),.DIR0ST,.DIR0CH)
- . Q:DIR0ST=""
- . S DIR0CHG=1
- . I '$G(DIR0("REP")) S DIR0A=DIR0A_DIR0ST
- . E S $E(DIR0A,DIR0C,DIR0C+$L(DIR0ST)-1)=DIR0ST
- . S DX=DX+$L(DIR0ST),DIR0C=DIR0C+$L(DIR0ST)
- E D READ(.DIR0CH)
- Q:DIR0CH=""
- ;
- E1 I "?^"[DIR0CH,DIR0C=1,'DIR0QU S DIR0A="",DIR0QU=1 D REP,DEOF Q
- D @$S($L(DIR0CH)>1:DIR0CH,$G(DIR0("REP")):"REP",1:"INS")
- I DIR0QU,"?^"'[$E(DIR0A)!'$L(DIR0A) S DIR0QU=0,DIR0A="" D CLR
- Q
- ;
- REP I DIR0C>DIR0M W $C(7) Q
- S DIR0CHG=1
- S $E(DIR0A,DIR0C)=DIR0CH,DIR0C=DIR0C+1
- I DIR0F>DX S DX=DX+1 W DIR0CH Q
- N DIX
- S DIX=DIR0C-(DIR0L\2)
- S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
- S DX=DIR0S X IOXY
- W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
- Q
- ;
- INS I $L(DIR0A)'<DIR0M W $C(7) Q
- S DIR0CHG=1
- S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C,999),DIR0C=DIR0C+1
- I DIR0F>DX S DX=DX+1 W $E(DIR0A,DIR0C-1,DIR0C+DIR0F-DX-1) Q
- S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1) S DX=DIR0F
- Q
- ;
- RIGHT Q:DIR0C>$L(DIR0A)
- I DX<DIR0F S DX=DX+1,DIR0C=DIR0C+1 Q
- S DIR0C=DIR0C+1,DX=DIR0S X IOXY
- W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
- S DX=DIR0F
- Q
- ;
- LEFT Q:DIR0C'>1
- I DX>DIR0S S DX=DX-1,DIR0C=DIR0C-1 Q
- S DIR0C=DIR0C-1 W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
- Q
- ;
- JRT Q:DIR0C>$L(DIR0A)
- I DIR0F=DX D Q
- . S DIR0C=DIR0C+DIR0L S:DIR0C+1>$L(DIR0A) DIR0C=$L(DIR0A)+1
- . S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
- . S DX=DIR0F
- N DIX
- S DIX=$L(DIR0A)-DIR0C+1
- I DIR0F-DX>DIX S DX=DX+DIX,DIR0C=DIR0C+DIX Q
- S DIR0C=DIR0C+DIR0F-DX,DX=DIR0F
- Q
- ;
- JLT Q:DIR0C'>1
- I DX=DIR0S D Q
- . S DIR0C=DIR0C-DIR0L S:DIR0C<1 DIR0C=1
- . W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
- S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
- Q
- ;
- FDE Q:DIR0C>$L(DIR0A)
- I DX+$L(DIR0A)-DIR0C-DIR0L<DIR0S D Q
- . S DX=DX+$L(DIR0A)-DIR0C+1,DIR0C=$L(DIR0A)+1
- S DIR0C=$L(DIR0A)+1,DX=DIR0S X IOXY
- W $E(DIR0A,DIR0C-DIR0L,DIR0C)
- S DX=DIR0F
- Q
- ;
- FDB Q:DIR0C'>1
- I DX-DIR0C+1<DIR0S S DX=DIR0S X IOXY W $E(DIR0A,1,DIR0L)
- S DX=DIR0S,DIR0C=1
- Q
- ;
- BS Q:DIR0C'>1
- S DIR0CHG=1
- S DIR0C=DIR0C-1,DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
- I DX>DIR0S D Q
- . S DX=DX-1 X IOXY
- . W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
- N DIX
- S DIX=DIR0C-(DIR0L\2)
- S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
- S:DIX<1 DIX=1
- W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
- Q
- ;
- DEL Q:DIR0C>$L(DIR0A)!(DIR0F'>DX)
- S DIR0CHG=1
- S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
- W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
- Q
- ;
- CLR S DIR0CHG=1
- S DIR0C=1,DX=DIR0S X IOXY
- I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
- S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
- W $E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
- Q
- ;
- DEOF S DIR0CHG=1
- W $E(DIR0SP,DX-DIR0S+1,999)
- S DIR0A=$E(DIR0A,1,DIR0C-1)
- Q
- ;
- RPM N DX,DY
- I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
- I $G(DIR0("REP")) W:$D(DDS) "Insert " K DIR0("REP")
- E W:$D(DDS) "Replace" S DIR0("REP")=1
- Q
- ;
- KPM I $G(DDGLKPNM) K DDGLKPNM W $P(DDGLED,DDGLDEL,9)
- E S DDGLKPNM=1 W $P(DDGLED,DDGLDEL,10)
- Q
- ;
- WRT G WRT^DIR0W
- WLT G WLT^DIR0W
- DLW G DLW^DIR0W
- HLP G ^DIR0H
- ZM G SM^DIR02
- ;
- TO I $D(DIR0TO)#2 D @DIR0TO Q
- S DTOUT=1
- UP ;
- DOWN ;
- TAB ;
- FDL ;
- CR ;
- NB ;
- NP ;
- PP ;
- SEL ;
- EX ;
- QT ;
- CL ;
- SV ;
- RF ;
- PRNT ;
- S DIR0QT=1
- Q
- ;
- MOUSERT ;not used(?)
- Q
- MOUSEDN N % R *%,*%
- Q
- ;
- MOUSE ;
- X DDGLZOSF("EOFF") R *DDSMX,*DDSMY X DDGLZOSF("EON") S DDSMX=DDSMX-33,DDSMY=DDSMY-33,DDSMOUSY=1 ;Get $X,$Y from mouse
- S X="" F S X=$O(DDSMOUSE(DDSMY,X)) Q:X=""!(X>DDSMX) S P=$O(DDSMOUSE(DDSMY,X,"")) I P'<DDSMX S X=$G(DDSMOUSE(DDSMY,X,P,1)) S:X]"" DIR0A=X Q ;MOUSE clicked on CHOICE
- I +DIR0=DDSMY,DDSMX'<$P(DIR0,U,2),$P(DIR0,U,2)+$P(DIR0,U,3)-1'<DDSMX D ;MOUSE CLICK is where we already are
- .S DIR0CH="CR" ;SELECT if this is "CLOSE" Command, or if field is filled in, & has BRANCHING LOGIC or is just REACHABLE
- .I $G(DIR0A)]"",$G(DDS) Q:DDSMY+1=IOSL I $G(DDSBK),$G(DDO) Q:$G(^DIST(.404,DDSBK,40,DDO,10))]""!($P($G(^(4)),U,4)=2)
- .S DIR0A="??" ;Otherwise, give HELP
- G EX
- ;
- NOP W $C(7)
- Q
- ;
- READ(Y) ;Out: Y=char or mnemonic
- F D Q:Y'=-1
- . R *Y:DTIME
- . I Y>31,Y<127 S Y=$C(Y) Q
- . I Y<0 S Y="TO" Q
- . D MNE(.Y)
- I Y'="TO",$D(DIR0KD) D @DIR0KD
- Q
- ;
- PREAD(DIR0LEN,DIR0ST,Y) ;CALLED BY DIR03. Y is really DIR0CH
- ; Y = Mnem, Null if DIR0LEN chars read or invalid
- X DDGLZOSF("EON")
- R DIR0ST#DIR0LEN:DTIME E S Y="TO" Q
- X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
- I $C(Y)?1C,Y D
- . D MNE(.Y) S:Y=-1 Y=""
- E S Y=""
- Q
- ;
- MNE(Y) ;Out: Y=mnemonic, or -1 if invalid
- N S,F
- S S="",F=0
- F D MNELOOP Q:F
- Q
- ;
- MNELOOP ;translate IN to OUT
- S S=S_$C(Y)
- I DIR0(DIR0P_"IN")'[(U_S) D I Y=-1 D FLUSH Q
- . I $C(Y)'?1L S Y=-1 Q
- . S S=$E(S,1,$L(S)-1)_$C(Y-32)
- . S:DIR0(DIR0P_"IN")'[(U_S_U) Y=-1
- ;
- I DIR0(DIR0P_"IN")[(U_S_U),S'=$C(27) D
- . S Y=$P(DIR0(DIR0P_"OUT"),";",$L($P(DIR0(DIR0P_"IN"),U_S_U),U)),F=1
- E R *Y:5 D:Y=-1 FLUSH
- Q
- ;
- FLUSH N X
- S F=1 W $C(7) F R *X:0 E Q
- Q
- ;
- MIN(X,Y) ;
- Q $S(X<Y:X,1:Y)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIR01 5685 printed Feb 19, 2025@00:20:02 Page 2
- DIR01 ;SFISC/MKO-FIELD EDITOR ;12DEC2004
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 ;There's a default answer; single-char READ
- IF DIR0A]""
- IF DIR0C=1
- DO F
- XECUTE IOXY
- if DIR0QT
- QUIT
- +8 FOR
- DO E
- XECUTE IOXY
- if DIR0QT
- QUIT
- +9 QUIT
- +10 ;
- F DO READ(.DIR0CH)
- +1 IF "?^"'[DIR0CH=$LENGTH(DIR0CH)
- SET DIR0A=""
- DO REP
- DO DEOF
- QUIT
- +2 if DIR0CH]""
- DO E1
- +3 QUIT
- +4 ;
- E IF $GET(DIR0("REP"))&DIR0C>1!(DIR0C>$LENGTH(DIR0A))
- IF DIR0F>DX
- IF DIR0M>$LENGTH(DIR0A)
- IF '$DATA(DIR0KD)
- Begin DoDot:1
- +1 DO PREAD($$MIN(DIR0F-DX,DIR0M-DIR0C+1),.DIR0ST,.DIR0CH)
- +2 if DIR0ST=""
- QUIT
- +3 SET DIR0CHG=1
- +4 IF '$GET(DIR0("REP"))
- SET DIR0A=DIR0A_DIR0ST
- +5 IF '$TEST
- SET $EXTRACT(DIR0A,DIR0C,DIR0C+$LENGTH(DIR0ST)-1)=DIR0ST
- +6 SET DX=DX+$LENGTH(DIR0ST)
- SET DIR0C=DIR0C+$LENGTH(DIR0ST)
- End DoDot:1
- +7 IF '$TEST
- DO READ(.DIR0CH)
- +8 if DIR0CH=""
- QUIT
- +9 ;
- E1 IF "?^"[DIR0CH
- IF DIR0C=1
- IF 'DIR0QU
- SET DIR0A=""
- SET DIR0QU=1
- DO REP
- DO DEOF
- QUIT
- +1 DO @$SELECT($LENGTH(DIR0CH)>1:DIR0CH,$GET(DIR0("REP")):"REP",1:"INS")
- +2 IF DIR0QU
- IF "?^"'[$EXTRACT(DIR0A)!'$LENGTH(DIR0A)
- SET DIR0QU=0
- SET DIR0A=""
- DO CLR
- +3 QUIT
- +4 ;
- REP IF DIR0C>DIR0M
- WRITE $CHAR(7)
- QUIT
- +1 SET DIR0CHG=1
- +2 SET $EXTRACT(DIR0A,DIR0C)=DIR0CH
- SET DIR0C=DIR0C+1
- +3 IF DIR0F>DX
- SET DX=DX+1
- WRITE DIR0CH
- QUIT
- +4 NEW DIX
- +5 SET DIX=DIR0C-(DIR0L\2)
- +6 if $LENGTH(DIR0A)-DIX+1<DIR0L
- SET DIX=$LENGTH(DIR0A)-DIR0L+1
- +7 SET DX=DIR0S
- XECUTE IOXY
- +8 WRITE $EXTRACT(DIR0A,DIX,DIX+DIR0L-1)
- SET DX=DIR0S+DIR0C-DIX
- +9 QUIT
- +10 ;
- INS IF $LENGTH(DIR0A)'<DIR0M
- WRITE $CHAR(7)
- QUIT
- +1 SET DIR0CHG=1
- +2 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_DIR0CH_$EXTRACT(DIR0A,DIR0C,999)
- SET DIR0C=DIR0C+1
- +3 IF DIR0F>DX
- SET DX=DX+1
- WRITE $EXTRACT(DIR0A,DIR0C-1,DIR0C+DIR0F-DX-1)
- QUIT
- +4 SET DX=DIR0S
- XECUTE IOXY
- WRITE $EXTRACT(DIR0A,DIR0C-DIR0L,DIR0C-1)
- SET DX=DIR0F
- +5 QUIT
- +6 ;
- RIGHT if DIR0C>$LENGTH(DIR0A)
- QUIT
- +1 IF DX<DIR0F
- SET DX=DX+1
- SET DIR0C=DIR0C+1
- QUIT
- +2 SET DIR0C=DIR0C+1
- SET DX=DIR0S
- XECUTE IOXY
- +3 WRITE $EXTRACT(DIR0A,DIR0C-DIR0L,DIR0C-1)
- +4 SET DX=DIR0F
- +5 QUIT
- +6 ;
- LEFT if DIR0C'>1
- QUIT
- +1 IF DX>DIR0S
- SET DX=DX-1
- SET DIR0C=DIR0C-1
- QUIT
- +2 SET DIR0C=DIR0C-1
- WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0L-1)
- +3 QUIT
- +4 ;
- JRT if DIR0C>$LENGTH(DIR0A)
- QUIT
- +1 IF DIR0F=DX
- Begin DoDot:1
- +2 SET DIR0C=DIR0C+DIR0L
- if DIR0C+1>$LENGTH(DIR0A)
- SET DIR0C=$LENGTH(DIR0A)+1
- +3 SET DX=DIR0S
- XECUTE IOXY
- WRITE $EXTRACT(DIR0A,DIR0C-DIR0L,DIR0C-1)
- +4 SET DX=DIR0F
- End DoDot:1
- QUIT
- +5 NEW DIX
- +6 SET DIX=$LENGTH(DIR0A)-DIR0C+1
- +7 IF DIR0F-DX>DIX
- SET DX=DX+DIX
- SET DIR0C=DIR0C+DIX
- QUIT
- +8 SET DIR0C=DIR0C+DIR0F-DX
- SET DX=DIR0F
- +9 QUIT
- +10 ;
- JLT if DIR0C'>1
- QUIT
- +1 IF DX=DIR0S
- Begin DoDot:1
- +2 SET DIR0C=DIR0C-DIR0L
- if DIR0C<1
- SET DIR0C=1
- +3 WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0L-1)
- End DoDot:1
- QUIT
- +4 SET DIR0C=DIR0C-DX+DIR0S
- SET DX=DIR0S
- +5 QUIT
- +6 ;
- FDE if DIR0C>$LENGTH(DIR0A)
- QUIT
- +1 IF DX+$LENGTH(DIR0A)-DIR0C-DIR0L<DIR0S
- Begin DoDot:1
- +2 SET DX=DX+$LENGTH(DIR0A)-DIR0C+1
- SET DIR0C=$LENGTH(DIR0A)+1
- End DoDot:1
- QUIT
- +3 SET DIR0C=$LENGTH(DIR0A)+1
- SET DX=DIR0S
- XECUTE IOXY
- +4 WRITE $EXTRACT(DIR0A,DIR0C-DIR0L,DIR0C)
- +5 SET DX=DIR0F
- +6 QUIT
- +7 ;
- FDB if DIR0C'>1
- QUIT
- +1 IF DX-DIR0C+1<DIR0S
- SET DX=DIR0S
- XECUTE IOXY
- WRITE $EXTRACT(DIR0A,1,DIR0L)
- +2 SET DX=DIR0S
- SET DIR0C=1
- +3 QUIT
- +4 ;
- BS if DIR0C'>1
- QUIT
- +1 SET DIR0CHG=1
- +2 SET DIR0C=DIR0C-1
- SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_$EXTRACT(DIR0A,DIR0C+1,999)
- +3 IF DX>DIR0S
- Begin DoDot:1
- +4 SET DX=DX-1
- XECUTE IOXY
- +5 WRITE $EXTRACT(DIR0A_$EXTRACT(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
- End DoDot:1
- QUIT
- +6 NEW DIX
- +7 SET DIX=DIR0C-(DIR0L\2)
- +8 if $LENGTH(DIR0A)-DIX+1<DIR0L
- SET DIX=$LENGTH(DIR0A)-DIR0L+1
- +9 if DIX<1
- SET DIX=1
- +10 WRITE $EXTRACT(DIR0A,DIX,DIX+DIR0L-1)
- SET DX=DIR0S+DIR0C-DIX
- +11 QUIT
- +12 ;
- DEL if DIR0C>$LENGTH(DIR0A)!(DIR0F'>DX)
- QUIT
- +1 SET DIR0CHG=1
- +2 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_$EXTRACT(DIR0A,DIR0C+1,999)
- +3 WRITE $EXTRACT(DIR0A_$EXTRACT(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
- +4 QUIT
- +5 ;
- CLR SET DIR0CHG=1
- +1 SET DIR0C=1
- SET DX=DIR0S
- XECUTE IOXY
- +2 IF DIR0A]""
- IF DIR0A'=DIR0D
- SET DIR0SV=DIR0A
- +3 SET DIR0A=$SELECT(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
- +4 WRITE $EXTRACT(DIR0A,1,DIR0L)_$EXTRACT(DIR0SP,$LENGTH(DIR0A)+1,999)
- +5 QUIT
- +6 ;
- DEOF SET DIR0CHG=1
- +1 WRITE $EXTRACT(DIR0SP,DX-DIR0S+1,999)
- +2 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)
- +3 QUIT
- +4 ;
- RPM NEW DX,DY
- +1 IF $DATA(DDS)
- SET DX=IOM-8
- SET DY=IOSL-1
- XECUTE IOXY
- +2 IF $GET(DIR0("REP"))
- if $DATA(DDS)
- WRITE "Insert "
- KILL DIR0("REP")
- +3 IF '$TEST
- if $DATA(DDS)
- WRITE "Replace"
- SET DIR0("REP")=1
- +4 QUIT
- +5 ;
- KPM IF $GET(DDGLKPNM)
- KILL DDGLKPNM
- WRITE $PIECE(DDGLED,DDGLDEL,9)
- +1 IF '$TEST
- SET DDGLKPNM=1
- WRITE $PIECE(DDGLED,DDGLDEL,10)
- +2 QUIT
- +3 ;
- WRT GOTO WRT^DIR0W
- WLT GOTO WLT^DIR0W
- DLW GOTO DLW^DIR0W
- HLP GOTO ^DIR0H
- ZM GOTO SM^DIR02
- +1 ;
- TO IF $DATA(DIR0TO)#2
- DO @DIR0TO
- QUIT
- +1 SET DTOUT=1
- UP ;
- DOWN ;
- TAB ;
- FDL ;
- CR ;
- NB ;
- NP ;
- PP ;
- SEL ;
- EX ;
- QT ;
- CL ;
- SV ;
- RF ;
- PRNT ;
- +1 SET DIR0QT=1
- +2 QUIT
- +3 ;
- MOUSERT ;not used(?)
- +1 QUIT
- MOUSEDN NEW %
- READ *%,*%
- +1 QUIT
- +2 ;
- MOUSE ;
- +1 ;Get $X,$Y from mouse
- XECUTE DDGLZOSF("EOFF")
- READ *DDSMX,*DDSMY
- XECUTE DDGLZOSF("EON")
- SET DDSMX=DDSMX-33
- SET DDSMY=DDSMY-33
- SET DDSMOUSY=1
- +2 ;MOUSE clicked on CHOICE
- SET X=""
- FOR
- SET X=$ORDER(DDSMOUSE(DDSMY,X))
- if X=""!(X>DDSMX)
- QUIT
- SET P=$ORDER(DDSMOUSE(DDSMY,X,""))
- IF P'<DDSMX
- SET X=$GET(DDSMOUSE(DDSMY,X,P,1))
- if X]""
- SET DIR0A=X
- QUIT
- +3 ;MOUSE CLICK is where we already are
- IF +DIR0=DDSMY
- IF DDSMX'<$PIECE(DIR0,U,2)
- IF $PIECE(DIR0,U,2)+$PIECE(DIR0,U,3)-1'<DDSMX
- Begin DoDot:1
- +4 ;SELECT if this is "CLOSE" Command, or if field is filled in, & has BRANCHING LOGIC or is just REACHABLE
- SET DIR0CH="CR"
- +5 IF $GET(DIR0A)]""
- IF $GET(DDS)
- if DDSMY+1=IOSL
- QUIT
- IF $GET(DDSBK)
- IF $GET(DDO)
- if $GET(^DIST(.404,DDSBK,40,DDO,10))]""!($PIECE($GET(^(4)),U,4)=2)
- QUIT
- +6 ;Otherwise, give HELP
- SET DIR0A="??"
- End DoDot:1
- +7 GOTO EX
- +8 ;
- NOP WRITE $CHAR(7)
- +1 QUIT
- +2 ;
- READ(Y) ;Out: Y=char or mnemonic
- +1 FOR
- Begin DoDot:1
- +2 READ *Y:DTIME
- +3 IF Y>31
- IF Y<127
- SET Y=$CHAR(Y)
- QUIT
- +4 IF Y<0
- SET Y="TO"
- QUIT
- +5 DO MNE(.Y)
- End DoDot:1
- if Y'=-1
- QUIT
- +6 IF Y'="TO"
- IF $DATA(DIR0KD)
- DO @DIR0KD
- +7 QUIT
- +8 ;
- PREAD(DIR0LEN,DIR0ST,Y) ;CALLED BY DIR03. Y is really DIR0CH
- +1 ; Y = Mnem, Null if DIR0LEN chars read or invalid
- +2 XECUTE DDGLZOSF("EON")
- +3 READ DIR0ST#DIR0LEN:DTIME
- IF '$TEST
- SET Y="TO"
- QUIT
- +4 XECUTE DDGLZOSF("EOFF")
- XECUTE DDGLZOSF("TRMRD")
- +5 IF $CHAR(Y)?1C
- IF Y
- Begin DoDot:1
- +6 DO MNE(.Y)
- if Y=-1
- SET Y=""
- End DoDot:1
- +7 IF '$TEST
- SET Y=""
- +8 QUIT
- +9 ;
- MNE(Y) ;Out: Y=mnemonic, or -1 if invalid
- +1 NEW S,F
- +2 SET S=""
- SET F=0
- +3 FOR
- DO MNELOOP
- if F
- QUIT
- +4 QUIT
- +5 ;
- MNELOOP ;translate IN to OUT
- +1 SET S=S_$CHAR(Y)
- +2 IF DIR0(DIR0P_"IN")'[(U_S)
- Begin DoDot:1
- +3 IF $CHAR(Y)'?1L
- SET Y=-1
- QUIT
- +4 SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)
- +5 if DIR0(DIR0P_"IN")'[(U_S_U)
- SET Y=-1
- End DoDot:1
- IF Y=-1
- DO FLUSH
- QUIT
- +6 ;
- +7 IF DIR0(DIR0P_"IN")[(U_S_U)
- IF S'=$CHAR(27)
- Begin DoDot:1
- +8 SET Y=$PIECE(DIR0(DIR0P_"OUT"),";",$LENGTH($PIECE(DIR0(DIR0P_"IN"),U_S_U),U))
- SET F=1
- End DoDot:1
- +9 IF '$TEST
- READ *Y:5
- if Y=-1
- DO FLUSH
- +10 QUIT
- +11 ;
- FLUSH NEW X
- +1 SET F=1
- WRITE $CHAR(7)
- FOR
- READ *X:0
- IF '$TEST
- QUIT
- +2 QUIT
- +3 ;
- MIN(X,Y) ;
- +1 QUIT $SELECT(X<Y:X,1:Y)