DDW8 ;SFISC/MKO-COPY, CUT, PASTE ;12:09 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.
;
CUT() ;Cut selected text
N DDWADJ,DDWC1,DDWC2,DDWCSV,DDWISIN,DDWNDEL,DDWR1,DDWR2,DDWRSV
I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT'
;
S DDWED=1
S DDWISIN=$$ISINSEL()
D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
D COPYBUF
;
S DDWRSV=DDWRW,DDWCSV=DDWC
I DDWR2>DDWA,DDWR2-DDWA<DDWRW S DDWADJ=1
E I DDWR1-DDWA'>DDWMR,DDWR1-DDWA>DDWRW S DDWADJ=0
;
D DELBLK^DDW9(.DDWNDEL)
D:$D(DDWADJ) POS(DDWRSV-(DDWADJ*DDWNDEL),DDWCSV,"RN")
D:'DDWISIN PASTE()
Q
;
COPY() ;Copy selected text
N DDWC1,DDWC2,DDWISIN,DDWR1,DDWR2
I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT'
;
S DDWISIN=$$ISINSEL()
D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
D COPYBUF
D UNMARK^DDW7
D:'DDWISIN PASTE()
Q
;
COPYBUF ;Copy selected text to buffer
N DDWND,DDWI,DDWX,DDWX1,DDWX2
K ^TMP("DDWB",$J)
S DDWND=0
;
D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;**
;
F DDWI=DDWR1:1:$$MIN(DDWA,DDWR2) D
. S DDWND=DDWND+1
. S DDWX=^TMP("DDW",$J,DDWI)
. S DDWX=$E(DDWX,$S(DDWI=DDWR1:DDWC1,1:1),$S(DDWI=DDWR2:DDWC2,1:999))
. S ^TMP("DDWB",$J,DDWND)=DDWX
;
F DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR) D
. S DDWX=$E(DDWL(DDWI),$S(DDWI+DDWA=DDWR1:DDWC1,1:1),$S(DDWI+DDWA=DDWR2:DDWC2,1:999))
. S DDWND=DDWND+1
. S ^TMP("DDWB",$J,DDWND)=DDWX
;
S DDWX1=$$RTOSTB(DDWR1),DDWX2=$$RTOSTB(DDWR2)
F DDWI=$$MIN(DDWSTB,DDWX1):-1:DDWX2 D
. S DDWND=DDWND+1
. S DDWX=^TMP("DDW1",$J,DDWI)
. S DDWX=$E(DDWX,$S(DDWI=DDWX1:DDWC1,1:1),$S(DDWI=DDWX2:DDWC2,1:999))
. S ^TMP("DDWB",$J,DDWND)=DDWX
;
D:DDWR2-DDWR1>50 MSG^DDW()
Q
;
PASTE() ;Paste text
I $D(DDWMARK) D ERR("You curently have text selected.") Q
I '$D(^TMP("DDWB",$J)) D ERR($$EZBLD^DIALOG(1404)) Q ;**
;
S DDWED=1
N DDWBSIZ,DDWFC,DDWI,DDWLST,DDWNSV,DDWTXT,DDWX
S DDWBSIZ=$O(^TMP("DDWB",$J,""),-1)
;
S DDWTXT=1
S:$L(DDWN)+1<DDWC DDWN=DDWN_$J("",DDWC-$L(DDWN)-1)
S (DDWNSV,DDWX)=$E(DDWN,1,DDWC-1)
S DDWTXT(1)=DDWX
I $L(DDWX)+$L(^TMP("DDWB",$J,1))<256!(DDWX="") S DDWTXT(1)=DDWTXT(1)_^(1)
E S DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=^TMP("DDWB",$J,1)
;
S DDWLST=$E(DDWN,DDWC,999)
I DDWRAP,DDWLST?1." " S DDWLST=""
I DDWLST]"",DDWBSIZ=1 S DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=DDWLST,DDWLST=""
;
D:DDWTXT ADJMAR^DDW6(.DDWTXT,"","I")
S (DDWN,DDWL(DDWRW))=DDWTXT(1)
;
I DDWBSIZ=1,DDWTXT=1 S DDWFC=$L(DDWNSV)+$L(^TMP("DDWB",$J,1))+1
E I DDWBSIZ=1,DDWTXT=2,DDWLST="" S DDWFC=$L(DDWTXT(2))+1
E S DDWFC=1
;
I $$SCR(DDWFC)=$P(DDWOFS,U,4) D
. D POS(DDWRW,$$MIN($L(DDWNSV),$L(DDWN))+1)
. W $P(DDGLCLR,DDGLDEL)_$E(DDWN,$L(DDWNSV)+1,IOM+DDWOFS)
;
D POS(DDWRW,DDWFC,"R")
;
F DDWI=2:1:DDWTXT D
. D ILINE^DDW5
. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
. D CUP(DDWRW,1)
. W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
;
F DDWI=2:1:DDWBSIZ D
. D ILINE^DDW5
. S (DDWN,DDWL(DDWRW))=^TMP("DDWB",$J,DDWI)
. D CUP(DDWRW,1)
. W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
;
I DDWLST]"" D
. D ILINE^DDW5
. S (DDWN,DDWL(DDWRW))=DDWLST
. D CUP(DDWRW,1)
. W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
;
D POS(DDWRW,DDWFC,"RN")
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
;
ISINSEL() ;Is the cursor within the selected text
N DDWI,DDWY
S DDWI=DDWRW+DDWA,DDWY=0
I DDWI<$P(DDWMARK,U)
E I DDWI>$P(DDWMARK,U,3)
E I DDWI=$P(DDWMARK,U),DDWC<$P(DDWMARK,U,2)
E I DDWI=$P(DDWMARK,U,3),DDWC-1>$P(DDWMARK,U,4)
E S DDWY=1
Q DDWY
;
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
;
ERR(DDWX) ;
D MSG^DDW($C(7)_DDWX) H 2 D MSG^DDW()
D CUP(DDWRW,DDWC-DDWOFS)
F R *DDWX:0 E Q
Q
;
TR(X) ;Strip trailing blanks
Q:$G(X)="" X
N I
F I=$L(X):-1:0 Q:$E(X,I)'=" "
Q $E(X,1,I)
;
LD(X) ;Strip leading blanks
Q:$G(X)="" X
N I
F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
Q $E(X,I,999)
;
RTOSTB(R) ;Return node in STB given line #
Q DDWSTB+DDWA+DDWMR+1-R
;
SCR(C) ;Return screen number
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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW8 4640 printed Oct 16, 2024@18:44:32 Page 2
DDW8 ;SFISC/MKO-COPY, CUT, PASTE ;12:09 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 ;
CUT() ;Cut selected text
+1 NEW DDWADJ,DDWC1,DDWC2,DDWCSV,DDWISIN,DDWNDEL,DDWR1,DDWR2,DDWRSV
+2 ;**'NO TEXT'
IF '$DATA(DDWMARK)
DO ERR($$EZBLD^DIALOG(1404))
QUIT
+3 ;
+4 SET DDWED=1
+5 SET DDWISIN=$$ISINSEL()
+6 DO PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
+7 DO COPYBUF
+8 ;
+9 SET DDWRSV=DDWRW
SET DDWCSV=DDWC
+10 IF DDWR2>DDWA
IF DDWR2-DDWA<DDWRW
SET DDWADJ=1
+11 IF '$TEST
IF DDWR1-DDWA'>DDWMR
IF DDWR1-DDWA>DDWRW
SET DDWADJ=0
+12 ;
+13 DO DELBLK^DDW9(.DDWNDEL)
+14 if $DATA(DDWADJ)
DO POS(DDWRSV-(DDWADJ*DDWNDEL),DDWCSV,"RN")
+15 if 'DDWISIN
DO PASTE()
+16 QUIT
+17 ;
COPY() ;Copy selected text
+1 NEW DDWC1,DDWC2,DDWISIN,DDWR1,DDWR2
+2 ;**'NO TEXT'
IF '$DATA(DDWMARK)
DO ERR($$EZBLD^DIALOG(1404))
QUIT
+3 ;
+4 SET DDWISIN=$$ISINSEL()
+5 DO PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
+6 DO COPYBUF
+7 DO UNMARK^DDW7
+8 if 'DDWISIN
DO PASTE()
+9 QUIT
+10 ;
COPYBUF ;Copy selected text to buffer
+1 NEW DDWND,DDWI,DDWX,DDWX1,DDWX2
+2 KILL ^TMP("DDWB",$JOB)
+3 SET DDWND=0
+4 ;
+5 ;**
if DDWR2-DDWR1>50
DO MSG^DDW(" ...")
+6 ;
+7 FOR DDWI=DDWR1:1:$$MIN(DDWA,DDWR2)
Begin DoDot:1
+8 SET DDWND=DDWND+1
+9 SET DDWX=^TMP("DDW",$JOB,DDWI)
+10 SET DDWX=$EXTRACT(DDWX,$SELECT(DDWI=DDWR1:DDWC1,1:1),$SELECT(DDWI=DDWR2:DDWC2,1:999))
+11 SET ^TMP("DDWB",$JOB,DDWND)=DDWX
End DoDot:1
+12 ;
+13 FOR DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR)
Begin DoDot:1
+14 SET DDWX=$EXTRACT(DDWL(DDWI),$SELECT(DDWI+DDWA=DDWR1:DDWC1,1:1),$SELECT(DDWI+DDWA=DDWR2:DDWC2,1:999))
+15 SET DDWND=DDWND+1
+16 SET ^TMP("DDWB",$JOB,DDWND)=DDWX
End DoDot:1
+17 ;
+18 SET DDWX1=$$RTOSTB(DDWR1)
SET DDWX2=$$RTOSTB(DDWR2)
+19 FOR DDWI=$$MIN(DDWSTB,DDWX1):-1:DDWX2
Begin DoDot:1
+20 SET DDWND=DDWND+1
+21 SET DDWX=^TMP("DDW1",$JOB,DDWI)
+22 SET DDWX=$EXTRACT(DDWX,$SELECT(DDWI=DDWX1:DDWC1,1:1),$SELECT(DDWI=DDWX2:DDWC2,1:999))
+23 SET ^TMP("DDWB",$JOB,DDWND)=DDWX
End DoDot:1
+24 ;
+25 if DDWR2-DDWR1>50
DO MSG^DDW()
+26 QUIT
+27 ;
PASTE() ;Paste text
+1 IF $DATA(DDWMARK)
DO ERR("You curently have text selected.")
QUIT
+2 ;**
IF '$DATA(^TMP("DDWB",$JOB))
DO ERR($$EZBLD^DIALOG(1404))
QUIT
+3 ;
+4 SET DDWED=1
+5 NEW DDWBSIZ,DDWFC,DDWI,DDWLST,DDWNSV,DDWTXT,DDWX
+6 SET DDWBSIZ=$ORDER(^TMP("DDWB",$JOB,""),-1)
+7 ;
+8 SET DDWTXT=1
+9 if $LENGTH(DDWN)+1<DDWC
SET DDWN=DDWN_$JUSTIFY("",DDWC-$LENGTH(DDWN)-1)
+10 SET (DDWNSV,DDWX)=$EXTRACT(DDWN,1,DDWC-1)
+11 SET DDWTXT(1)=DDWX
+12 IF $LENGTH(DDWX)+$LENGTH(^TMP("DDWB",$JOB,1))<256!(DDWX="")
SET DDWTXT(1)=DDWTXT(1)_^(1)
+13 IF '$TEST
SET DDWTXT=DDWTXT+1
SET DDWTXT(DDWTXT)=^TMP("DDWB",$JOB,1)
+14 ;
+15 SET DDWLST=$EXTRACT(DDWN,DDWC,999)
+16 IF DDWRAP
IF DDWLST?1." "
SET DDWLST=""
+17 IF DDWLST]""
IF DDWBSIZ=1
SET DDWTXT=DDWTXT+1
SET DDWTXT(DDWTXT)=DDWLST
SET DDWLST=""
+18 ;
+19 if DDWTXT
DO ADJMAR^DDW6(.DDWTXT,"","I")
+20 SET (DDWN,DDWL(DDWRW))=DDWTXT(1)
+21 ;
+22 IF DDWBSIZ=1
IF DDWTXT=1
SET DDWFC=$LENGTH(DDWNSV)+$LENGTH(^TMP("DDWB",$JOB,1))+1
+23 IF '$TEST
IF DDWBSIZ=1
IF DDWTXT=2
IF DDWLST=""
SET DDWFC=$LENGTH(DDWTXT(2))+1
+24 IF '$TEST
SET DDWFC=1
+25 ;
+26 IF $$SCR(DDWFC)=$PIECE(DDWOFS,U,4)
Begin DoDot:1
+27 DO POS(DDWRW,$$MIN($LENGTH(DDWNSV),$LENGTH(DDWN))+1)
+28 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWN,$LENGTH(DDWNSV)+1,IOM+DDWOFS)
End DoDot:1
+29 ;
+30 DO POS(DDWRW,DDWFC,"R")
+31 ;
+32 FOR DDWI=2:1:DDWTXT
Begin DoDot:1
+33 DO ILINE^DDW5
+34 SET (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
+35 DO CUP(DDWRW,1)
+36 WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+37 ;
+38 FOR DDWI=2:1:DDWBSIZ
Begin DoDot:1
+39 DO ILINE^DDW5
+40 SET (DDWN,DDWL(DDWRW))=^TMP("DDWB",$JOB,DDWI)
+41 DO CUP(DDWRW,1)
+42 WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+43 ;
+44 IF DDWLST]""
Begin DoDot:1
+45 DO ILINE^DDW5
+46 SET (DDWN,DDWL(DDWRW))=DDWLST
+47 DO CUP(DDWRW,1)
+48 WRITE $EXTRACT(DDWN,1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+49 ;
+50 DO POS(DDWRW,DDWFC,"RN")
+51 QUIT
+52 ;
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 ;
ISINSEL() ;Is the cursor within the selected text
+1 NEW DDWI,DDWY
+2 SET DDWI=DDWRW+DDWA
SET DDWY=0
+3 IF DDWI<$PIECE(DDWMARK,U)
+4 IF '$TEST
IF DDWI>$PIECE(DDWMARK,U,3)
+5 IF '$TEST
IF DDWI=$PIECE(DDWMARK,U)
IF DDWC<$PIECE(DDWMARK,U,2)
+6 IF '$TEST
IF DDWI=$PIECE(DDWMARK,U,3)
IF DDWC-1>$PIECE(DDWMARK,U,4)
+7 IF '$TEST
SET DDWY=1
+8 QUIT DDWY
+9 ;
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 ;
ERR(DDWX) ;
+1 DO MSG^DDW($CHAR(7)_DDWX)
HANG 2
DO MSG^DDW()
+2 DO CUP(DDWRW,DDWC-DDWOFS)
+3 FOR
READ *DDWX:0
IF '$TEST
QUIT
+4 QUIT
+5 ;
TR(X) ;Strip trailing blanks
+1 if $GET(X)=""
QUIT X
+2 NEW I
+3 FOR I=$LENGTH(X):-1:0
if $EXTRACT(X,I)'=" "
QUIT
+4 QUIT $EXTRACT(X,1,I)
+5 ;
LD(X) ;Strip leading blanks
+1 if $GET(X)=""
QUIT X
+2 NEW I
+3 FOR I=1:1:$LENGTH(X)+1
if $EXTRACT(X,I)'=" "
QUIT
+4 QUIT $EXTRACT(X,I,999)
+5 ;
RTOSTB(R) ;Return node in STB given line #
+1 QUIT DDWSTB+DDWA+DDWMR+1-R
+2 ;
SCR(C) ;Return screen number
+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)
