DDW3 ;SFISC/MKO-TOP, BOTTOM, SCROLL ;9:08 AM 13 Feb 1996
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
TOP N DDWI
I DDWA=0 D POS(1,1,"RN") Q
D SHFTUP(1),POS(1,1,"RN")
Q
;
SHFTUP(DDWFL) ;
N DDWSH,DDWI
S DDWSH=DDWA+1-DDWFL
D:DDWSH>DDWMR MSG^DDW("Repositioning ...")
;
F DDWI=DDWMR:-1:$$MAX(1,DDWMR-DDWSH+1) D:DDWI+DDWA'>DDWCNT
. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI)
. S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI)
;
I $E(DDWBF,2) F DDWI=DDWA:-1:DDWFL+DDWMR D
. S DDWSTB=DDWSTB+1
. S ^TMP("DDW1",$J,DDWSTB)=^TMP("DDW",$J,DDWI)
E S DDWSTB=$$MAX(DDWCNT-DDWFL+1-DDWMR,0)
;
S DDWA=DDWFL-1
I DDWSH>DDWMR D
. F DDWI=1:1:DDWMR S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1)
. I $P(DDWOFS,U,4)=1 D
.. D CUP(1,1)
.. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI<DDWMR:$C(13,10),1:"")
. D MSG^DDW()
E D
. F DDWI=DDWMR:-1:DDWSH+1 S DDWL(DDWI)=DDWL(DDWI-DDWSH)
. F DDWI=DDWSH:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1)
. D:$P(DDWOFS,U,4)=1 SCRDN(DDWSH)
;
S:'DDWA $E(DDWBF,2)=0
Q
;
BOT N DDWI
I DDWSTB=0 D POS($$MIN(DDWMR,DDWCNT-DDWA),"E","RN") Q
D SHFTDN($$MAX(1,DDWCNT-DDWMR+1))
D POS(DDWMR,"E","RN")
Q
;
SHFTDN(DDWFL,DDWCOL) ;
N DDWNSTB,DDWSH,DDWI
S DDWSH=DDWFL-DDWA-1,DDWNSTB=DDWCNT-DDWFL+1
D:DDWSH>DDWMR MSG^DDW("Repositioning ...")
;
F DDWI=1:1:$$MIN(DDWSH,DDWMR) D
. S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI)
. S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
.
;
I $E(DDWBF,3) F DDWI=DDWSTB:-1:DDWNSTB+1 D
. S DDWA=DDWA+1
. S ^TMP("DDW",$J,DDWA)=^TMP("DDW1",$J,DDWI)
E S DDWA=DDWFL-1
;
I DDWSH>DDWMR D
. F DDWI=1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"")
. I $P(DDWOFS,U,4)=$$SCR($S($D(DDWCOL):DDWCOL,1:$L(DDWL(DDWMR))+1)) D
.. D CUP(1,1)
.. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI<DDWMR:$C(13,10),1:"")
. D MSG^DDW()
E D
. F DDWI=1:1:DDWMR-DDWSH S DDWL(DDWI)=DDWL(DDWI+DDWSH)
. F DDWI=DDWMR-DDWSH+1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"")
. D:$P(DDWOFS,U,4)=$$SCR($L(DDWL(DDWMR))+1) SCRUP(DDWSH)
;
S DDWSTB=$$MAX(0,DDWNSTB-DDWMR)
S:'DDWSTB $E(DDWBF,3)=0
Q
;
MVFWD(DDWNUM) ;
N DDWI
F DDWI=1:1:DDWNUM D
. S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI)
. S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
F DDWI=1:1:DDWMR-DDWNUM S DDWL(DDWI)=DDWL(DDWI+DDWNUM)
F DDWI=DDWMR-DDWNUM+1:1:DDWMR D
. S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1
D SCRUP(DDWNUM)
Q
;
SCRUP(DDWNUM) ;
N DDWI
D CUP(DDWMR,1)
F DDWI=DDWMR-DDWNUM+1:1:DDWMR D
. I $P(DDGLED,DDGLDEL,2)]"" W $C(10)
. E D
.. D CUP(1,1) W $P(DDGLED,DDGLDEL,4)
.. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3)
. I DDWL(DDWI)'?." " D
.. D CUP(DDWMR,1)
.. W $$LINE(DDWI,$G(DDWMARK))
D POS(DDWMR,DDWC,"RN")
Q
;
MVBCK(DDWNUM) ;
N DDWI
F DDWI=DDWMR:-1:DDWMR-DDWNUM+1 D:DDWI+DDWA'>DDWCNT
. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI)
. S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI)
F DDWI=DDWMR:-1:DDWNUM+1 S DDWL(DDWI)=DDWL(DDWI-DDWNUM)
F DDWI=DDWNUM:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWA),DDWA=DDWA-1
D SCRDN(DDWNUM)
Q
;
SCRDN(DDWNUM) ;
N DDWI
D CUP(1,1)
F DDWI=DDWNUM:-1:1 D
. I $P(DDGLED,DDGLDEL,2)]"" W $P(DDGLED,DDGLDEL)
. E D
.. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4)
.. D CUP(1,1) W $P(DDGLED,DDGLDEL,3)
. I DDWL(DDWI)'?." " D
.. D CUP(1,1)
.. W $$LINE(DDWI,$G(DDWMARK))
D POS(1,DDWC,"RN")
Q
;
ERR ;
W $C(7)
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(C,.DDWOFS)
S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
Q
;
SHIFT(C,DDWOFS) ;
N DDWI,N,M,S
S N=$P(DDWOFS,U,2),M=$P(DDWOFS,U,3)
S S=$$SCR(C)
S DDWOFS=S-1*M_U_N_U_M_U_S
D RULER
F DDWI=1:1:$$MIN(DDWMR,DDWCNT) D
. S DY=IOTM+DDWI-2,DX=0 X IOXY
. W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))
Q
;
RULER ;Write ruler
D CUP(DDWMR+1,1)
W $P(DDGLCLR,DDGLDEL)_$E(DDWRUL,1+DDWOFS,IOM+DDWOFS)
I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D
. D CUP(DDWMR+1,DDWLMAR-DDWOFS) W "<"
I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D
. D CUP(DDWMR+1,DDWRMAR-DDWOFS) W ">"
Q
;
LINE(DDWI,DDWMARK) ;
N DDWX
S DDWX=$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
Q:$G(DDWMARK)="" DDWX
;
N DDWR1,DDWC1,DDWR2,DDWC2
S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2)
S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4)
;
I DDWI'<(DDWR1-DDWA),DDWI'>(DDWR2-DDWA) D
. N DDWX1,DDWX2
. S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1)
. S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999)
. S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS)
Q DDWX
;
SCR(C) ;
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)
DDW3 ;SFISC/MKO-TOP, BOTTOM, SCROLL ;9:08 AM 13 Feb 1996
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
TOP NEW DDWI
+1 IF DDWA=0
DO POS(1,1,"RN")
QUIT
+2 DO SHFTUP(1)
DO POS(1,1,"RN")
+3 QUIT
+4 ;
SHFTUP(DDWFL) ;
+1 NEW DDWSH,DDWI
+2 SET DDWSH=DDWA+1-DDWFL
+3 IF DDWSH>DDWMR
DO MSG^DDW("Repositioning ...")
+4 ;
+5 FOR DDWI=DDWMR:-1:$$MAX(1,DDWMR-DDWSH+1)
IF DDWI+DDWA'>DDWCNT
Begin DoDot:1
+6 SET DDWSTB=DDWSTB+1
SET ^TMP("DDW1",$JOB,DDWSTB)=DDWL(DDWI)
+7 SET ^TMP("DDW",$JOB,DDWA+DDWI)=DDWL(DDWI)
End DoDot:1
+8 ;
+9 IF $EXTRACT(DDWBF,2)
FOR DDWI=DDWA:-1:DDWFL+DDWMR
Begin DoDot:1
+10 SET DDWSTB=DDWSTB+1
+11 SET ^TMP("DDW1",$JOB,DDWSTB)=^TMP("DDW",$JOB,DDWI)
End DoDot:1
+12 IF '$TEST
SET DDWSTB=$$MAX(DDWCNT-DDWFL+1-DDWMR,0)
+13 ;
+14 SET DDWA=DDWFL-1
+15 IF DDWSH>DDWMR
Begin DoDot:1
+16 FOR DDWI=1:1:DDWMR
SET DDWL(DDWI)=^TMP("DDW",$JOB,DDWFL+DDWI-1)
+17 IF $PIECE(DDWOFS,U,4)=1
Begin DoDot:2
+18 DO CUP(1,1)
+19 FOR DDWI=1:1:DDWMR
WRITE $PIECE(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$GET(DDWMARK))_$SELECT(DDWI<DDWMR:$CHAR(13,10),1:"")
End DoDot:2
+20 DO MSG^DDW()
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 FOR DDWI=DDWMR:-1:DDWSH+1
SET DDWL(DDWI)=DDWL(DDWI-DDWSH)
+23 FOR DDWI=DDWSH:-1:1
SET DDWL(DDWI)=^TMP("DDW",$JOB,DDWFL+DDWI-1)
+24 IF $PIECE(DDWOFS,U,4)=1
DO SCRDN(DDWSH)
End DoDot:1
+25 ;
+26 IF 'DDWA
SET $EXTRACT(DDWBF,2)=0
+27 QUIT
+28 ;
BOT NEW DDWI
+1 IF DDWSTB=0
DO POS($$MIN(DDWMR,DDWCNT-DDWA),"E","RN")
QUIT
+2 DO SHFTDN($$MAX(1,DDWCNT-DDWMR+1))
+3 DO POS(DDWMR,"E","RN")
+4 QUIT
+5 ;
SHFTDN(DDWFL,DDWCOL) ;
+1 NEW DDWNSTB,DDWSH,DDWI
+2 SET DDWSH=DDWFL-DDWA-1
SET DDWNSTB=DDWCNT-DDWFL+1
+3 IF DDWSH>DDWMR
DO MSG^DDW("Repositioning ...")
+4 ;
+5 FOR DDWI=1:1:$$MIN(DDWSH,DDWMR)
Begin DoDot:1
+6 SET DDWA=DDWA+1
SET ^TMP("DDW",$JOB,DDWA)=DDWL(DDWI)
+7 SET ^TMP("DDW1",$JOB,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
+8 End DoDot:1
+9 ;
+10 IF $EXTRACT(DDWBF,3)
FOR DDWI=DDWSTB:-1:DDWNSTB+1
Begin DoDot:1
+11 SET DDWA=DDWA+1
+12 SET ^TMP("DDW",$JOB,DDWA)=^TMP("DDW1",$JOB,DDWI)
End DoDot:1
+13 IF '$TEST
SET DDWA=DDWFL-1
+14 ;
+15 IF DDWSH>DDWMR
Begin DoDot:1
+16 FOR DDWI=1:1:DDWMR
SET DDWL(DDWI)=$SELECT(DDWNSTB-DDWI+1>0:^TMP("DDW1",$JOB,DDWNSTB-DDWI+1),1:"")
+17 IF $PIECE(DDWOFS,U,4)=$$SCR($SELECT($DATA(DDWCOL):DDWCOL,1:$LENGTH(DDWL(DDWMR))+1))
Begin DoDot:2
+18 DO CUP(1,1)
+19 FOR DDWI=1:1:DDWMR
WRITE $PIECE(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$GET(DDWMARK))_$SELECT(DDWI<DDWMR:$CHAR(13,10),1:"")
End DoDot:2
+20 DO MSG^DDW()
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 FOR DDWI=1:1:DDWMR-DDWSH
SET DDWL(DDWI)=DDWL(DDWI+DDWSH)
+23 FOR DDWI=DDWMR-DDWSH+1:1:DDWMR
SET DDWL(DDWI)=$SELECT(DDWNSTB-DDWI+1>0:^TMP("DDW1",$JOB,DDWNSTB-DDWI+1),1:"")
+24 IF $PIECE(DDWOFS,U,4)=$$SCR($LENGTH(DDWL(DDWMR))+1)
DO SCRUP(DDWSH)
End DoDot:1
+25 ;
+26 SET DDWSTB=$$MAX(0,DDWNSTB-DDWMR)
+27 IF 'DDWSTB
SET $EXTRACT(DDWBF,3)=0
+28 QUIT
+29 ;
MVFWD(DDWNUM) ;
+1 NEW DDWI
+2 FOR DDWI=1:1:DDWNUM
Begin DoDot:1
+3 SET DDWA=DDWA+1
SET ^TMP("DDW",$JOB,DDWA)=DDWL(DDWI)
+4 SET ^TMP("DDW1",$JOB,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
End DoDot:1
+5 FOR DDWI=1:1:DDWMR-DDWNUM
SET DDWL(DDWI)=DDWL(DDWI+DDWNUM)
+6 FOR DDWI=DDWMR-DDWNUM+1:1:DDWMR
Begin DoDot:1
+7 SET DDWL(DDWI)=^TMP("DDW1",$JOB,DDWSTB)
SET DDWSTB=DDWSTB-1
End DoDot:1
+8 DO SCRUP(DDWNUM)
+9 QUIT
+10 ;
SCRUP(DDWNUM) ;
+1 NEW DDWI
+2 DO CUP(DDWMR,1)
+3 FOR DDWI=DDWMR-DDWNUM+1:1:DDWMR
Begin DoDot:1
+4 IF $PIECE(DDGLED,DDGLDEL,2)]""
WRITE $CHAR(10)
+5 IF '$TEST
Begin DoDot:2
+6 DO CUP(1,1)
WRITE $PIECE(DDGLED,DDGLDEL,4)
+7 DO CUP(DDWMR,1)
WRITE $PIECE(DDGLED,DDGLDEL,3)
End DoDot:2
+8 IF DDWL(DDWI)'?." "
Begin DoDot:2
+9 DO CUP(DDWMR,1)
+10 WRITE $$LINE(DDWI,$GET(DDWMARK))
End DoDot:2
End DoDot:1
+11 DO POS(DDWMR,DDWC,"RN")
+12 QUIT
+13 ;
MVBCK(DDWNUM) ;
+1 NEW DDWI
+2 FOR DDWI=DDWMR:-1:DDWMR-DDWNUM+1
IF DDWI+DDWA'>DDWCNT
Begin DoDot:1
+3 SET DDWSTB=DDWSTB+1
SET ^TMP("DDW1",$JOB,DDWSTB)=DDWL(DDWI)
+4 SET ^TMP("DDW",$JOB,DDWA+DDWI)=DDWL(DDWI)
End DoDot:1
+5 FOR DDWI=DDWMR:-1:DDWNUM+1
SET DDWL(DDWI)=DDWL(DDWI-DDWNUM)
+6 FOR DDWI=DDWNUM:-1:1
SET DDWL(DDWI)=^TMP("DDW",$JOB,DDWA)
SET DDWA=DDWA-1
+7 DO SCRDN(DDWNUM)
+8 QUIT
+9 ;
SCRDN(DDWNUM) ;
+1 NEW DDWI
+2 DO CUP(1,1)
+3 FOR DDWI=DDWNUM:-1:1
Begin DoDot:1
+4 IF $PIECE(DDGLED,DDGLDEL,2)]""
WRITE $PIECE(DDGLED,DDGLDEL)
+5 IF '$TEST
Begin DoDot:2
+6 DO CUP(DDWMR,1)
WRITE $PIECE(DDGLED,DDGLDEL,4)
+7 DO CUP(1,1)
WRITE $PIECE(DDGLED,DDGLDEL,3)
End DoDot:2
+8 IF DDWL(DDWI)'?." "
Begin DoDot:2
+9 DO CUP(1,1)
+10 WRITE $$LINE(DDWI,$GET(DDWMARK))
End DoDot:2
End DoDot:1
+11 DO POS(1,DDWC,"RN")
+12 QUIT
+13 ;
ERR ;
+1 WRITE $CHAR(7)
+2 QUIT
+3 ;
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(C,.DDWOFS)
+8 SET DY=IOTM+R-2
SET DX=C-DDWOFS-1
XECUTE IOXY
+9 QUIT
+10 ;
SHIFT(C,DDWOFS) ;
+1 NEW DDWI,N,M,S
+2 SET N=$PIECE(DDWOFS,U,2)
SET M=$PIECE(DDWOFS,U,3)
+3 SET S=$$SCR(C)
+4 SET DDWOFS=S-1*M_U_N_U_M_U_S
+5 DO RULER
+6 FOR DDWI=1:1:$$MIN(DDWMR,DDWCNT)
Begin DoDot:1
+7 SET DY=IOTM+DDWI-2
SET DX=0
XECUTE IOXY
+8 WRITE $PIECE(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$GET(DDWMARK))
End DoDot:1
+9 QUIT
+10 ;
RULER ;Write ruler
+1 DO CUP(DDWMR+1,1)
+2 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWRUL,1+DDWOFS,IOM+DDWOFS)
+3 IF DDWLMAR-DDWOFS'<1
IF DDWLMAR-DDWOFS'>IOM
Begin DoDot:1
+4 DO CUP(DDWMR+1,DDWLMAR-DDWOFS)
WRITE "<"
End DoDot:1
+5 IF DDWRMAR-DDWOFS'<1
IF DDWRMAR-DDWOFS'>IOM
Begin DoDot:1
+6 DO CUP(DDWMR+1,DDWRMAR-DDWOFS)
WRITE ">"
End DoDot:1
+7 QUIT
+8 ;
LINE(DDWI,DDWMARK) ;
+1 NEW DDWX
+2 SET DDWX=$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
+3 IF $GET(DDWMARK)=""
QUIT DDWX
+4 ;
+5 NEW DDWR1,DDWC1,DDWR2,DDWC2
+6 SET DDWR1=$PIECE(DDWMARK,U,1)
SET DDWC1=$PIECE(DDWMARK,U,2)
+7 SET DDWR2=$PIECE(DDWMARK,U,3)
SET DDWC2=$PIECE(DDWMARK,U,4)
+8 ;
+9 IF DDWI'<(DDWR1-DDWA)
IF DDWI'>(DDWR2-DDWA)
Begin DoDot:1
+10 NEW DDWX1,DDWX2
+11 SET DDWX1=$SELECT(DDWI=(DDWR1-DDWA):DDWC1,1:1)
+12 SET DDWX2=$SELECT(DDWI=(DDWR2-DDWA):DDWC2,1:999)
+13 SET DDWX=$EXTRACT(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$PIECE(DDGLVID,DDGLDEL,10)_$EXTRACT(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS)
End DoDot:1
+14 QUIT DDWX
+15 ;
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)
+2 ;
MAX(X,Y) ;
+1 QUIT $SELECT(X>Y:X,1:Y)
