DDW9 ;SFISC/MKO-MARK TEXT ;12:20 PM 24 Aug 2002
;;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.
;
CHKDEL(DDWY) ;Check that cursor is on block and delete
N DDWI
N DDWC1,DDWC2,DDWR1,DDWR2,DDWI
D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
S DDWY=0,DDWI=DDWRW+DDWA
Q:DDWI<DDWR1
Q:DDWI>DDWR2
I DDWI=DDWR1,DDWC<DDWC1 D UNMARK^DDW7 Q
I DDWI=DDWR2,DDWC-1>DDWC2 D UNMARK^DDW7 Q
;
D DELBLK()
S DDWY=1
Q
;
DELBLK(DDWNDEL) ;Delete block
;Returns: DDWNDEL=# lines deleted from the screen
N DDWNP,DDWI,DDWX
I '$D(DDWR1) N DDWR1,DDWR2,DDWC1,DDWC2 D
. D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
;
S DDWNDEL=0,$E(DDWBF,1,3)=111
K DDWMARK
;
I DDWR2-DDWA<1 D
. D DELABV
E I DDWR1-DDWA>DDWMR D
. D DELBEL
E D DELMID
;
D IND^DDW7()
Q
;
DELABV ;All of the block is above the screen
I DDWR1=DDWR2 D Q
. N DDWX
. S DDWX=^TMP("DDW",$J,DDWR1),$E(DDWX,DDWC1,DDWC2)=""
. I DDWX]"" S ^TMP("DDW",$J,DDWR1)=DDWX
. E D SHIFTA(DDWR1,DDWR1)
;
D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;**
N DDWFST,DDWLST
S DDWFST=$E(^TMP("DDW",$J,DDWR1),1,DDWC1-1)
S DDWLST=$E(^TMP("DDW",$J,DDWR2),DDWC2+1,999)
I DDWFST]"" S ^TMP("DDW",$J,DDWR1)=DDWFST,DDWFST=DDWR1+1
E S DDWFST=DDWR1
I DDWLST]"" S ^TMP("DDW",$J,DDWR2)=DDWLST,DDWLST=DDWR2-1
E S DDWLST=DDWR2
D SHIFTA(DDWFST,DDWLST)
D:DDWR2-DDWR1>50 MSG^DDW()
Q
;
SHIFTA(DDWA1,DDWA2) ;
N DDWNL
S DDWNL=DDWA2-DDWA1+1
I DDWA2=DDWA S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q
;
N DDWI
F DDWI=DDWA1:1:DDWA-DDWNL S ^TMP("DDW",$J,DDWI)=^TMP("DDW",$J,DDWI+DDWNL)
S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL
Q
;
DELBEL ;All of the block is below the screen
N DDWS1,DDWS2
S DDWS1=DDWA+DDWMR+DDWSTB-DDWR1+1,DDWS2=DDWA+DDWMR+DDWSTB-DDWR2+1
I DDWS1=DDWS2 D Q
. N DDWX
. S DDWX=^TMP("DDW1",$J,DDWS1),$E(DDWX,DDWC1,DDWC2)=""
. I DDWX]"" S ^TMP("DDW1",$J,DDWS1)=DDWX
. E D SHIFTB(DDWS1,DDWS1)
;
D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;**
N DDWFST,DDWLST
S DDWFST=$E(^TMP("DDW1",$J,DDWS1),1,DDWC1-1)
S DDWLST=$E(^TMP("DDW1",$J,DDWS2),DDWC2+1,999)
I DDWFST]"" S ^TMP("DDW1",$J,DDWS1)=DDWFST,DDWFST=DDWS1-1
E S DDWFST=DDWS1
I DDWLST]"" S ^TMP("DDW1",$J,DDWS2)=DDWLST,DDWLST=DDWS2+1
E S DDWLST=DDWS2
D SHIFTB(DDWFST,DDWLST)
D:DDWR2-DDWR1>50 MSG^DDW()
Q
;
SHIFTB(DDWS1,DDWS2) ;
N DDWNL
S DDWNL=DDWS1-DDWS2+1
I DDWS1=DDWSTB S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q
;
N DDWI
F DDWI=DDWS2:1:DDWSTB-DDWNL S ^TMP("DDW1",$J,DDWI)=^TMP("DDW1",$J,DDWI+DDWNL)
S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL
Q
;
DELMID ;A portion of the block appears on the screen
I DDWR2-1-DDWA>DDWMR D
. S DDWX=DDWR2-(DDWA+DDWMR+1)
. S DDWSTB=DDWSTB-DDWX,DDWCNT=DDWCNT-DDWX
;
I DDWR2-DDWA>DDWMR D
. S DDWX=$E(^TMP("DDW1",$J,DDWSTB),DDWC2+1,999)
. I DDWX="" S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1
. E S ^TMP("DDW1",$J,DDWSTB)=DDWX
;
D POS($$MAX(DDWR1-DDWA,1),$S(DDWR1=DDWR2:DDWC1,1:1),"RN")
;
S DDWNP=DDWR2-DDWA'<DDWMR
F DDWI=DDWRW:1:$$MIN(DDWR2-DDWA,DDWMR) D
. S DDWX=$E(DDWL(DDWRW),1,$S(DDWI+DDWA=DDWR1:DDWC1,1:1)-1)_$E(DDWL(DDWRW),$S(DDWI+DDWA=DDWR2:DDWC2,1:999)+1,999)
. I DDWX]"" D
.. S DDWL(DDWRW)=DDWX
.. I 'DDWNP D
... D CUP(DDWRW,1)
... W $P(DDGLCLR,DDGLDEL)_$E(DDWX,1+DDWOFS,IOM+DDWOFS)
.. D POS(DDWRW+(DDWI<$$MIN(DDWR2-DDWA,DDWMR)),DDWC,"RN")
. E D XLINE^DDW5(1,DDWNP) S DDWNDEL=DDWNDEL+1
;
I DDWNP F DDWI=$$MAX(DDWR1-DDWA,1):1:DDWMR D
. D CUP(DDWI,1)
. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
;
I DDWR1+1'>DDWA D
. S DDWX=DDWA-DDWR1
. S DDWA=DDWA-DDWX,DDWCNT=DDWCNT-DDWX
;
I DDWR1'>DDWA D
. S DDWX=$E(^TMP("DDW",$J,DDWA),1,DDWC1-1)
. I DDWX="" S DDWA=DDWA-1,DDWCNT=DDWCNT-1
. E S ^TMP("DDW",$J,DDWA)=DDWX
;
S:DDWCNT<1 DDWCNT=1
D:DDWRW+DDWA>DDWCNT UP^DDWT1
Q
;
PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK)
S R1=$P(M,U),C1=$P(M,U,2)
S R2=$P(M,U,3),C2=$P(M,U,4)
Q
;
CUP(Y,X) ;
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
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
;
MAX(X,Y) ;
Q $S(X>Y:X,1:Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW9 4527 printed Oct 16, 2024@18:44:33 Page 2
DDW9 ;SFISC/MKO-MARK TEXT ;12:20 PM 24 Aug 2002
+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 ;
CHKDEL(DDWY) ;Check that cursor is on block and delete
+1 NEW DDWI
+2 NEW DDWC1,DDWC2,DDWR1,DDWR2,DDWI
+3 DO PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
+4 SET DDWY=0
SET DDWI=DDWRW+DDWA
+5 if DDWI<DDWR1
QUIT
+6 if DDWI>DDWR2
QUIT
+7 IF DDWI=DDWR1
IF DDWC<DDWC1
DO UNMARK^DDW7
QUIT
+8 IF DDWI=DDWR2
IF DDWC-1>DDWC2
DO UNMARK^DDW7
QUIT
+9 ;
+10 DO DELBLK()
+11 SET DDWY=1
+12 QUIT
+13 ;
DELBLK(DDWNDEL) ;Delete block
+1 ;Returns: DDWNDEL=# lines deleted from the screen
+2 NEW DDWNP,DDWI,DDWX
+3 IF '$DATA(DDWR1)
NEW DDWR1,DDWR2,DDWC1,DDWC2
Begin DoDot:1
+4 DO PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
End DoDot:1
+5 ;
+6 SET DDWNDEL=0
SET $EXTRACT(DDWBF,1,3)=111
+7 KILL DDWMARK
+8 ;
+9 IF DDWR2-DDWA<1
Begin DoDot:1
+10 DO DELABV
End DoDot:1
+11 IF '$TEST
IF DDWR1-DDWA>DDWMR
Begin DoDot:1
+12 DO DELBEL
End DoDot:1
+13 IF '$TEST
DO DELMID
+14 ;
+15 DO IND^DDW7()
+16 QUIT
+17 ;
DELABV ;All of the block is above the screen
+1 IF DDWR1=DDWR2
Begin DoDot:1
+2 NEW DDWX
+3 SET DDWX=^TMP("DDW",$JOB,DDWR1)
SET $EXTRACT(DDWX,DDWC1,DDWC2)=""
+4 IF DDWX]""
SET ^TMP("DDW",$JOB,DDWR1)=DDWX
+5 IF '$TEST
DO SHIFTA(DDWR1,DDWR1)
End DoDot:1
QUIT
+6 ;
+7 ;**
if DDWR2-DDWR1>50
DO MSG^DDW(" ...")
+8 NEW DDWFST,DDWLST
+9 SET DDWFST=$EXTRACT(^TMP("DDW",$JOB,DDWR1),1,DDWC1-1)
+10 SET DDWLST=$EXTRACT(^TMP("DDW",$JOB,DDWR2),DDWC2+1,999)
+11 IF DDWFST]""
SET ^TMP("DDW",$JOB,DDWR1)=DDWFST
SET DDWFST=DDWR1+1
+12 IF '$TEST
SET DDWFST=DDWR1
+13 IF DDWLST]""
SET ^TMP("DDW",$JOB,DDWR2)=DDWLST
SET DDWLST=DDWR2-1
+14 IF '$TEST
SET DDWLST=DDWR2
+15 DO SHIFTA(DDWFST,DDWLST)
+16 if DDWR2-DDWR1>50
DO MSG^DDW()
+17 QUIT
+18 ;
SHIFTA(DDWA1,DDWA2) ;
+1 NEW DDWNL
+2 SET DDWNL=DDWA2-DDWA1+1
+3 IF DDWA2=DDWA
SET DDWA=DDWA-DDWNL
SET DDWCNT=DDWCNT-DDWNL
QUIT
+4 ;
+5 NEW DDWI
+6 FOR DDWI=DDWA1:1:DDWA-DDWNL
SET ^TMP("DDW",$JOB,DDWI)=^TMP("DDW",$JOB,DDWI+DDWNL)
+7 SET DDWA=DDWA-DDWNL
SET DDWCNT=DDWCNT-DDWNL
+8 QUIT
+9 ;
DELBEL ;All of the block is below the screen
+1 NEW DDWS1,DDWS2
+2 SET DDWS1=DDWA+DDWMR+DDWSTB-DDWR1+1
SET DDWS2=DDWA+DDWMR+DDWSTB-DDWR2+1
+3 IF DDWS1=DDWS2
Begin DoDot:1
+4 NEW DDWX
+5 SET DDWX=^TMP("DDW1",$JOB,DDWS1)
SET $EXTRACT(DDWX,DDWC1,DDWC2)=""
+6 IF DDWX]""
SET ^TMP("DDW1",$JOB,DDWS1)=DDWX
+7 IF '$TEST
DO SHIFTB(DDWS1,DDWS1)
End DoDot:1
QUIT
+8 ;
+9 ;**
if DDWR2-DDWR1>50
DO MSG^DDW(" ...")
+10 NEW DDWFST,DDWLST
+11 SET DDWFST=$EXTRACT(^TMP("DDW1",$JOB,DDWS1),1,DDWC1-1)
+12 SET DDWLST=$EXTRACT(^TMP("DDW1",$JOB,DDWS2),DDWC2+1,999)
+13 IF DDWFST]""
SET ^TMP("DDW1",$JOB,DDWS1)=DDWFST
SET DDWFST=DDWS1-1
+14 IF '$TEST
SET DDWFST=DDWS1
+15 IF DDWLST]""
SET ^TMP("DDW1",$JOB,DDWS2)=DDWLST
SET DDWLST=DDWS2+1
+16 IF '$TEST
SET DDWLST=DDWS2
+17 DO SHIFTB(DDWFST,DDWLST)
+18 if DDWR2-DDWR1>50
DO MSG^DDW()
+19 QUIT
+20 ;
SHIFTB(DDWS1,DDWS2) ;
+1 NEW DDWNL
+2 SET DDWNL=DDWS1-DDWS2+1
+3 IF DDWS1=DDWSTB
SET DDWSTB=DDWSTB-DDWNL
SET DDWCNT=DDWCNT-DDWNL
QUIT
+4 ;
+5 NEW DDWI
+6 FOR DDWI=DDWS2:1:DDWSTB-DDWNL
SET ^TMP("DDW1",$JOB,DDWI)=^TMP("DDW1",$JOB,DDWI+DDWNL)
+7 SET DDWSTB=DDWSTB-DDWNL
SET DDWCNT=DDWCNT-DDWNL
+8 QUIT
+9 ;
DELMID ;A portion of the block appears on the screen
+1 IF DDWR2-1-DDWA>DDWMR
Begin DoDot:1
+2 SET DDWX=DDWR2-(DDWA+DDWMR+1)
+3 SET DDWSTB=DDWSTB-DDWX
SET DDWCNT=DDWCNT-DDWX
End DoDot:1
+4 ;
+5 IF DDWR2-DDWA>DDWMR
Begin DoDot:1
+6 SET DDWX=$EXTRACT(^TMP("DDW1",$JOB,DDWSTB),DDWC2+1,999)
+7 IF DDWX=""
SET DDWSTB=DDWSTB-1
SET DDWCNT=DDWCNT-1
+8 IF '$TEST
SET ^TMP("DDW1",$JOB,DDWSTB)=DDWX
End DoDot:1
+9 ;
+10 DO POS($$MAX(DDWR1-DDWA,1),$SELECT(DDWR1=DDWR2:DDWC1,1:1),"RN")
+11 ;
+12 SET DDWNP=DDWR2-DDWA'<DDWMR
+13 FOR DDWI=DDWRW:1:$$MIN(DDWR2-DDWA,DDWMR)
Begin DoDot:1
+14 SET DDWX=$EXTRACT(DDWL(DDWRW),1,$SELECT(DDWI+DDWA=DDWR1:DDWC1,1:1)-1)_$EXTRACT(DDWL(DDWRW),$SELECT(DDWI+DDWA=DDWR2:DDWC2,1:999)+1,999)
+15 IF DDWX]""
Begin DoDot:2
+16 SET DDWL(DDWRW)=DDWX
+17 IF 'DDWNP
Begin DoDot:3
+18 DO CUP(DDWRW,1)
+19 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWX,1+DDWOFS,IOM+DDWOFS)
End DoDot:3
+20 DO POS(DDWRW+(DDWI<$$MIN(DDWR2-DDWA,DDWMR)),DDWC,"RN")
End DoDot:2
+21 IF '$TEST
DO XLINE^DDW5(1,DDWNP)
SET DDWNDEL=DDWNDEL+1
End DoDot:1
+22 ;
+23 IF DDWNP
FOR DDWI=$$MAX(DDWR1-DDWA,1):1:DDWMR
Begin DoDot:1
+24 DO CUP(DDWI,1)
+25 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+26 ;
+27 IF DDWR1+1'>DDWA
Begin DoDot:1
+28 SET DDWX=DDWA-DDWR1
+29 SET DDWA=DDWA-DDWX
SET DDWCNT=DDWCNT-DDWX
End DoDot:1
+30 ;
+31 IF DDWR1'>DDWA
Begin DoDot:1
+32 SET DDWX=$EXTRACT(^TMP("DDW",$JOB,DDWA),1,DDWC1-1)
+33 IF DDWX=""
SET DDWA=DDWA-1
SET DDWCNT=DDWCNT-1
+34 IF '$TEST
SET ^TMP("DDW",$JOB,DDWA)=DDWX
End DoDot:1
+35 ;
+36 if DDWCNT<1
SET DDWCNT=1
+37 if DDWRW+DDWA>DDWCNT
DO UP^DDWT1
+38 QUIT
+39 ;
PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK)
+1 SET R1=$PIECE(M,U)
SET C1=$PIECE(M,U,2)
+2 SET R2=$PIECE(M,U,3)
SET C2=$PIECE(M,U,4)
+3 QUIT
+4 ;
CUP(Y,X) ;
+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 ;
MIN(X,Y) ;
+1 QUIT $SELECT(X<Y:X,1:Y)
+2 ;
MAX(X,Y) ;
+1 QUIT $SELECT(X>Y:X,1:Y)
