DIR01 ;SFISC/MKO-FIELD EDITOR ;12:37 PM 15 Feb 1995
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
I DIR0A]"",DIR0C=1 D F X IOXY Q:DIR0QT
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 ;
S DIR0QT=1
Q
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) ;
; 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 ;
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)
DIR01 ;SFISC/MKO-FIELD EDITOR ;12:37 PM 15 Feb 1995
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 IF DIR0A]""
IF DIR0C=1
DO F
XECUTE IOXY
IF DIR0QT
QUIT
+4 FOR
DO E
XECUTE IOXY
IF DIR0QT
QUIT
+5 QUIT
+6 ;
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 ;
+1 SET DIR0QT=1
+2 QUIT
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) ;
+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 ;
+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)
