- 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 Jan 18, 2025@03:43:19 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