DIR0W ;SFISC/MKO-WORD FUNCTIONS FOR FIELD EDITOR ;09:45 AM 12 Dec 1994
;;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.
;
WRT N DIR0I
Q:DIR0C>$L(DIR0A)
S DIR0I=$$WRPOS(DIR0A)
;
I DIR0C-DX+DIR0S+DIR0L>DIR0I S DX=DX+DIR0I-DIR0C,DIR0C=DIR0I Q
S DIR0C=DIR0I,DX=DIR0S X IOXY
I $L(DIR0A)-DIR0L<DIR0C D
. W $E(DIR0A,$L(DIR0A)-DIR0L+1,$L(DIR0A))
. S DX=DIR0S+DIR0C-$L(DIR0A)+DIR0L-1
E W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
Q
;
WLT N DIR0D,DIR0I,DIR0T
Q:DIR0C=1
S DIR0T=$$PUNC(DIR0A)
;
S DIR0I=DIR0C-1
I $E(DIR0T,DIR0I)=" " F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'=" "
I $E(DIR0T,DIR0I)="!" D
. F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'="!"
E I DIR0I D
. F DIR0I=DIR0I-1:-1:0 Q:" !"[$E(DIR0T,DIR0I)
S DIR0I=DIR0I+1
;
I DIR0C-DX+DIR0S'>DIR0I S DX=DX-DIR0C+DIR0I,DIR0C=DIR0I Q
S DIR0C=DIR0I,DX=DIR0S X IOXY
I DIR0L'<DIR0C W $E(DIR0A,1,DIR0L) S DX=DIR0S+DIR0C-1 Q
S DX=DIR0L*2\3+DIR0S W $E(DIR0A,DIR0C-DX+DIR0S,DIR0C+DIR0F-DX-1)
Q
;
DLW N DIR0I,DIR0X
Q:DIR0C>$L(DIR0A)
S DIR0CHG=1
;
S DIR0I=$$WRPOS(DIR0A)
S $E(DIR0A,DIR0C,DIR0I-1)=""
;
S DIR0X=DIR0L\3+DIR0S
I DX>DIR0X,$L($E(DIR0A,DIR0C,$L(DIR0A)))+DIR0X>DIR0F D
. S DX=DIR0S X IOXY
. W $E(DIR0A,DIR0C-DIR0X+DIR0S,DIR0C+DIR0F-DIR0X-1)
. S DX=DIR0X
E D
. S DIR0X=$E(DIR0A,DIR0C,DIR0C+DIR0F-DX-1)
. S DIR0X=DIR0X_$J("",DIR0F-DX-$L(DIR0X))
. W DIR0X
Q
;
WRT2 Q:DIR0C>$L(DIR0A)
S DIR0C=$$WRPOS(DIR0A)
;
I DIR0C>$L(DIR0A) S DIR0C=0 D FDE^DIR03 Q
S DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
S DY=DIR0R+DIR0LN-1
Q
;
WLT2 N DIR0D,DIR0I,DIR0T
Q:DIR0C=1
S DIR0T=$$PUNC(DIR0A)
;
S DIR0I=DIR0C-1
I $E(DIR0T,DIR0I)=" " F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'=" "
I $E(DIR0T,DIR0I)="!" D
. F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'="!"
E I DIR0I D
. F DIR0I=DIR0I-1:-1:0 Q:" !"[$E(DIR0T,DIR0I)
S DIR0I=DIR0I+1
;
I DIR0I=1 D FDB^DIR03 Q
S DIR0C=DIR0I,DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
S DY=DIR0R+DIR0LN-1
Q
;
DLW2 N DIR0I,DIR0X
Q:DIR0C>$L(DIR0A)
S DIR0CHG=1
;
S DIR0I=$$WRPOS(DIR0A)
S $E(DIR0A,DIR0C,DIR0I-1)=""
;
S DIR0X=DIR0A_$J("",DIR0I-DIR0C)
W $E(DIR0X,DIR0C,DIR0C+DIR0F-DX)
D
. N DY,DX
. S DX=DIR0S
. F DIR0I=DIR0C\DIR0L+2:1:$L(DIR0X)\DIR0L+1 D
.. S DY=DIR0R+DIR0I-1 X IOXY
.. W $E(DIR0X,DIR0I-1*DIR0L+1,DIR0I*DIR0L)
Q
;
WRPOS(DIR0T) ;
N DIR0I,DIR0P,DIR0S
S DIR0T=$$PUNC(DIR0T)
S DIR0S=$F(DIR0T," ",DIR0C+1),DIR0P=$F(DIR0T,"!",DIR0C+1)
S:'DIR0S DIR0S=999 S:'DIR0P DIR0P=999
;
I DIR0S=999,DIR0P=999 D
. S DIR0I=$L(DIR0T)+1
E I $E(DIR0T,DIR0C)="!" D
. F DIR0I=DIR0C+1:1 Q:$E(DIR0T,DIR0I)'="!"
. F DIR0I=DIR0I:1 Q:$E(DIR0T,DIR0I)'=" "
E I DIR0S<DIR0P D
. F DIR0I=DIR0S:1 Q:$E(DIR0T,DIR0I)'=" "
E S DIR0I=DIR0P-1
Q DIR0I
;
PUNC(X) ;
Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!"))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIR0W 3204 printed Oct 16, 2024@18:54:24 Page 2
DIR0W ;SFISC/MKO-WORD FUNCTIONS FOR FIELD EDITOR ;09:45 AM 12 Dec 1994
+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 ;
WRT NEW DIR0I
+1 if DIR0C>$LENGTH(DIR0A)
QUIT
+2 SET DIR0I=$$WRPOS(DIR0A)
+3 ;
+4 IF DIR0C-DX+DIR0S+DIR0L>DIR0I
SET DX=DX+DIR0I-DIR0C
SET DIR0C=DIR0I
QUIT
+5 SET DIR0C=DIR0I
SET DX=DIR0S
XECUTE IOXY
+6 IF $LENGTH(DIR0A)-DIR0L<DIR0C
Begin DoDot:1
+7 WRITE $EXTRACT(DIR0A,$LENGTH(DIR0A)-DIR0L+1,$LENGTH(DIR0A))
+8 SET DX=DIR0S+DIR0C-$LENGTH(DIR0A)+DIR0L-1
End DoDot:1
+9 IF '$TEST
WRITE $EXTRACT(DIR0A,DIR0C,DIR0C+DIR0L-1)
+10 QUIT
+11 ;
WLT NEW DIR0D,DIR0I,DIR0T
+1 if DIR0C=1
QUIT
+2 SET DIR0T=$$PUNC(DIR0A)
+3 ;
+4 SET DIR0I=DIR0C-1
+5 IF $EXTRACT(DIR0T,DIR0I)=" "
FOR DIR0I=DIR0I-1:-1:0
if $EXTRACT(DIR0T,DIR0I)'=" "
QUIT
+6 IF $EXTRACT(DIR0T,DIR0I)="!"
Begin DoDot:1
+7 FOR DIR0I=DIR0I-1:-1:0
if $EXTRACT(DIR0T,DIR0I)'="!"
QUIT
End DoDot:1
+8 IF '$TEST
IF DIR0I
Begin DoDot:1
+9 FOR DIR0I=DIR0I-1:-1:0
if " !"[$EXTRACT(DIR0T,DIR0I)
QUIT
End DoDot:1
+10 SET DIR0I=DIR0I+1
+11 ;
+12 IF DIR0C-DX+DIR0S'>DIR0I
SET DX=DX-DIR0C+DIR0I
SET DIR0C=DIR0I
QUIT
+13 SET DIR0C=DIR0I
SET DX=DIR0S
XECUTE IOXY
+14 IF DIR0L'<DIR0C
WRITE $EXTRACT(DIR0A,1,DIR0L)
SET DX=DIR0S+DIR0C-1
QUIT
+15 SET DX=DIR0L*2\3+DIR0S
WRITE $EXTRACT(DIR0A,DIR0C-DX+DIR0S,DIR0C+DIR0F-DX-1)
+16 QUIT
+17 ;
DLW NEW DIR0I,DIR0X
+1 if DIR0C>$LENGTH(DIR0A)
QUIT
+2 SET DIR0CHG=1
+3 ;
+4 SET DIR0I=$$WRPOS(DIR0A)
+5 SET $EXTRACT(DIR0A,DIR0C,DIR0I-1)=""
+6 ;
+7 SET DIR0X=DIR0L\3+DIR0S
+8 IF DX>DIR0X
IF $LENGTH($EXTRACT(DIR0A,DIR0C,$LENGTH(DIR0A)))+DIR0X>DIR0F
Begin DoDot:1
+9 SET DX=DIR0S
XECUTE IOXY
+10 WRITE $EXTRACT(DIR0A,DIR0C-DIR0X+DIR0S,DIR0C+DIR0F-DIR0X-1)
+11 SET DX=DIR0X
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET DIR0X=$EXTRACT(DIR0A,DIR0C,DIR0C+DIR0F-DX-1)
+14 SET DIR0X=DIR0X_$JUSTIFY("",DIR0F-DX-$LENGTH(DIR0X))
+15 WRITE DIR0X
End DoDot:1
+16 QUIT
+17 ;
WRT2 if DIR0C>$LENGTH(DIR0A)
QUIT
+1 SET DIR0C=$$WRPOS(DIR0A)
+2 ;
+3 IF DIR0C>$LENGTH(DIR0A)
SET DIR0C=0
DO FDE^DIR03
QUIT
+4 SET DIR0LN=DIR0C-1\DIR0L+1
SET DX=DIR0C-1#DIR0L+DIR0S
+5 if DIR0LN>DIR0NL
SET DIR0LN=DIR0NL
SET DX=DIR0S+DIR0NC
+6 SET DY=DIR0R+DIR0LN-1
+7 QUIT
+8 ;
WLT2 NEW DIR0D,DIR0I,DIR0T
+1 if DIR0C=1
QUIT
+2 SET DIR0T=$$PUNC(DIR0A)
+3 ;
+4 SET DIR0I=DIR0C-1
+5 IF $EXTRACT(DIR0T,DIR0I)=" "
FOR DIR0I=DIR0I-1:-1:0
if $EXTRACT(DIR0T,DIR0I)'=" "
QUIT
+6 IF $EXTRACT(DIR0T,DIR0I)="!"
Begin DoDot:1
+7 FOR DIR0I=DIR0I-1:-1:0
if $EXTRACT(DIR0T,DIR0I)'="!"
QUIT
End DoDot:1
+8 IF '$TEST
IF DIR0I
Begin DoDot:1
+9 FOR DIR0I=DIR0I-1:-1:0
if " !"[$EXTRACT(DIR0T,DIR0I)
QUIT
End DoDot:1
+10 SET DIR0I=DIR0I+1
+11 ;
+12 IF DIR0I=1
DO FDB^DIR03
QUIT
+13 SET DIR0C=DIR0I
SET DIR0LN=DIR0C-1\DIR0L+1
SET DX=DIR0C-1#DIR0L+DIR0S
+14 if DIR0LN>DIR0NL
SET DIR0LN=DIR0NL
SET DX=DIR0S+DIR0NC
+15 SET DY=DIR0R+DIR0LN-1
+16 QUIT
+17 ;
DLW2 NEW DIR0I,DIR0X
+1 if DIR0C>$LENGTH(DIR0A)
QUIT
+2 SET DIR0CHG=1
+3 ;
+4 SET DIR0I=$$WRPOS(DIR0A)
+5 SET $EXTRACT(DIR0A,DIR0C,DIR0I-1)=""
+6 ;
+7 SET DIR0X=DIR0A_$JUSTIFY("",DIR0I-DIR0C)
+8 WRITE $EXTRACT(DIR0X,DIR0C,DIR0C+DIR0F-DX)
+9 Begin DoDot:1
+10 NEW DY,DX
+11 SET DX=DIR0S
+12 FOR DIR0I=DIR0C\DIR0L+2:1:$LENGTH(DIR0X)\DIR0L+1
Begin DoDot:2
+13 SET DY=DIR0R+DIR0I-1
XECUTE IOXY
+14 WRITE $EXTRACT(DIR0X,DIR0I-1*DIR0L+1,DIR0I*DIR0L)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
WRPOS(DIR0T) ;
+1 NEW DIR0I,DIR0P,DIR0S
+2 SET DIR0T=$$PUNC(DIR0T)
+3 SET DIR0S=$FIND(DIR0T," ",DIR0C+1)
SET DIR0P=$FIND(DIR0T,"!",DIR0C+1)
+4 if 'DIR0S
SET DIR0S=999
if 'DIR0P
SET DIR0P=999
+5 ;
+6 IF DIR0S=999
IF DIR0P=999
Begin DoDot:1
+7 SET DIR0I=$LENGTH(DIR0T)+1
End DoDot:1
+8 IF '$TEST
IF $EXTRACT(DIR0T,DIR0C)="!"
Begin DoDot:1
+9 FOR DIR0I=DIR0C+1:1
if $EXTRACT(DIR0T,DIR0I)'="!"
QUIT
+10 FOR DIR0I=DIR0I:1
if $EXTRACT(DIR0T,DIR0I)'=" "
QUIT
End DoDot:1
+11 IF '$TEST
IF DIR0S<DIR0P
Begin DoDot:1
+12 FOR DIR0I=DIR0S:1
if $EXTRACT(DIR0T,DIR0I)'=" "
QUIT
End DoDot:1
+13 IF '$TEST
SET DIR0I=DIR0P-1
+14 QUIT DIR0I
+15 ;
PUNC(X) ;
+1 QUIT $TRANSLATE(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TRANSLATE($JUSTIFY("",32)," ","!"))
