DIR03 ;SFISC/MKO-MULTILINE FIELD EDITOR ;11OCT2004
;;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.
;
F D E X IOXY Q:DIR0DN!$G(DIR0QT)
Q
;
E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),$S(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)>DX,'$D(DIR0KD) D
. D PREAD^DIR01($S(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)-DX,.DIR0ST,.DIR0CH)
. Q:'$L(DIR0ST)
. 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^DIR01(.DIR0CH)
Q:DIR0CH=""
;
I "?^"[DIR0CH,DIR0C=1,'DIR0QU D Q
. D DEOF X IOXY
. S DIR0A="",DIR0QU=1 D REP
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 DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C+1,999)
S DIR0C=DIR0C+1
W DIR0CH
I DX<DIR0F S DX=DX+1 Q
S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S Q
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)
W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
D
. N DIR0LN,DY,DX
. S DX=DIR0S
. F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
.. S DY=DIR0R+DIR0LN-1 X IOXY
.. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
S DIR0C=DIR0C+1
I DX<DIR0F S DX=DX+1 Q
S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S
Q
;
RIGHT Q:DIR0C>$L(DIR0A)
S DIR0C=DIR0C+1
I DX<DIR0F!(DIR0LN=DIR0NL) S DX=DX+1 Q
S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S
Q
;
LEFT Q:DIR0C'>1
S DIR0C=DIR0C-1
I DX>DIR0S S DX=DX-1 Q
S DIR0LN=DIR0LN-1,DY=DY-1,DX=DIR0F
Q
;
JRT Q:DIR0C>$L(DIR0A)
Q:DX=DIR0F
S DIR0C=DIR0LN*DIR0L S:DIR0C>$L(DIR0A) DIR0C=$L(DIR0A)+1
S DX=DIR0C#DIR0L-1+DIR0S S:DX<DIR0S DX=DIR0F
Q
;
JLT Q:DIR0C'>1
Q:DX=DIR0S
S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
Q
;
UP Q:DIR0LN=1
S DIR0C=DIR0C-DIR0L,DIR0LN=DIR0LN-1,DY=DY-1
Q
;
DOWN Q:DIR0LN=DIR0NL
Q:$L(DIR0A)\DIR0L<DIR0LN
S DIR0C=DIR0C+DIR0L,DIR0LN=DIR0LN+1,DY=DY+1
S:DIR0C>($L(DIR0A)+1) DIR0C=$L(DIR0A)+1,DX=DIR0C#DIR0L+DIR0S-1
Q
;
FDE ;
NP Q:DIR0C>$L(DIR0A)
S DIR0C=$L(DIR0A)+1,DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
S DY=DIR0R+DIR0LN-1
Q
;
FDB ;
PP Q:DIR0C'>1
S DIR0LN=1,DY=DIR0R,DX=DIR0S,DIR0C=1
Q
;
BS Q:DIR0C'>1
S DIR0CHG=1
S DX=DX-1,DIR0C=DIR0C-1
S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)_" "
I DX<DIR0S S DIR0LN=DIR0LN-1,DY=DY-1,DX=DIR0F
X IOXY W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
D
. N DIR0LN,DY,DX
. S DX=DIR0S
. F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
.. S DY=DIR0R+DIR0LN-1 X IOXY
.. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
S DIR0A=$E(DIR0A,1,$L(DIR0A)-1)
Q
;
DEL Q:DIR0C>$L(DIR0A)
S DIR0CHG=1
S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)_" "
W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
D
. N DIR0LN,DY,DX
. S DX=DIR0S
. F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
.. S DY=DIR0R+DIR0LN-1 X IOXY
.. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
S DIR0A=$E(DIR0A,1,$L(DIR0A)-1)
Q
;
CLR N %X
S DIR0CHG=1
S %X=DIR0A
I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
S %X=DIR0A_$J("",$L(%X)-$L(DIR0A))
S DX=DIR0S
F DIR0LN=1:1:$L(%X)\DIR0L+1 D
. S DY=DIR0R+DIR0LN-1 X IOXY
. W $E(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
S (DIR0C,DIR0LN)=1,DY=DIR0R
Q
;
DEOF N %X
Q:DIR0C>$L(DIR0A)
S DIR0CHG=1
S %X=DIR0A,DIR0A=$E(DIR0A,1,DIR0C-1),%X=DIR0A_$J("",$L(%X)-$L(DIR0A))
W $E(%X,DIR0C,DIR0C+DIR0F-DX)
D
. N DIR0LN,DY,DX
. S DX=DIR0S
. F DIR0LN=DIR0C-1\DIR0L+2:1:$L(%X)\DIR0L+1 D
.. S DY=DIR0R+DIR0LN-1 X IOXY
.. W $E(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
Q
;
RPM N DX,DY
I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
I $G(DIR0("REP")) W "Insert " K DIR0("REP")
E W "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 WRT2^DIR0W
WLT ;
FDL G WLT2^DIR0W
DLW G DLW2^DIR0W
;
HLP ;
NB ;
SEL ;
SV ;
RF ;
NOP W $C(7)
Q
TO I $D(DIR0TO)#2 D @DIR0TO Q
S DTOUT=1
ZM ;
QT ;
EX ;
CL ;
TAB ;
CR S DIR0DN=1
Q
;
MOUSEDN N % R *%,*%
Q
MOUSE G MOUSE^DIR01
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIR03 4423 printed Dec 13, 2024@02:53:49 Page 2
DIR03 ;SFISC/MKO-MULTILINE FIELD EDITOR ;11OCT2004
+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 FOR
DO E
XECUTE IOXY
if DIR0DN!$GET(DIR0QT)
QUIT
+8 QUIT
+9 ;
E IF $GET(DIR0("REP"))&DIR0C>1!(DIR0C>$LENGTH(DIR0A))
IF $SELECT(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)>DX
IF '$DATA(DIR0KD)
Begin DoDot:1
+1 DO PREAD^DIR01($SELECT(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)-DX,.DIR0ST,.DIR0CH)
+2 if '$LENGTH(DIR0ST)
QUIT
+3 IF '$GET(DIR0("REP"))
SET DIR0A=DIR0A_DIR0ST
+4 IF '$TEST
SET $EXTRACT(DIR0A,DIR0C,DIR0C+$LENGTH(DIR0ST)-1)=DIR0ST
+5 SET DX=DX+$LENGTH(DIR0ST)
SET DIR0C=DIR0C+$LENGTH(DIR0ST)
End DoDot:1
+6 IF '$TEST
DO READ^DIR01(.DIR0CH)
+7 if DIR0CH=""
QUIT
+8 ;
+9 IF "?^"[DIR0CH
IF DIR0C=1
IF 'DIR0QU
Begin DoDot:1
+10 DO DEOF
XECUTE IOXY
+11 SET DIR0A=""
SET DIR0QU=1
DO REP
End DoDot:1
QUIT
+12 DO @$SELECT($LENGTH(DIR0CH)>1:DIR0CH,$GET(DIR0("REP")):"REP",1:"INS")
+13 IF DIR0QU
IF "?^"'[$EXTRACT(DIR0A)!'$LENGTH(DIR0A)
SET DIR0QU=0
SET DIR0A=""
DO CLR
+14 QUIT
+15 ;
REP IF DIR0C>DIR0M
WRITE $CHAR(7)
QUIT
+1 SET DIR0CHG=1
+2 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_DIR0CH_$EXTRACT(DIR0A,DIR0C+1,999)
+3 SET DIR0C=DIR0C+1
+4 WRITE DIR0CH
+5 IF DX<DIR0F
SET DX=DX+1
QUIT
+6 SET DIR0LN=DIR0LN+1
SET DY=DY+1
SET DX=DIR0S
QUIT
+7 QUIT
+8 ;
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)
+3 WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0F-DX)
+4 Begin DoDot:1
+5 NEW DIR0LN,DY,DX
+6 SET DX=DIR0S
+7 FOR DIR0LN=DIR0C-1\DIR0L+2:1:$LENGTH(DIR0A)\DIR0L+1
Begin DoDot:2
+8 SET DY=DIR0R+DIR0LN-1
XECUTE IOXY
+9 WRITE $EXTRACT(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
End DoDot:2
End DoDot:1
+10 SET DIR0C=DIR0C+1
+11 IF DX<DIR0F
SET DX=DX+1
QUIT
+12 SET DIR0LN=DIR0LN+1
SET DY=DY+1
SET DX=DIR0S
+13 QUIT
+14 ;
RIGHT if DIR0C>$LENGTH(DIR0A)
QUIT
+1 SET DIR0C=DIR0C+1
+2 IF DX<DIR0F!(DIR0LN=DIR0NL)
SET DX=DX+1
QUIT
+3 SET DIR0LN=DIR0LN+1
SET DY=DY+1
SET DX=DIR0S
+4 QUIT
+5 ;
LEFT if DIR0C'>1
QUIT
+1 SET DIR0C=DIR0C-1
+2 IF DX>DIR0S
SET DX=DX-1
QUIT
+3 SET DIR0LN=DIR0LN-1
SET DY=DY-1
SET DX=DIR0F
+4 QUIT
+5 ;
JRT if DIR0C>$LENGTH(DIR0A)
QUIT
+1 if DX=DIR0F
QUIT
+2 SET DIR0C=DIR0LN*DIR0L
if DIR0C>$LENGTH(DIR0A)
SET DIR0C=$LENGTH(DIR0A)+1
+3 SET DX=DIR0C#DIR0L-1+DIR0S
if DX<DIR0S
SET DX=DIR0F
+4 QUIT
+5 ;
JLT if DIR0C'>1
QUIT
+1 if DX=DIR0S
QUIT
+2 SET DIR0C=DIR0C-DX+DIR0S
SET DX=DIR0S
+3 QUIT
+4 ;
UP if DIR0LN=1
QUIT
+1 SET DIR0C=DIR0C-DIR0L
SET DIR0LN=DIR0LN-1
SET DY=DY-1
+2 QUIT
+3 ;
DOWN if DIR0LN=DIR0NL
QUIT
+1 if $LENGTH(DIR0A)\DIR0L<DIR0LN
QUIT
+2 SET DIR0C=DIR0C+DIR0L
SET DIR0LN=DIR0LN+1
SET DY=DY+1
+3 if DIR0C>($LENGTH(DIR0A)+1)
SET DIR0C=$LENGTH(DIR0A)+1
SET DX=DIR0C#DIR0L+DIR0S-1
+4 QUIT
+5 ;
FDE ;
NP if DIR0C>$LENGTH(DIR0A)
QUIT
+1 SET DIR0C=$LENGTH(DIR0A)+1
SET DIR0LN=DIR0C-1\DIR0L+1
SET DX=DIR0C-1#DIR0L+DIR0S
+2 if DIR0LN>DIR0NL
SET DIR0LN=DIR0NL
SET DX=DIR0S+DIR0NC
+3 SET DY=DIR0R+DIR0LN-1
+4 QUIT
+5 ;
FDB ;
PP if DIR0C'>1
QUIT
+1 SET DIR0LN=1
SET DY=DIR0R
SET DX=DIR0S
SET DIR0C=1
+2 QUIT
+3 ;
BS if DIR0C'>1
QUIT
+1 SET DIR0CHG=1
+2 SET DX=DX-1
SET DIR0C=DIR0C-1
+3 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_$EXTRACT(DIR0A,DIR0C+1,999)_" "
+4 IF DX<DIR0S
SET DIR0LN=DIR0LN-1
SET DY=DY-1
SET DX=DIR0F
+5 XECUTE IOXY
WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0F-DX)
+6 Begin DoDot:1
+7 NEW DIR0LN,DY,DX
+8 SET DX=DIR0S
+9 FOR DIR0LN=DIR0C-1\DIR0L+2:1:$LENGTH(DIR0A)\DIR0L+1
Begin DoDot:2
+10 SET DY=DIR0R+DIR0LN-1
XECUTE IOXY
+11 WRITE $EXTRACT(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
End DoDot:2
End DoDot:1
+12 SET DIR0A=$EXTRACT(DIR0A,1,$LENGTH(DIR0A)-1)
+13 QUIT
+14 ;
DEL if DIR0C>$LENGTH(DIR0A)
QUIT
+1 SET DIR0CHG=1
+2 SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)_$EXTRACT(DIR0A,DIR0C+1,999)_" "
+3 WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0F-DX)
+4 Begin DoDot:1
+5 NEW DIR0LN,DY,DX
+6 SET DX=DIR0S
+7 FOR DIR0LN=DIR0C-1\DIR0L+2:1:$LENGTH(DIR0A)\DIR0L+1
Begin DoDot:2
+8 SET DY=DIR0R+DIR0LN-1
XECUTE IOXY
+9 WRITE $EXTRACT(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
End DoDot:2
End DoDot:1
+10 SET DIR0A=$EXTRACT(DIR0A,1,$LENGTH(DIR0A)-1)
+11 QUIT
+12 ;
CLR NEW %X
+1 SET DIR0CHG=1
+2 SET %X=DIR0A
+3 IF DIR0A]""
IF DIR0A'=DIR0D
SET DIR0SV=DIR0A
+4 SET DIR0A=$SELECT(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
+5 SET %X=DIR0A_$JUSTIFY("",$LENGTH(%X)-$LENGTH(DIR0A))
+6 SET DX=DIR0S
+7 FOR DIR0LN=1:1:$LENGTH(%X)\DIR0L+1
Begin DoDot:1
+8 SET DY=DIR0R+DIR0LN-1
XECUTE IOXY
+9 WRITE $EXTRACT(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
End DoDot:1
+10 SET (DIR0C,DIR0LN)=1
SET DY=DIR0R
+11 QUIT
+12 ;
DEOF NEW %X
+1 if DIR0C>$LENGTH(DIR0A)
QUIT
+2 SET DIR0CHG=1
+3 SET %X=DIR0A
SET DIR0A=$EXTRACT(DIR0A,1,DIR0C-1)
SET %X=DIR0A_$JUSTIFY("",$LENGTH(%X)-$LENGTH(DIR0A))
+4 WRITE $EXTRACT(%X,DIR0C,DIR0C+DIR0F-DX)
+5 Begin DoDot:1
+6 NEW DIR0LN,DY,DX
+7 SET DX=DIR0S
+8 FOR DIR0LN=DIR0C-1\DIR0L+2:1:$LENGTH(%X)\DIR0L+1
Begin DoDot:2
+9 SET DY=DIR0R+DIR0LN-1
XECUTE IOXY
+10 WRITE $EXTRACT(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
RPM NEW DX,DY
+1 IF $DATA(DDS)
SET DX=IOM-8
SET DY=IOSL-1
XECUTE IOXY
+2 IF $GET(DIR0("REP"))
WRITE "Insert "
KILL DIR0("REP")
+3 IF '$TEST
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 WRT2^DIR0W
WLT ;
FDL GOTO WLT2^DIR0W
DLW GOTO DLW2^DIR0W
+1 ;
HLP ;
NB ;
SEL ;
SV ;
RF ;
NOP WRITE $CHAR(7)
+1 QUIT
TO IF $DATA(DIR0TO)#2
DO @DIR0TO
QUIT
+1 SET DTOUT=1
ZM ;
QT ;
EX ;
CL ;
TAB ;
CR SET DIR0DN=1
+1 QUIT
+2 ;
MOUSEDN NEW %
READ *%,*%
+1 QUIT
MOUSE GOTO MOUSE^DIR01
