DDW4 ;SFISC/PD KELTZ-OTHER NAVIGATION, DEL ;2:54 PM 23 Aug 2000
;;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.
;
TAB N DDWX
S DDWX=$F(DDWRUL,"T",DDWC+1) G:'DDWX ERR
D POS(DDWRW,DDWX-1,"R")
Q
;
DEOL S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
W $P(DDGLCLR,DDGLDEL)
Q
;
DELW N DDWI,DDWW
I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
I DDWC>$L(DDWN) D Q
. I DDWN?." " D
.. D XLINE^DDW5()
. E D
.. N DDWY,DDWX
.. S DDWY=DDWRW+DDWA,DDWX=DDWC
.. D JOIN^DDW6
.. D POS(DDWY-DDWA,DDWX,"RN")
;
S DDWI=$$WRPOS(DDWN)
S DDWW=$E(DDWN,DDWC,DDWI-1)
S $E(DDWN,DDWC,DDWI-1)="",DDWL(DDWRW)=DDWN
I $P(DDGLED,DDGLDEL,6)]"" D
. F DDWI=1:1:$L(DDWW) W $P(DDGLED,DDGLDEL,6)
. S DDWI=$E(DDWN,IOM-$L(DDWW)+1+DDWOFS,IOM+DDWOFS)
. I DDWI]"" D CUP(DDWRW,IOM-$L(DDWW)+1) W DDWI D CUP(DDWRW,DDWC-DDWOFS)
E D
. W $E(DDWN_$J("",$L(DDWW)),DDWC,IOM+DDWOFS)
. D CUP(DDWRW,DDWC-DDWOFS)
Q
;
WORDR N DDWI
S DDWI=$$WRPOS(DDWN)
D POS(DDWRW,DDWI,"R")
Q
;
WRPOS(DDWT) ;
N DDWP,DDWS
S DDWT=$$PUNC(DDWT)
S DDWS=$F(DDWT," ",DDWC+1),DDWP=$F(DDWT,"!",DDWC+1)
S:'DDWS DDWS=999 S:'DDWP DDWP=999
;
I DDWC>$L(DDWT) D
. I DDWRW+DDWA'<DDWCNT S DDWI=$L(DDWT)+1
. E D DN^DDWT1 S DDWI=1
E I DDWS=999,DDWP=999 D
. S DDWI=$L(DDWT)+1
E I $E(DDWT,DDWC)="!" D
. F DDWI=DDWC+1:1 Q:$E(DDWT,DDWI)'="!"
. F DDWI=DDWI:1 Q:$E(DDWT,DDWI)'=" "
E I DDWS<DDWP D
. F DDWI=DDWS:1 Q:$E(DDWT,DDWI)'=" "
E S DDWI=DDWP-1
Q DDWI
;
WORDL N DDWD,DDWI,DDWT
S DDWT=$$PUNC(DDWN)
;
I DDWC=1 D
. I DDWRW=1,'DDWA S DDWI=1
. E D UP^DDWT1 S DDWI=$L(DDWN)+1
E D
. S DDWI=DDWC-1
. S:$E(DDWT,DDWI)="" DDWI=$L(DDWT)
. I $E(DDWT,DDWI)=" " F DDWI=DDWI-1:-1:0 Q:$E(DDWT,DDWI)'=" "
. I $E(DDWT,DDWI)="!" D
.. F DDWI=DDWI-1:-1:0 Q:$E(DDWT,DDWI)'="!"
. E I DDWI D
.. F DDWI=DDWI-1:-1:0 Q:" !"[$E(DDWT,DDWI)
. S DDWI=DDWI+1
D POS(DDWRW,DDWI,"R")
Q
;
PGDN N DDWX
I DDWRW<DDWMR D
. D POS($$MIN(DDWCNT-DDWA,DDWMR),DDWC,"RN")
E D
. S DDWX=$$MIN(DDWSTB,DDWMR)
. D:DDWX MVFWD^DDW3(DDWX)
Q
;
PGUP N DDWX
I DDWRW>1 D
. D POS(1,DDWC,"RN")
E D
. S DDWX=$$MIN(DDWA,DDWMR)
. D:DDWX MVBCK^DDW3(DDWX)
Q
;
JLEFT I DDWC=1,'DDWOFS Q
N DDWX
I DDWN?." " S DDWX=1
E F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" "
I DDWC-DDWOFS=1,DDWC>1 D POS(DDWRW,DDWC-1,"R") Q:DDWC=DDWX
S DDWC=$$MAX($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:0),1+DDWOFS)
D POS(DDWRW,DDWC,"R")
Q
JRIGHT N DDWX
S DDWX=$L(DDWN)+1
I DDWC-DDWOFS=IOM,DDWC<246 D POS(DDWRW,DDWC+1,"R") Q:DDWC=DDWX
S DDWC=$$MIN($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:999),$$MIN(IOM+DDWOFS,246))
D POS(DDWRW,DDWC,"R")
Q
;
LBEG N DDWX
I DDWN?." " D POS(DDWRW,1,"R") Q
I $E(DDWN,1,DDWC-1)?." ",$E(DDWN,DDWC)'=" " D POS(DDWRW,1,"R") Q
F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" "
D POS(DDWRW,DDWX,"R")
Q
LEND D POS(DDWRW,"E","R")
Q
;
ERR ;Beep
W $C(7)
Q
;
CUP(Y,X) ;Cursor positioning
S DY=IOTM+Y-2,DX=X-1 X IOXY
Q
;
POS(R,C,F) ;Pos cursor based on char pos C
N DDWX
S:$G(C)="E" C=$L($G(DDWL(R)))+1
S:$G(F)["N" DDWN=$G(DDWL(R))
S:$G(F)["R" DDWRW=R,DDWC=C
;
S DDWX=C-DDWOFS
I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
Q
;
SCR(C) ;Screen #
Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
MAX(X,Y) ;
Q $S(X>Y:X,1:Y)
PUNC(X) ;
Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!"))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW4 3714 printed Apr 09, 2024@21:47:59 Page 2
DDW4 ;SFISC/PD KELTZ-OTHER NAVIGATION, DEL ;2:54 PM 23 Aug 2000
+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 ;
TAB NEW DDWX
+1 SET DDWX=$FIND(DDWRUL,"T",DDWC+1)
if 'DDWX
GOTO ERR
+2 DO POS(DDWRW,DDWX-1,"R")
+3 QUIT
+4 ;
DEOL SET (DDWN,DDWL(DDWRW))=$EXTRACT(DDWN,1,DDWC-1)
+1 WRITE $PIECE(DDGLCLR,DDGLDEL)
+2 QUIT
+3 ;
DELW NEW DDWI,DDWW
+1 IF $DATA(DDWMARK)
IF DDWRW+DDWA'>$PIECE(DDWMARK,U,3)
DO UNMARK^DDW7
+2 IF DDWC>$LENGTH(DDWN)
Begin DoDot:1
+3 IF DDWN?." "
Begin DoDot:2
+4 DO XLINE^DDW5()
End DoDot:2
+5 IF '$TEST
Begin DoDot:2
+6 NEW DDWY,DDWX
+7 SET DDWY=DDWRW+DDWA
SET DDWX=DDWC
+8 DO JOIN^DDW6
+9 DO POS(DDWY-DDWA,DDWX,"RN")
End DoDot:2
End DoDot:1
QUIT
+10 ;
+11 SET DDWI=$$WRPOS(DDWN)
+12 SET DDWW=$EXTRACT(DDWN,DDWC,DDWI-1)
+13 SET $EXTRACT(DDWN,DDWC,DDWI-1)=""
SET DDWL(DDWRW)=DDWN
+14 IF $PIECE(DDGLED,DDGLDEL,6)]""
Begin DoDot:1
+15 FOR DDWI=1:1:$LENGTH(DDWW)
WRITE $PIECE(DDGLED,DDGLDEL,6)
+16 SET DDWI=$EXTRACT(DDWN,IOM-$LENGTH(DDWW)+1+DDWOFS,IOM+DDWOFS)
+17 IF DDWI]""
DO CUP(DDWRW,IOM-$LENGTH(DDWW)+1)
WRITE DDWI
DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 WRITE $EXTRACT(DDWN_$JUSTIFY("",$LENGTH(DDWW)),DDWC,IOM+DDWOFS)
+20 DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:1
+21 QUIT
+22 ;
WORDR NEW DDWI
+1 SET DDWI=$$WRPOS(DDWN)
+2 DO POS(DDWRW,DDWI,"R")
+3 QUIT
+4 ;
WRPOS(DDWT) ;
+1 NEW DDWP,DDWS
+2 SET DDWT=$$PUNC(DDWT)
+3 SET DDWS=$FIND(DDWT," ",DDWC+1)
SET DDWP=$FIND(DDWT,"!",DDWC+1)
+4 if 'DDWS
SET DDWS=999
if 'DDWP
SET DDWP=999
+5 ;
+6 IF DDWC>$LENGTH(DDWT)
Begin DoDot:1
+7 IF DDWRW+DDWA'<DDWCNT
SET DDWI=$LENGTH(DDWT)+1
+8 IF '$TEST
DO DN^DDWT1
SET DDWI=1
End DoDot:1
+9 IF '$TEST
IF DDWS=999
IF DDWP=999
Begin DoDot:1
+10 SET DDWI=$LENGTH(DDWT)+1
End DoDot:1
+11 IF '$TEST
IF $EXTRACT(DDWT,DDWC)="!"
Begin DoDot:1
+12 FOR DDWI=DDWC+1:1
if $EXTRACT(DDWT,DDWI)'="!"
QUIT
+13 FOR DDWI=DDWI:1
if $EXTRACT(DDWT,DDWI)'=" "
QUIT
End DoDot:1
+14 IF '$TEST
IF DDWS<DDWP
Begin DoDot:1
+15 FOR DDWI=DDWS:1
if $EXTRACT(DDWT,DDWI)'=" "
QUIT
End DoDot:1
+16 IF '$TEST
SET DDWI=DDWP-1
+17 QUIT DDWI
+18 ;
WORDL NEW DDWD,DDWI,DDWT
+1 SET DDWT=$$PUNC(DDWN)
+2 ;
+3 IF DDWC=1
Begin DoDot:1
+4 IF DDWRW=1
IF 'DDWA
SET DDWI=1
+5 IF '$TEST
DO UP^DDWT1
SET DDWI=$LENGTH(DDWN)+1
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET DDWI=DDWC-1
+8 if $EXTRACT(DDWT,DDWI)=""
SET DDWI=$LENGTH(DDWT)
+9 IF $EXTRACT(DDWT,DDWI)=" "
FOR DDWI=DDWI-1:-1:0
if $EXTRACT(DDWT,DDWI)'=" "
QUIT
+10 IF $EXTRACT(DDWT,DDWI)="!"
Begin DoDot:2
+11 FOR DDWI=DDWI-1:-1:0
if $EXTRACT(DDWT,DDWI)'="!"
QUIT
End DoDot:2
+12 IF '$TEST
IF DDWI
Begin DoDot:2
+13 FOR DDWI=DDWI-1:-1:0
if " !"[$EXTRACT(DDWT,DDWI)
QUIT
End DoDot:2
+14 SET DDWI=DDWI+1
End DoDot:1
+15 DO POS(DDWRW,DDWI,"R")
+16 QUIT
+17 ;
PGDN NEW DDWX
+1 IF DDWRW<DDWMR
Begin DoDot:1
+2 DO POS($$MIN(DDWCNT-DDWA,DDWMR),DDWC,"RN")
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET DDWX=$$MIN(DDWSTB,DDWMR)
+5 if DDWX
DO MVFWD^DDW3(DDWX)
End DoDot:1
+6 QUIT
+7 ;
PGUP NEW DDWX
+1 IF DDWRW>1
Begin DoDot:1
+2 DO POS(1,DDWC,"RN")
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET DDWX=$$MIN(DDWA,DDWMR)
+5 if DDWX
DO MVBCK^DDW3(DDWX)
End DoDot:1
+6 QUIT
+7 ;
JLEFT IF DDWC=1
IF 'DDWOFS
QUIT
+1 NEW DDWX
+2 IF DDWN?." "
SET DDWX=1
+3 IF '$TEST
FOR DDWX=1:1:$LENGTH(DDWN)
if $EXTRACT(DDWN,DDWX)'=" "
QUIT
+4 IF DDWC-DDWOFS=1
IF DDWC>1
DO POS(DDWRW,DDWC-1,"R")
if DDWC=DDWX
QUIT
+5 SET DDWC=$$MAX($SELECT($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:0),1+DDWOFS)
+6 DO POS(DDWRW,DDWC,"R")
+7 QUIT
JRIGHT NEW DDWX
+1 SET DDWX=$LENGTH(DDWN)+1
+2 IF DDWC-DDWOFS=IOM
IF DDWC<246
DO POS(DDWRW,DDWC+1,"R")
if DDWC=DDWX
QUIT
+3 SET DDWC=$$MIN($SELECT($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:999),$$MIN(IOM+DDWOFS,246))
+4 DO POS(DDWRW,DDWC,"R")
+5 QUIT
+6 ;
LBEG NEW DDWX
+1 IF DDWN?." "
DO POS(DDWRW,1,"R")
QUIT
+2 IF $EXTRACT(DDWN,1,DDWC-1)?." "
IF $EXTRACT(DDWN,DDWC)'=" "
DO POS(DDWRW,1,"R")
QUIT
+3 FOR DDWX=1:1:$LENGTH(DDWN)
if $EXTRACT(DDWN,DDWX)'=" "
QUIT
+4 DO POS(DDWRW,DDWX,"R")
+5 QUIT
LEND DO POS(DDWRW,"E","R")
+1 QUIT
+2 ;
ERR ;Beep
+1 WRITE $CHAR(7)
+2 QUIT
+3 ;
CUP(Y,X) ;Cursor positioning
+1 SET DY=IOTM+Y-2
SET DX=X-1
XECUTE IOXY
+2 QUIT
+3 ;
POS(R,C,F) ;Pos cursor based on char pos C
+1 NEW DDWX
+2 if $GET(C)="E"
SET C=$LENGTH($GET(DDWL(R)))+1
+3 if $GET(F)["N"
SET DDWN=$GET(DDWL(R))
+4 if $GET(F)["R"
SET DDWRW=R
SET DDWC=C
+5 ;
+6 SET DDWX=C-DDWOFS
+7 IF DDWX>IOM!(DDWX<1)
DO SHIFT^DDW3(C,.DDWOFS)
+8 SET DY=IOTM+R-2
SET DX=C-DDWOFS-1
XECUTE IOXY
+9 QUIT
+10 ;
SCR(C) ;Screen #
+1 QUIT C-$PIECE(DDWOFS,U,2)-1\$PIECE(DDWOFS,U,3)+1
+2 ;
MIN(X,Y) ;
+1 QUIT $SELECT(X<Y:X,1:Y)
MAX(X,Y) ;
+1 QUIT $SELECT(X>Y:X,1:Y)
PUNC(X) ;
+1 QUIT $TRANSLATE(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TRANSLATE($JUSTIFY("",32)," ","!"))
