- 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
