DDGFEL ;SFISC/MKO-SELECT OR EDIT ELEMENT ;07:25 AM 7 Aug 1995
;;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.
;
SELECT ;Select an element
N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
D GETELEM(DY,DX) Q:$G(F)=""
;
I F="P" G ^DDGFAPC
;
;Clear and/or kill portions of DDGFREF
S:T="D" $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
K:T="C" @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C"),@DDGFREF@("F",DDGFPG,B,F)
K:$D(D) @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")
;
D COVER
G ^DDGF2
;
EDIT ;Edit a caption or data length
N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2,X,Y
D GETELEM(DY,DX) Q:"P"[$G(F)
;
S DDGFCHG=1
I T="C" D
. K D,D1,D2,D3,L
. S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)="^^^"
. K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")
. D COVER
. D
.. N DX,DY
.. S DY=IOSL-6,DX=IOM-9 X IOXY W "EDIT "
. ;
. N DDGFCOD,DDGFX
. D EN^DIR0(C1,C2,$L(C),1,C,"","","","KWT",.DDGFX,.DDGFCOD)
. S X=DDGFX
. I $P(DDGFCOD,U)="TO"!(X="!M") W $C(7) S X=C
. E I X["^" S X=C
. E X $P(^DD(.4044,1,0),U,5,999) I '$D(X) W $C(7) S X=C
. S C3=C2+$L(X)-1
. ;
. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
. D WRITE^DDGLIBW(DDGFWID,X,C1-P1,C2-P2)
. I $L(X)<$L(C) D REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C3+1-P2)_U_1_U_($L(C)-$L(X)))
. S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)=C1_U_C2_U_C3_U_X,$P(^(F),U,9)=1
;
I T="D" D
. K C,C1,C2,C3
. S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
. K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F)
. D COVER,^DDGFADL
. ;
. S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=D1_U_D2_U_D3_U_L,$P(^(F),U,9)=1
. S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
. D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
;
D RC(DY,DX)
Q
;
GETELEM(DY,DX) ;Which element is the cursor on
;Returns P,B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
;If on pop-up page border, return only B="P",F="P",T="PTOP" or "PBRC"
;Set P=page,B=Block,F=DDO,T=type ("D" or "C")
;If cursor is not on anything, $G(F)=""
;
Q:'$D(@DDGFREF@("RC",DDGFWID,DY))
N X1,X2,F1
S X1="" K F
F S X1=$O(@DDGFREF@("RC",DDGFWID,DY,X1)) Q:X1=""!(DX<X1) D
. S X2=""
. F S X2=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2)) Q:X2="" D Q:$G(F)
.. Q:DX>X2
.. S B=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,""))
.. S F=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,""))
.. S T=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,F,""))
Q:"P"[$G(F)
;
S P1=$P(DDGFLIM,U),P2=$P(DDGFLIM,U,2)
S F1=$G(@DDGFREF@("F",DDGFPG,B,F))
;
;Get caption, data, and coordinates
S C1=$P(F1,U),C2=$P(F1,U,2),C3=$P(F1,U,3),C=$P(F1,U,4)
I $P(F1,U,8)]"" D
. S D1=$P(F1,U,5),D2=$P(F1,U,6),D3=$P(F1,U,7)
. S L=$P(F1,U,8),D=$TR($J("",L)," ","_")
Q
;
COVER ;Look for covered (hidden) fields
;Input:
; T,C,C1,C2,P1,P2
;H(DDO) - array of hidden fields
;Erase the element we've selected from buffer
;Redraw the element(s) that were covered
N H,O,X1,X2,Y
F Y="C1","D1" D
. I Y="C1",T'="C" Q
. I Y="D1",'$D(D) Q
. S X1=""
. F S X1=$O(@DDGFREF@("RC",DDGFWID,@Y,X1)) Q:X1="" D
.. S X2=""
.. F S X2=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2)) Q:X2="" D
... N B
... S B=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,""))
... S O=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,B,""))
... I O]"",$D(H(O))[0 D
.... I T="C",$$OVERLAP(C2,C3,X1,X2) S H(O)=DDGFPG_U_B
.... E I $D(D),$$OVERLAP(D2,D3,X1,X2) S H(O)=DDGFPG_U_B
;
;Clear in buffer area occupied by element(s) selected
D:T="C" CLEAR(C,C1,C2,C3)
D:$D(D) CLEAR(D,D1,D2,D3)
;
;Write to buffer the overlapped field(s)
I $D(H) S H="" F S H=$O(H(H)) Q:H="" D
. S O=$G(@DDGFREF@("F",$P(H(H),U),$P(H(H),U,2),H)) Q:O=""
. D WRITE^DDGLIBW(DDGFWID,$P(O,U,4),$P(O,U)-P1,$P(O,U,2)-P2,"",1)
. I $P(O,U,8)>0 D WRITE^DDGLIBW(DDGFWID,$TR($J("",$P(O,U,8))," ","_"),$P(O,U,5)-P1,$P(O,U,6)-P2,"",1)
Q
;
OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2
N T
I A1<B1 S T=A1,A1=B1,B1=T,T=A2,A2=B2,B2=T
Q A1'<B1&(A1'>B2)!(A2'<B1&(A2'>B2))
;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
N S
I DDGFR D
. S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
. X IOXY W S_$J("",7-$L(S))
S DY=DDGFY,DX=DDGFX X IOXY
Q
;
CLEAR(C,C1,C2,C3) ;Clear in buffer area occupied by element(s) selected
;If on the page border, redraw the lines
N L
S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0))
D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
;
I $P(@DDGFREF@("F",DDGFPG),U,3) D
. I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D
.. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3))
.. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7))
.. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):6,1:8))
.. D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
. E I C2=$P(DDGFLIM,U,2) D
.. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
. E I C3'<$P(DDGFLIM,U,4) D
.. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFEL 5251 printed Sep 23, 2025@20:18:25 Page 2
DDGFEL ;SFISC/MKO-SELECT OR EDIT ELEMENT ;07:25 AM 7 Aug 1995
+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 ;
SELECT ;Select an element
+1 NEW B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
+2 DO GETELEM(DY,DX)
if $GET(F)=""
QUIT
+3 ;
+4 IF F="P"
GOTO ^DDGFAPC
+5 ;
+6 ;Clear and/or kill portions of DDGFREF
+7 if T="D"
SET $PIECE(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
+8 if T="C"
KILL @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C"),@DDGFREF@("F",DDGFPG,B,F)
+9 if $DATA(D)
KILL @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")
+10 ;
+11 DO COVER
+12 GOTO ^DDGF2
+13 ;
EDIT ;Edit a caption or data length
+1 NEW B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2,X,Y
+2 DO GETELEM(DY,DX)
if "P"[$GET(F)
QUIT
+3 ;
+4 SET DDGFCHG=1
+5 IF T="C"
Begin DoDot:1
+6 KILL D,D1,D2,D3,L
+7 SET $PIECE(@DDGFREF@("F",DDGFPG,B,F),U,1,4)="^^^"
+8 KILL @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")
+9 DO COVER
+10 Begin DoDot:2
+11 NEW DX,DY
+12 SET DY=IOSL-6
SET DX=IOM-9
XECUTE IOXY
WRITE "EDIT "
End DoDot:2
+13 ;
+14 NEW DDGFCOD,DDGFX
+15 DO EN^DIR0(C1,C2,$LENGTH(C),1,C,"","","","KWT",.DDGFX,.DDGFCOD)
+16 SET X=DDGFX
+17 IF $PIECE(DDGFCOD,U)="TO"!(X="!M")
WRITE $CHAR(7)
SET X=C
+18 IF '$TEST
IF X["^"
SET X=C
+19 IF '$TEST
XECUTE $PIECE(^DD(.4044,1,0),U,5,999)
IF '$DATA(X)
WRITE $CHAR(7)
SET X=C
+20 SET C3=C2+$LENGTH(X)-1
+21 ;
+22 SET @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
+23 DO WRITE^DDGLIBW(DDGFWID,X,C1-P1,C2-P2)
+24 IF $LENGTH(X)<$LENGTH(C)
DO REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C3+1-P2)_U_1_U_($LENGTH(C)-$LENGTH(X)))
+25 SET $PIECE(@DDGFREF@("F",DDGFPG,B,F),U,1,4)=C1_U_C2_U_C3_U_X
SET $PIECE(^(F),U,9)=1
End DoDot:1
+26 ;
+27 IF T="D"
Begin DoDot:1
+28 KILL C,C1,C2,C3
+29 SET $PIECE(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
+30 KILL @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F)
+31 DO COVER
DO ^DDGFADL
+32 ;
+33 SET $PIECE(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=D1_U_D2_U_D3_U_L
SET $PIECE(^(F),U,9)=1
+34 SET @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
+35 DO WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
End DoDot:1
+36 ;
+37 DO RC(DY,DX)
+38 QUIT
+39 ;
GETELEM(DY,DX) ;Which element is the cursor on
+1 ;Returns P,B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
+2 ;If on pop-up page border, return only B="P",F="P",T="PTOP" or "PBRC"
+3 ;Set P=page,B=Block,F=DDO,T=type ("D" or "C")
+4 ;If cursor is not on anything, $G(F)=""
+5 ;
+6 if '$DATA(@DDGFREF@("RC",DDGFWID,DY))
QUIT
+7 NEW X1,X2,F1
+8 SET X1=""
KILL F
+9 FOR
SET X1=$ORDER(@DDGFREF@("RC",DDGFWID,DY,X1))
if X1=""!(DX<X1)
QUIT
Begin DoDot:1
+10 SET X2=""
+11 FOR
SET X2=$ORDER(@DDGFREF@("RC",DDGFWID,DY,X1,X2))
if X2=""
QUIT
Begin DoDot:2
+12 if DX>X2
QUIT
+13 SET B=$ORDER(@DDGFREF@("RC",DDGFWID,DY,X1,X2,""))
+14 SET F=$ORDER(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,""))
+15 SET T=$ORDER(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,F,""))
End DoDot:2
if $GET(F)
QUIT
End DoDot:1
+16 if "P"[$GET(F)
QUIT
+17 ;
+18 SET P1=$PIECE(DDGFLIM,U)
SET P2=$PIECE(DDGFLIM,U,2)
+19 SET F1=$GET(@DDGFREF@("F",DDGFPG,B,F))
+20 ;
+21 ;Get caption, data, and coordinates
+22 SET C1=$PIECE(F1,U)
SET C2=$PIECE(F1,U,2)
SET C3=$PIECE(F1,U,3)
SET C=$PIECE(F1,U,4)
+23 IF $PIECE(F1,U,8)]""
Begin DoDot:1
+24 SET D1=$PIECE(F1,U,5)
SET D2=$PIECE(F1,U,6)
SET D3=$PIECE(F1,U,7)
+25 SET L=$PIECE(F1,U,8)
SET D=$TRANSLATE($JUSTIFY("",L)," ","_")
End DoDot:1
+26 QUIT
+27 ;
COVER ;Look for covered (hidden) fields
+1 ;Input:
+2 ; T,C,C1,C2,P1,P2
+3 ;H(DDO) - array of hidden fields
+4 ;Erase the element we've selected from buffer
+5 ;Redraw the element(s) that were covered
+6 NEW H,O,X1,X2,Y
+7 FOR Y="C1","D1"
Begin DoDot:1
+8 IF Y="C1"
IF T'="C"
QUIT
+9 IF Y="D1"
IF '$DATA(D)
QUIT
+10 SET X1=""
+11 FOR
SET X1=$ORDER(@DDGFREF@("RC",DDGFWID,@Y,X1))
if X1=""
QUIT
Begin DoDot:2
+12 SET X2=""
+13 FOR
SET X2=$ORDER(@DDGFREF@("RC",DDGFWID,@Y,X1,X2))
if X2=""
QUIT
Begin DoDot:3
+14 NEW B
+15 SET B=$ORDER(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,""))
+16 SET O=$ORDER(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,B,""))
+17 IF O]""
IF $DATA(H(O))[0
Begin DoDot:4
+18 IF T="C"
IF $$OVERLAP(C2,C3,X1,X2)
SET H(O)=DDGFPG_U_B
+19 IF '$TEST
IF $DATA(D)
IF $$OVERLAP(D2,D3,X1,X2)
SET H(O)=DDGFPG_U_B
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;
+21 ;Clear in buffer area occupied by element(s) selected
+22 if T="C"
DO CLEAR(C,C1,C2,C3)
+23 if $DATA(D)
DO CLEAR(D,D1,D2,D3)
+24 ;
+25 ;Write to buffer the overlapped field(s)
+26 IF $DATA(H)
SET H=""
FOR
SET H=$ORDER(H(H))
if H=""
QUIT
Begin DoDot:1
+27 SET O=$GET(@DDGFREF@("F",$PIECE(H(H),U),$PIECE(H(H),U,2),H))
if O=""
QUIT
+28 DO WRITE^DDGLIBW(DDGFWID,$PIECE(O,U,4),$PIECE(O,U)-P1,$PIECE(O,U,2)-P2,"",1)
+29 IF $PIECE(O,U,8)>0
DO WRITE^DDGLIBW(DDGFWID,$TRANSLATE($JUSTIFY("",$PIECE(O,U,8))," ","_"),$PIECE(O,U,5)-P1,$PIECE(O,U,6)-P2,"",1)
End DoDot:1
+30 QUIT
+31 ;
OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2
+1 NEW T
+2 IF A1<B1
SET T=A1
SET A1=B1
SET B1=T
SET T=A2
SET A2=B2
SET B2=T
+3 QUIT A1'<B1&(A1'>B2)!(A2'<B1&(A2'>B2))
+4 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
+1 NEW S
+2 IF DDGFR
Begin DoDot:1
+3 SET DY=IOSL-6
SET DX=IOM-9
SET S="R"_(DDGFY+1)_",C"_(DDGFX+1)
+4 XECUTE IOXY
WRITE S_$JUSTIFY("",7-$LENGTH(S))
End DoDot:1
+5 SET DY=DDGFY
SET DX=DDGFX
XECUTE IOXY
+6 QUIT
+7 ;
CLEAR(C,C1,C2,C3) ;Clear in buffer area occupied by element(s) selected
+1 ;If on the page border, redraw the lines
+2 NEW L
+3 SET L=$JUSTIFY("",$LENGTH(C)-$SELECT(C3>$PIECE(DDGFLIM,U,4):C3-$PIECE(DDGFLIM,U,4),1:0))
+4 DO WRITE^DDGLIBW(DDGFWID,L,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"",1)
+5 ;
+6 IF $PIECE(@DDGFREF@("F",DDGFPG),U,3)
Begin DoDot:1
+7 IF C1=$PIECE(DDGFLIM,U)!(C1=$PIECE(DDGFLIM,U,3))
Begin DoDot:2
+8 SET L=$TRANSLATE(L," ",$PIECE(DDGLGRA,DDGLDEL,3))
+9 if C2=$PIECE(DDGFLIM,U,2)
SET $EXTRACT(L)=$PIECE(DDGLGRA,DDGLDEL,$SELECT(C1=$PIECE(DDGFLIM,U):5,1:7))
+10 if C3'<$PIECE(DDGFLIM,U,4)
SET $EXTRACT(L,$LENGTH(L))=$PIECE(DDGLGRA,DDGLDEL,$SELECT(C1=$PIECE(DDGFLIM,U):6,1:8))
+11 DO WRITE^DDGLIBW(DDGFWID,L,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"G",1)
End DoDot:2
+12 IF '$TEST
IF C2=$PIECE(DDGFLIM,U,2)
Begin DoDot:2
+13 DO WRITE^DDGLIBW(DDGFWID,$PIECE(DDGLGRA,DDGLDEL,4),C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"G",1)
End DoDot:2
+14 IF '$TEST
IF C3'<$PIECE(DDGFLIM,U,4)
Begin DoDot:2
+15 DO WRITE^DDGLIBW(DDGFWID,$PIECE(DDGLGRA,DDGLDEL,4),C1-$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,4)-$PIECE(DDGFLIM,U,2),"G",1)
End DoDot:2
End DoDot:1
+16 QUIT
