DDW5 ;SFISC/PD KELTZ-WRAP, BREAK, ILINE, XLINE ;01:23 PM 21 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.
;
WRAP ;Wrap at word boundary
S:$E(DDWN,DDWC,999)?1." " (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
I DDWC'>$L(DDWN) D WRAPI Q
I 'DDWRAP D POS(DDWRW,DDWRMAR+1,"R"),BREAK(1) Q
D WRAPW
Q
;
WRAPI ;Cursor in middle
I $E(DDWN,DDWLMAR,999)'[" "!'DDWRAP D BREAK(-1),POS(DDWRW-1,"E","RN") Q
N DDWCSV,DDWI,DDWLST,DDWRMSV
S DDWI=$F(DDWN," ",DDWC)
I DDWI,DDWI-2'>DDWRMAR D
. S DDWCSV=DDWC
. S (DDWN,DDWL(DDWRW))=$$TR(DDWN)
. D POS(DDWRW,DDWI,"R"),BREAK(-1),POS(DDWRW-1,DDWCSV,"RN")
. S (DDWN,DDWL(DDWRW))=$$TR(DDWN)
E I DDWC=2 D
. D POS(DDWRW,DDWRMAR+1,"R"),BREAK(-1),POS(DDWRW-1,2,"RN")
E D
. S DDWLST=$$TR($E(DDWN,DDWC,999))
. S (DDWL(DDWRW),DDWN)=$E(DDWN,1,DDWC-1)
. S DDWRMSV=DDWRMAR,DDWRMAR=$$MIN(DDWRMAR,DDWC-2)
. D WRAPW
. W $E(DDWLST,1,IOM+DDWOFS-DDWC)
. S DDWL(DDWRW)=DDWN_DDWLST,DDWRMAR=DDWRMSV
. D POS(DDWRW,DDWC,"RN")
Q
;
WRAPW ;Cursor at end
N DDWI,DDWS1,DDWS2,DDWTXT
S DDWTXT(1)=DDWN
D ADJMAR^DDW6(.DDWTXT,"","I")
;
S DDWS1=$$SCR($L(DDWTXT(1))+1),DDWS2=$$SCR($L(DDWTXT(DDWTXT))+1)
I DDWS1=$P(DDWOFS,U,4),DDWS2=$P(DDWOFS,U,4),DDWTXT=2 D
. S (DDWN,DDWL(DDWRW))=DDWTXT(1)_DDWTXT(2)
. S DDWC=$L(DDWTXT(1))+1
. D POS(DDWRW,DDWC),BREAK(1)
;
E D
. F DDWI=1:1:DDWTXT-1 D
.. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
.. D ILINE
.. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI+1)
.. I DDWS2=$P(DDWOFS,U,4) D
... D CUP(DDWRW-1,1)
... W $P(DDGLCLR,DDGLDEL)_$E(DDWTXT(DDWI),1+DDWOFS,IOM+DDWOFS)
... D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
. D POS(DDWRW,"E","R")
Q
;
BREAK(DDWFLAG) ;Break line, make new line current
;Final cursor position:
; 0:lmar of new line (used by <RET>)
; 1:end of new line (used by Wrap)
;-1:doesn't matter (used by Wrap)
N DDWRST
I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
S DDWRST=$E(DDWN,DDWC,999)
I DDWLMAR>1,DDWRST'?@(DDWLMAR-1_""" "".E") D
. S DDWRST=$J("",DDWLMAR-1)_$$LD(DDWRST)
S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
W $P(DDGLCLR,DDGLDEL)
D ILINE
S (DDWN,DDWL(DDWRW))=DDWRST
;
I $G(DDWFLAG)=1 D
. I $$SCR($L(DDWN)+1)=$P(DDWOFS,U,4) D
.. D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
. D POS(DDWRW,"E","R")
;
E I '$G(DDWFLAG) D
. I $P(DDWOFS,U,4)=1 D CUP(DDWRW,1) W $E(DDWN,1,IOM)
. D POS(DDWRW,DDWLMAR,"R")
;
E D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
Q
;
ILINE ;Insert line below current line, make that current
;Column is unchanged
N DDWI,DDWX
I DDWRW<DDWMR D
. I DDWA+DDWMR'>DDWCNT D
.. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWMR)
. F DDWI=DDWMR:-1:DDWRW+2 S DDWL(DDWI)=DDWL(DDWI-1)
. S DDWL(DDWRW+1)=""
. D CUP(DDWRW+1,1)
. ;
. I $P(DDGLED,DDGLDEL,3)]"" D
.. I $P(DDGLED,DDGLDEL,2)="" D
... D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) D CUP(DDWRW+1,1)
.. W $P(DDGLED,DDGLDEL,3)
. E D
.. S DDWX=IOTM
.. S IOTM=IOTM+DDWRW W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX
.. D CUP(DDWRW+1,1) W $P(DDGLED,DDGLDEL)
.. W @$P(DDGLED,DDGLDEL,2)
. D POS(DDWRW+1,DDWC,"RN")
;
E D
. S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(1)
. F DDWI=1:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1)
. S DDWL(DDWMR)=""
. D SCRUP^DDW3(1)
S DDWCNT=DDWCNT+1
S $E(DDWBF,1,3)=111
Q
;
XLINE(DDWFLAG,DDWNP) ;Delete current line
;DDWFLAG:
; 1:leave cursor on deleted line (used by Join)
; 0:move cursor up one line if deleted line is last line
; (used by PF1-D and DELBLK)
; DDWNP = 1:don't bother printing, used by DELBLK
N DDWI,DDWX
I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
F DDWI=DDWRW:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1)
S DDWX="" S:DDWSTB DDWX=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1
S DDWL(DDWMR)=DDWX
;
D:'$G(DDWNP) XLINEP
;
S DDWCNT=DDWCNT-1
I 'DDWCNT D
. S DDWCNT=1 D POS(1,DDWLMAR,"RN")
E I DDWA+DDWRW>DDWCNT,'$G(DDWFLAG) D
. D UP^DDWT1
E D POS(DDWRW,DDWC,"N")
S $E(DDWBF,1,3)=111
Q
;
XLINEP ;Redisplay screen
I $P(DDGLED,DDGLDEL,4)]"" D
. W $P(DDGLED,DDGLDEL,4)
. I $P(DDGLED,DDGLDEL,2)="" D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3)
E I DDWRW<DDWMR D
. S DDWX=IOTM
. S IOTM=IOTM+DDWRW-1 W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX
. D CUP(DDWMR,1) W $C(10)
. W @$P(DDGLED,DDGLDEL,2)
E D
. D CUP(DDWMR,1) W $P(DDGLCLR,DDGLDEL)
;
I DDWL(DDWMR)'?." " D
. D CUP(DDWMR,1)
. W $E(DDWL(DDWMR),1+DDWOFS,IOM+DDWOFS)
Q
;
TR(X) Q:$G(X)="" X
N I
F I=$L(X):-1:0 Q:$E(X,I)'=" "
Q $E(X,1,I)
;
LD(X) Q:$G(X)="" X
N I
F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
Q $E(X,I,999)
;
CUP(Y,X) ;
S DY=IOTM+Y-2,DX=X-1 X IOXY
Q
;
POS(R,C,F) ;
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) ;
Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW5 5190 printed Dec 13, 2024@02:43:56 Page 2
DDW5 ;SFISC/PD KELTZ-WRAP, BREAK, ILINE, XLINE ;01:23 PM 21 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 ;
WRAP ;Wrap at word boundary
+1 if $EXTRACT(DDWN,DDWC,999)?1." "
SET (DDWN,DDWL(DDWRW))=$EXTRACT(DDWN,1,DDWC-1)
+2 IF DDWC'>$LENGTH(DDWN)
DO WRAPI
QUIT
+3 IF 'DDWRAP
DO POS(DDWRW,DDWRMAR+1,"R")
DO BREAK(1)
QUIT
+4 DO WRAPW
+5 QUIT
+6 ;
WRAPI ;Cursor in middle
+1 IF $EXTRACT(DDWN,DDWLMAR,999)'[" "!'DDWRAP
DO BREAK(-1)
DO POS(DDWRW-1,"E","RN")
QUIT
+2 NEW DDWCSV,DDWI,DDWLST,DDWRMSV
+3 SET DDWI=$FIND(DDWN," ",DDWC)
+4 IF DDWI
IF DDWI-2'>DDWRMAR
Begin DoDot:1
+5 SET DDWCSV=DDWC
+6 SET (DDWN,DDWL(DDWRW))=$$TR(DDWN)
+7 DO POS(DDWRW,DDWI,"R")
DO BREAK(-1)
DO POS(DDWRW-1,DDWCSV,"RN")
+8 SET (DDWN,DDWL(DDWRW))=$$TR(DDWN)
End DoDot:1
+9 IF '$TEST
IF DDWC=2
Begin DoDot:1
+10 DO POS(DDWRW,DDWRMAR+1,"R")
DO BREAK(-1)
DO POS(DDWRW-1,2,"RN")
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET DDWLST=$$TR($EXTRACT(DDWN,DDWC,999))
+13 SET (DDWL(DDWRW),DDWN)=$EXTRACT(DDWN,1,DDWC-1)
+14 SET DDWRMSV=DDWRMAR
SET DDWRMAR=$$MIN(DDWRMAR,DDWC-2)
+15 DO WRAPW
+16 WRITE $EXTRACT(DDWLST,1,IOM+DDWOFS-DDWC)
+17 SET DDWL(DDWRW)=DDWN_DDWLST
SET DDWRMAR=DDWRMSV
+18 DO POS(DDWRW,DDWC,"RN")
End DoDot:1
+19 QUIT
+20 ;
WRAPW ;Cursor at end
+1 NEW DDWI,DDWS1,DDWS2,DDWTXT
+2 SET DDWTXT(1)=DDWN
+3 DO ADJMAR^DDW6(.DDWTXT,"","I")
+4 ;
+5 SET DDWS1=$$SCR($LENGTH(DDWTXT(1))+1)
SET DDWS2=$$SCR($LENGTH(DDWTXT(DDWTXT))+1)
+6 IF DDWS1=$PIECE(DDWOFS,U,4)
IF DDWS2=$PIECE(DDWOFS,U,4)
IF DDWTXT=2
Begin DoDot:1
+7 SET (DDWN,DDWL(DDWRW))=DDWTXT(1)_DDWTXT(2)
+8 SET DDWC=$LENGTH(DDWTXT(1))+1
+9 DO POS(DDWRW,DDWC)
DO BREAK(1)
End DoDot:1
+10 ;
+11 IF '$TEST
Begin DoDot:1
+12 FOR DDWI=1:1:DDWTXT-1
Begin DoDot:2
+13 SET (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
+14 DO ILINE
+15 SET (DDWN,DDWL(DDWRW))=DDWTXT(DDWI+1)
+16 IF DDWS2=$PIECE(DDWOFS,U,4)
Begin DoDot:3
+17 DO CUP(DDWRW-1,1)
+18 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWTXT(DDWI),1+DDWOFS,IOM+DDWOFS)
+19 DO CUP(DDWRW,1)
WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
End DoDot:3
End DoDot:2
+20 DO POS(DDWRW,"E","R")
End DoDot:1
+21 QUIT
+22 ;
BREAK(DDWFLAG) ;Break line, make new line current
+1 ;Final cursor position:
+2 ; 0:lmar of new line (used by <RET>)
+3 ; 1:end of new line (used by Wrap)
+4 ;-1:doesn't matter (used by Wrap)
+5 NEW DDWRST
+6 IF $DATA(DDWMARK)
IF DDWRW+DDWA'>$PIECE(DDWMARK,U,3)
DO UNMARK^DDW7
+7 SET DDWRST=$EXTRACT(DDWN,DDWC,999)
+8 IF DDWLMAR>1
IF DDWRST'?@(DDWLMAR-1_""" "".E")
Begin DoDot:1
+9 SET DDWRST=$JUSTIFY("",DDWLMAR-1)_$$LD(DDWRST)
End DoDot:1
+10 SET (DDWN,DDWL(DDWRW))=$EXTRACT(DDWN,1,DDWC-1)
+11 WRITE $PIECE(DDGLCLR,DDGLDEL)
+12 DO ILINE
+13 SET (DDWN,DDWL(DDWRW))=DDWRST
+14 ;
+15 IF $GET(DDWFLAG)=1
Begin DoDot:1
+16 IF $$SCR($LENGTH(DDWN)+1)=$PIECE(DDWOFS,U,4)
Begin DoDot:2
+17 DO CUP(DDWRW,1)
WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
End DoDot:2
+18 DO POS(DDWRW,"E","R")
End DoDot:1
+19 ;
+20 IF '$TEST
IF '$GET(DDWFLAG)
Begin DoDot:1
+21 IF $PIECE(DDWOFS,U,4)=1
DO CUP(DDWRW,1)
WRITE $EXTRACT(DDWN,1,IOM)
+22 DO POS(DDWRW,DDWLMAR,"R")
End DoDot:1
+23 ;
+24 IF '$TEST
DO CUP(DDWRW,1)
WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
+25 QUIT
+26 ;
ILINE ;Insert line below current line, make that current
+1 ;Column is unchanged
+2 NEW DDWI,DDWX
+3 IF DDWRW<DDWMR
Begin DoDot:1
+4 IF DDWA+DDWMR'>DDWCNT
Begin DoDot:2
+5 SET DDWSTB=DDWSTB+1
SET ^TMP("DDW1",$JOB,DDWSTB)=DDWL(DDWMR)
End DoDot:2
+6 FOR DDWI=DDWMR:-1:DDWRW+2
SET DDWL(DDWI)=DDWL(DDWI-1)
+7 SET DDWL(DDWRW+1)=""
+8 DO CUP(DDWRW+1,1)
+9 ;
+10 IF $PIECE(DDGLED,DDGLDEL,3)]""
Begin DoDot:2
+11 IF $PIECE(DDGLED,DDGLDEL,2)=""
Begin DoDot:3
+12 DO CUP(DDWMR,1)
WRITE $PIECE(DDGLED,DDGLDEL,4)
DO CUP(DDWRW+1,1)
End DoDot:3
+13 WRITE $PIECE(DDGLED,DDGLDEL,3)
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 SET DDWX=IOTM
+16 SET IOTM=IOTM+DDWRW
WRITE @$PIECE(DDGLED,DDGLDEL,2)
SET IOTM=DDWX
+17 DO CUP(DDWRW+1,1)
WRITE $PIECE(DDGLED,DDGLDEL)
+18 WRITE @$PIECE(DDGLED,DDGLDEL,2)
End DoDot:2
+19 DO POS(DDWRW+1,DDWC,"RN")
End DoDot:1
+20 ;
+21 IF '$TEST
Begin DoDot:1
+22 SET DDWA=DDWA+1
SET ^TMP("DDW",$JOB,DDWA)=DDWL(1)
+23 FOR DDWI=1:1:DDWMR-1
SET DDWL(DDWI)=DDWL(DDWI+1)
+24 SET DDWL(DDWMR)=""
+25 DO SCRUP^DDW3(1)
End DoDot:1
+26 SET DDWCNT=DDWCNT+1
+27 SET $EXTRACT(DDWBF,1,3)=111
+28 QUIT
+29 ;
XLINE(DDWFLAG,DDWNP) ;Delete current line
+1 ;DDWFLAG:
+2 ; 1:leave cursor on deleted line (used by Join)
+3 ; 0:move cursor up one line if deleted line is last line
+4 ; (used by PF1-D and DELBLK)
+5 ; DDWNP = 1:don't bother printing, used by DELBLK
+6 NEW DDWI,DDWX
+7 IF $DATA(DDWMARK)
IF DDWRW+DDWA'>$PIECE(DDWMARK,U,3)
DO UNMARK^DDW7
+8 FOR DDWI=DDWRW:1:DDWMR-1
SET DDWL(DDWI)=DDWL(DDWI+1)
+9 SET DDWX=""
if DDWSTB
SET DDWX=^TMP("DDW1",$JOB,DDWSTB)
SET DDWSTB=DDWSTB-1
+10 SET DDWL(DDWMR)=DDWX
+11 ;
+12 if '$GET(DDWNP)
DO XLINEP
+13 ;
+14 SET DDWCNT=DDWCNT-1
+15 IF 'DDWCNT
Begin DoDot:1
+16 SET DDWCNT=1
DO POS(1,DDWLMAR,"RN")
End DoDot:1
+17 IF '$TEST
IF DDWA+DDWRW>DDWCNT
IF '$GET(DDWFLAG)
Begin DoDot:1
+18 DO UP^DDWT1
End DoDot:1
+19 IF '$TEST
DO POS(DDWRW,DDWC,"N")
+20 SET $EXTRACT(DDWBF,1,3)=111
+21 QUIT
+22 ;
XLINEP ;Redisplay screen
+1 IF $PIECE(DDGLED,DDGLDEL,4)]""
Begin DoDot:1
+2 WRITE $PIECE(DDGLED,DDGLDEL,4)
+3 IF $PIECE(DDGLED,DDGLDEL,2)=""
DO CUP(DDWMR,1)
WRITE $PIECE(DDGLED,DDGLDEL,3)
End DoDot:1
+4 IF '$TEST
IF DDWRW<DDWMR
Begin DoDot:1
+5 SET DDWX=IOTM
+6 SET IOTM=IOTM+DDWRW-1
WRITE @$PIECE(DDGLED,DDGLDEL,2)
SET IOTM=DDWX
+7 DO CUP(DDWMR,1)
WRITE $CHAR(10)
+8 WRITE @$PIECE(DDGLED,DDGLDEL,2)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 DO CUP(DDWMR,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)
End DoDot:1
+11 ;
+12 IF DDWL(DDWMR)'?." "
Begin DoDot:1
+13 DO CUP(DDWMR,1)
+14 WRITE $EXTRACT(DDWL(DDWMR),1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+15 QUIT
+16 ;
TR(X) if $GET(X)=""
QUIT X
+1 NEW I
+2 FOR I=$LENGTH(X):-1:0
if $EXTRACT(X,I)'=" "
QUIT
+3 QUIT $EXTRACT(X,1,I)
+4 ;
LD(X) if $GET(X)=""
QUIT X
+1 NEW I
+2 FOR I=1:1:$LENGTH(X)+1
if $EXTRACT(X,I)'=" "
QUIT
+3 QUIT $EXTRACT(X,I,999)
+4 ;
CUP(Y,X) ;
+1 SET DY=IOTM+Y-2
SET DX=X-1
XECUTE IOXY
+2 QUIT
+3 ;
POS(R,C,F) ;
+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) ;
+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)
