DIR0 ;SFISC/MKO-FIELD EDITOR ;11:32 AM 15 Feb 1995
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
SM ;
N DIR0A,DIR0C,DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0L,DIR0M
N DIR0P,DIR0QT,DIR0QU,DIR0R,DIR0RJ,DIR0S,DIR0SP,DIR0ST,DIR0SV,DX,DY
S DIR0P="" D:$D(DIR0("IN"))[0 GETKEY^DIR0K
S:$P(DIR0,U,6) DIR0RJ=1
;
I $G(DDSH) D
. K DDSH
. S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)
. I DDO,'DDM W "COMMAND:"
. S DX=IOM-33 X IOXY W $P(DDGLVID,DDGLDEL,10)_$$EZBLD^DIALOG(8074)
. S DX=IOM-8 X IOXY
. W $P(DDGLVID,DDGLDEL,6)_$P($$EZBLD^DIALOG(7002),U,$G(DIR0("REP"))>0+1)_$P(DDGLVID,DDGLDEL,10)
;
S (DIR0A,DIR0D)=$G(DIR("B"))
S DIR0R=$P(DIR0,U),DIR0S=$P(DIR0,U,2),DIR0L=$P(DIR0,U,3),DIR0M=245
;
W $P(DDGLVID,DDGLDEL,10)
S DY=$P(DIR0,U,4),DX=$P(DIR0,U,5)
I $D(DIR("A"))=11 D
. N DIX
. S DIX="" F S DIX=$O(DIR("A",DIX)) Q:DIX="" D
.. X IOXY W DIR("A",DIX)
.. S DY=DY+1
;
I $D(DIR("A"))#2 D
. X IOXY W DIR("A")
. I DDO,DY=IOSL-1 W $P(DDGLCLR,DDGLDEL)
;
D INIT,^DIR01
;
I $D(DTOUT) W $C(7) S DIR0A=DIR0D
I DIR0A="@",DIR0D'="@" S DIR0A=""
S:DIR0CH="QT" DIR0A=DIR0D
S X=DIR0A
S:X?1"^".E!(X?1"?".E) DIR0A=DIR0D
S DIR0N=X=DIR0D S:DIR0A'=DIR0D DIR0("L")=DIR0A
;
D END,PAINT
X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
Q
;
EN(DIR0R,DIR0S,DIR0L,DIR0NL,DIR0A,DIR0M,DIR0C,DIR0MAP,DIR0FLG,X,Y) ;
;Field editor
N DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0KD,DIR0P,DIR0QT,DIR0QU
N DIR0RJ,DIR0SP,DIR0ST,DIR0SV,DIR0TO,DX,DY
;
D INIT^DDGLIB0()
;
I $D(DIR0MAP)<2 D
. S DIR0P="D"
. D:$D(DIR0("DIN"))[0 GETKEY^DIR0K
E D
. S DIR0P="C"
. I $O(DIR0MAP(""))!($D(DIR0MAP("IN"))[0) D
.. D GETKEY^DIR0K
.. K DIR0MAP S DIR0MAP("IN")=DIR0("CIN"),DIR0MAP("OUT")=DIR0("COUT")
. E D
.. S DIR0("CIN")=$G(DIR0MAP("IN")),DIR0("COUT")=$G(DIR0MAP("OUT"))
.. S:DIR0("CIN")[(U_"KD"_U) DIR0KD=$P(DIR0("COUT"),";",$L($P(DIR0("CIN"),U_"KD"_U),U))
.. S:DIR0("CIN")[(U_"TO"_U) DIR0TO=$P(DIR0("COUT"),";",$L($P(DIR0("CIN"),U_"TO"_U),U))
;
S (DIR0A,DIR0D)=$G(DIR0A)
S:'$G(DIR0R) DIR0R=0
S:'$G(DIR0S) DIR0S=0
S:'$G(DIR0L) DIR0L=IOM-1-DIR0S
S:'$G(DIR0M) DIR0M=245
S:'$G(DIR0FLG)["r" DIR0RJ=1
;
I $G(DIR0NL)>1 D
. D EN^DIR02,END
E D INIT,^DIR01,END,PAINT
;
S X=DIR0A
I $D(DTOUT) K DTOUT S:Y="" Y="TO"
S $P(Y,U,2)=+$G(DIR0CHG)
D KILL^DDGLIB0($G(DIR0FLG))
K DIR0("CIN"),DIR0("COUT")
Q
;
INIT ;
K DTOUT
X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
S DIR0SV=$G(DIR0("L"))
S DIR0C=$S($G(DIR0C)<1:0,1:DIR0C)+1
S:DIR0C-1>$L(DIR0A) DIR0C=$L(DIR0A)+1
S (DIR0QT,DIR0QU)=0,DY=DIR0R,DX=DIR0S,DIR0F=DIR0S+DIR0L
;
X IOXY
S DIR0SP=$J("",DIR0L) S:$G(DDGLVAN) DIR0SP=$TR(DIR0SP," ","_")
I DIR0C-1>DIR0L D
. W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$E(DIR0A,DIR0C-DIR0L,DIR0C-1)
. S DX=DIR0F
E D
. W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
. S DX=DIR0S+DIR0C-1
. X IOXY
Q
;
END ;
S Y=$P("U^D^R^L^N^NB^NP^PP^SEL^EX^QT^CL^SV^RF",U,$L($P("^UP^DOWN^TAB^FDL^CR^NB^NP^PP^SEL^EX^QT^CL^SV^RF^",U_DIR0CH_U),U))
S:Y="" Y=$P($G(DIR0QT),U,2)
N X,Y S DIR0SP=$TR(DIR0SP,"_"," ")
S DIR0C=DIR0C-1
Q
;
PAINT ;
N DIR0X
I $G(DIR0FLG)["P" W $P(DDGLVID,DDGLDEL,10) Q
I '$G(DIR0RJ) S DIR0X=$E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
E S DIR0X=$E(DIR0SP,$L(DIR0A)+1,999)_$E(DIR0A,1,DIR0L)
S DX=DIR0S X IOXY
W $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL)_DIR0X_$P(DDGLVID,DDGLDEL,10)
Q
;
UPDATE(DIR0NA,DIR0NC) ;Update ans/curs pos
N DIR0STR,DIR0X
S:$D(DIR0NA)[0 DIR0NA=DIR0A
S DIR0NC=$S($D(DIR0NC)[0:DIR0C-1,1:DIR0NC)+1
S:DIR0NC<1 DIR0NC=1
S:DIR0NC-1>$L(DIR0NA) DIR0NC=$L(DIR0NA)+1
S DIR0X=DX+DIR0NC-DIR0C
;
I DIR0A=DIR0NA,DIR0X'<DIR0S,DIR0X'>DIR0F D
. S DX=DIR0X X IOXY
E D
. S DIR0X=DIR0NC-DIR0L S:DIR0X<1 DIR0X=1
. S DX=DIR0S X IOXY
. S DIR0STR=$E(DIR0NA,DIR0X,DIR0X+DIR0L-1)
. W DIR0STR_$E(DIR0SP,$L(DIR0STR)+1,999)
. S DX=DIR0S+DIR0NC-DIR0X X IOXY
;
S DIR0A=DIR0NA,DIR0C=DIR0NC
Q
;
KILL ;
D KILL^DDGLIB0()
Q
;
;#8074 Press <PF1>H for help
;#7002 Insert^Replace
DIR0 ;SFISC/MKO-FIELD EDITOR ;11:32 AM 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 ;
SM ;
+1 NEW DIR0A,DIR0C,DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0L,DIR0M
+2 NEW DIR0P,DIR0QT,DIR0QU,DIR0R,DIR0RJ,DIR0S,DIR0SP,DIR0ST,DIR0SV,DX,DY
+3 SET DIR0P=""
IF $DATA(DIR0("IN"))[0
DO GETKEY^DIR0K
+4 IF $PIECE(DIR0,U,6)
SET DIR0RJ=1
+5 ;
+6 IF $GET(DDSH)
Begin DoDot:1
+7 KILL DDSH
+8 SET DY=IOSL-1
SET DX=0
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+9 IF DDO
IF 'DDM
WRITE "COMMAND:"
+10 SET DX=IOM-33
XECUTE IOXY
WRITE $PIECE(DDGLVID,DDGLDEL,10)_$$EZBLD^DIALOG(8074)
+11 SET DX=IOM-8
XECUTE IOXY
+12 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$PIECE($$EZBLD^DIALOG(7002),U,$GET(DIR0("REP"))>0+1)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+13 ;
+14 SET (DIR0A,DIR0D)=$GET(DIR("B"))
+15 SET DIR0R=$PIECE(DIR0,U)
SET DIR0S=$PIECE(DIR0,U,2)
SET DIR0L=$PIECE(DIR0,U,3)
SET DIR0M=245
+16 ;
+17 WRITE $PIECE(DDGLVID,DDGLDEL,10)
+18 SET DY=$PIECE(DIR0,U,4)
SET DX=$PIECE(DIR0,U,5)
+19 IF $DATA(DIR("A"))=11
Begin DoDot:1
+20 NEW DIX
+21 SET DIX=""
FOR
SET DIX=$ORDER(DIR("A",DIX))
IF DIX=""
QUIT
Begin DoDot:2
+22 XECUTE IOXY
WRITE DIR("A",DIX)
+23 SET DY=DY+1
End DoDot:2
End DoDot:1
+24 ;
+25 IF $DATA(DIR("A"))#2
Begin DoDot:1
+26 XECUTE IOXY
WRITE DIR("A")
+27 IF DDO
IF DY=IOSL-1
WRITE $PIECE(DDGLCLR,DDGLDEL)
End DoDot:1
+28 ;
+29 DO INIT
DO ^DIR01
+30 ;
+31 IF $DATA(DTOUT)
WRITE $CHAR(7)
SET DIR0A=DIR0D
+32 IF DIR0A="@"
IF DIR0D'="@"
SET DIR0A=""
+33 IF DIR0CH="QT"
SET DIR0A=DIR0D
+34 SET X=DIR0A
+35 IF X?1"^".E!(X?1"?".E)
SET DIR0A=DIR0D
+36 SET DIR0N=X=DIR0D
IF DIR0A'=DIR0D
SET DIR0("L")=DIR0A
+37 ;
+38 DO END
DO PAINT
+39 XECUTE DDGLZOSF("EON")
XECUTE DDGLZOSF("TRMOFF")
+40 QUIT
+41 ;
EN(DIR0R,DIR0S,DIR0L,DIR0NL,DIR0A,DIR0M,DIR0C,DIR0MAP,DIR0FLG,X,Y) ;
+1 ;Field editor
+2 NEW DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0KD,DIR0P,DIR0QT,DIR0QU
+3 NEW DIR0RJ,DIR0SP,DIR0ST,DIR0SV,DIR0TO,DX,DY
+4 ;
+5 DO INIT^DDGLIB0()
+6 ;
+7 IF $DATA(DIR0MAP)<2
Begin DoDot:1
+8 SET DIR0P="D"
+9 IF $DATA(DIR0("DIN"))[0
DO GETKEY^DIR0K
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET DIR0P="C"
+12 IF $ORDER(DIR0MAP(""))!($DATA(DIR0MAP("IN"))[0)
Begin DoDot:2
+13 DO GETKEY^DIR0K
+14 KILL DIR0MAP
SET DIR0MAP("IN")=DIR0("CIN")
SET DIR0MAP("OUT")=DIR0("COUT")
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 SET DIR0("CIN")=$GET(DIR0MAP("IN"))
SET DIR0("COUT")=$GET(DIR0MAP("OUT"))
+17 IF DIR0("CIN")[(U_"KD"_U)
SET DIR0KD=$PIECE(DIR0("COUT"),";",$LENGTH($PIECE(DIR0("CIN"),U_"KD"_U),U))
+18 IF DIR0("CIN")[(U_"TO"_U)
SET DIR0TO=$PIECE(DIR0("COUT"),";",$LENGTH($PIECE(DIR0("CIN"),U_"TO"_U),U))
End DoDot:2
End DoDot:1
+19 ;
+20 SET (DIR0A,DIR0D)=$GET(DIR0A)
+21 IF '$GET(DIR0R)
SET DIR0R=0
+22 IF '$GET(DIR0S)
SET DIR0S=0
+23 IF '$GET(DIR0L)
SET DIR0L=IOM-1-DIR0S
+24 IF '$GET(DIR0M)
SET DIR0M=245
+25 IF '$GET(DIR0FLG)["r"
SET DIR0RJ=1
+26 ;
+27 IF $GET(DIR0NL)>1
Begin DoDot:1
+28 DO EN^DIR02
DO END
End DoDot:1
+29 IF '$TEST
DO INIT
DO ^DIR01
DO END
DO PAINT
+30 ;
+31 SET X=DIR0A
+32 IF $DATA(DTOUT)
KILL DTOUT
IF Y=""
SET Y="TO"
+33 SET $PIECE(Y,U,2)=+$GET(DIR0CHG)
+34 DO KILL^DDGLIB0($GET(DIR0FLG))
+35 KILL DIR0("CIN"),DIR0("COUT")
+36 QUIT
+37 ;
INIT ;
+1 KILL DTOUT
+2 XECUTE DDGLZOSF("EOFF")
XECUTE DDGLZOSF("TRMON")
+3 SET DIR0SV=$GET(DIR0("L"))
+4 SET DIR0C=$SELECT($GET(DIR0C)<1:0,1:DIR0C)+1
+5 IF DIR0C-1>$LENGTH(DIR0A)
SET DIR0C=$LENGTH(DIR0A)+1
+6 SET (DIR0QT,DIR0QU)=0
SET DY=DIR0R
SET DX=DIR0S
SET DIR0F=DIR0S+DIR0L
+7 ;
+8 XECUTE IOXY
+9 SET DIR0SP=$JUSTIFY("",DIR0L)
IF $GET(DDGLVAN)
SET DIR0SP=$TRANSLATE(DIR0SP," ","_")
+10 IF DIR0C-1>DIR0L
Begin DoDot:1
+11 WRITE $SELECT('$DATA(DDGLVAN):$PIECE(DDGLVID,DDGLDEL,6),1:"")_$EXTRACT(DIR0A,DIR0C-DIR0L,DIR0C-1)
+12 SET DX=DIR0F
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 WRITE $SELECT('$DATA(DDGLVAN):$PIECE(DDGLVID,DDGLDEL,6),1:"")_$EXTRACT(DIR0A,1,DIR0L)_$EXTRACT(DIR0SP,$LENGTH(DIR0A)+1,999)
+15 SET DX=DIR0S+DIR0C-1
+16 XECUTE IOXY
End DoDot:1
+17 QUIT
+18 ;
END ;
+1 SET Y=$PIECE("U^D^R^L^N^NB^NP^PP^SEL^EX^QT^CL^SV^RF",U,$LENGTH($PIECE("^UP^DOWN^TAB^FDL^CR^NB^NP^PP^SEL^EX^QT^CL^SV^RF^",U_DIR0CH_U),U))
+2 IF Y=""
SET Y=$PIECE($GET(DIR0QT),U,2)
+3 NEW X,Y
SET DIR0SP=$TRANSLATE(DIR0SP,"_"," ")
+4 SET DIR0C=DIR0C-1
+5 QUIT
+6 ;
PAINT ;
+1 NEW DIR0X
+2 IF $GET(DIR0FLG)["P"
WRITE $PIECE(DDGLVID,DDGLDEL,10)
QUIT
+3 IF '$GET(DIR0RJ)
SET DIR0X=$EXTRACT(DIR0A,1,DIR0L)_$EXTRACT(DIR0SP,$LENGTH(DIR0A)+1,999)
+4 IF '$TEST
SET DIR0X=$EXTRACT(DIR0SP,$LENGTH(DIR0A)+1,999)_$EXTRACT(DIR0A,1,DIR0L)
+5 SET DX=DIR0S
XECUTE IOXY
+6 WRITE $PIECE(DDGLVID,DDGLDEL,10)_$PIECE(DDGLVID,DDGLDEL)_DIR0X_$PIECE(DDGLVID,DDGLDEL,10)
+7 QUIT
+8 ;
UPDATE(DIR0NA,DIR0NC) ;Update ans/curs pos
+1 NEW DIR0STR,DIR0X
+2 IF $DATA(DIR0NA)[0
SET DIR0NA=DIR0A
+3 SET DIR0NC=$SELECT($DATA(DIR0NC)[0:DIR0C-1,1:DIR0NC)+1
+4 IF DIR0NC<1
SET DIR0NC=1
+5 IF DIR0NC-1>$LENGTH(DIR0NA)
SET DIR0NC=$LENGTH(DIR0NA)+1
+6 SET DIR0X=DX+DIR0NC-DIR0C
+7 ;
+8 IF DIR0A=DIR0NA
IF DIR0X'<DIR0S
IF DIR0X'>DIR0F
Begin DoDot:1
+9 SET DX=DIR0X
XECUTE IOXY
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET DIR0X=DIR0NC-DIR0L
IF DIR0X<1
SET DIR0X=1
+12 SET DX=DIR0S
XECUTE IOXY
+13 SET DIR0STR=$EXTRACT(DIR0NA,DIR0X,DIR0X+DIR0L-1)
+14 WRITE DIR0STR_$EXTRACT(DIR0SP,$LENGTH(DIR0STR)+1,999)
+15 SET DX=DIR0S+DIR0NC-DIR0X
XECUTE IOXY
End DoDot:1
+16 ;
+17 SET DIR0A=DIR0NA
SET DIR0C=DIR0NC
+18 QUIT
+19 ;
KILL ;
+1 DO KILL^DDGLIB0()
+2 QUIT
+3 ;
+4 ;#8074 Press <PF1>H for help
+5 ;#7002 Insert^Replace
