- 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 Feb 19, 2025@00:20:04 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