DDGF2 ;SFISC/MKO - ACTIONS FOR SELECTED FIELDS ;1FEB2017
;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
;;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.
;GFT;**1055,1057**
;
;Input:
; B = internal block number
; F = internal field order
; T = type of element ("C" = caption, "D" = data)
; C = caption
; C1 = $Y of caption
; C2 = $X of caption
; D = data representation (underlines)
; D1 = $Y of data
; D2 = $X of data
; L = length of data
; P1 = page $Y
; P2 = page $X
; DDGFWID = "P1" or such
N DDGFE
S DDGFE=0,DDGFLSV=DDGFLIM
S DDGFLIM=$P(@DDGFREF@("F",DDGFPG,B),U,1,2)_U_$P(DDGFLIM,U,3,4)
;
D PAINTS
S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE ;MOVE THE FIELD AROUND UNTIL SPACEBAR DESELECTS IT.
D END
D:$G(DDGFSUBP) SUBPG1^DDGFPG
Q
;
END ;Redraw field 'F' on block 'B'
S DDGFLIM=DDGFLSV K DDGFLSV
Q:$D(^DIST(.404,B,40,F,0))[0
N OLD,NEW,CAP,DATA S (NEW,OLD)=$G(^(2)),CAP=$P(NEW,U,3),DATA=$P(NEW,U,1)
;^DIST(.404,D0,40,D1,2)= (#4.1) DATA COORDINATE [1F] ^ (#4.2) DATA LENGTH [2N] ^ (#5.1) CAPTION COORDINATE [3F] ^ (#5.2) SUPPRESS COLON AFTER CAPTION? [4S]
S $P(NEW,U,2)=$G(L) ;LENGTH WILL NOT BE THERE, IF THIS IS A CAPTION
S $P(CAP,",",1)=C1+1,$P(CAP,",",2)=C2+1
S C3=C2+$L(C)-1 ;CAPTION END POINT
I T="C",C]"" D
. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2)
. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
;
I $D(D) D
. S $P(DATA,",",1)=D1+1,$P(DATA,",",2)=D2+1
. S D3=D2+L-1 ;DATA END POINT
. D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
. S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
;
S @DDGFREF@("F",DDGFPG,B,F)=C1_U_C2_U_C3_U_C_U_$S($D(D):D1_U_D2_U_D3_U_L,1:"^^^")_U_1,DDGFCHG=1
D KILLPGS^DDGFFLDA(B,DDGFWID) ;BLOCK MAY BE ON ANOTHER PAGE
;
X IOXY
Q
;
TO ;Time-out
W $C(7)
G DESELECT
;
DESELECT ;SPACE-BAR HAS DESELECTED FIELD
S DDGFE=1
Q
;
LNU I T="C" Q:C1'>$P(DDGFLIM,U) ;LINE FEED UP
I $D(D),D1'>$P(DDGFLIM,U) Q
D REDRAW S:T="C" C1=C1-1
S:$D(D) D1=D1-1
S DY=DY-1
D PAINTS
Q
LND I T="C" Q:C1'<$P(DDGFLIM,U,3) ;LINE FEED DOWN
I $D(D),D1'<$P(DDGFLIM,U,3) Q
D REDRAW
S:T="C" C1=C1+1
S:$D(D) D1=D1+1
S DY=DY+1
D PAINTS
Q
CHR I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
I $D(D),D2+L>$P(DDGFLIM,U,4) Q
D REDRAW S:T="C" C2=C2+1
S:$D(D) D2=D2+1
S DX=DX+1
D PAINTS
Q
CHL I T="C" Q:C2'>$P(DDGFLIM,U,2)
I $D(D),D2'>$P(DDGFLIM,U,2) Q
D REDRAW S:T="C" C2=C2-1
S:$D(D) D2=D2-1
S DX=DX-1
D PAINTS
Q
TBR N X
I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
I $D(D),D2+L>$P(DDGFLIM,U,4) Q
D REDRAW
I T="C" D
. S X=$$MIN(5,$P(DDGFLIM,U,4)-(C2+$L(C)),$S($D(D):$P(DDGFLIM,U,4)-(D2+L)+1,1:""))
. S C2=C2+X
E S X=$$MIN(5,$P(DDGFLIM,U,4)-(D2+L)+1)
S:$D(D) D2=D2+X
S DX=DX+X
D PAINTS
Q
TBL N X
I T="C" Q:C2'>$P(DDGFLIM,U,2)
I $D(D),D2'>$P(DDGFLIM,U,2) Q
D REDRAW
I T="C" D
. S X=$$MIN(5,C2-$P(DDGFLIM,U,2),$S($D(D):D2-$P(DDGFLIM,U,2),1:""))
. S C2=C2-X
E S X=$$MIN(5,D2-$P(DDGFLIM,U,2))
S:$D(D) D2=D2-X
S DX=DX-X
D PAINTS
Q
SCT N Y
I T="C" Q:C1'>$P(DDGFLIM,U)
I $D(D),D1'>$P(DDGFLIM,U) Q
D REDRAW
I T="C" S Y=$S('$D(D):C1,C1<D1:C1,1:D1)-$P(DDGFLIM,U),C1=C1-Y
E S Y=D1-$P(DDGFLIM,U)
S:$D(D) D1=D1-Y
S DY=DY-Y
D PAINTS
Q
SCB N Y
I T="C" Q:C1'<$P(DDGFLIM,U,3)
I $D(D),D1'<$P(DDGFLIM,U,3) Q
D REDRAW
I T="C" S Y=$P(DDGFLIM,U,3)-$S('$D(D):C1,C1>D1:C1,1:D1),C1=C1+Y
E S Y=$P(DDGFLIM,U,3)-D1
S:$D(D) D1=D1+Y
S DY=DY+Y
D PAINTS
Q
SCR N X
I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
I $D(D),D2+L>$P(DDGFLIM,U,4) Q
D REDRAW
I T="C" D
. S X=$P(DDGFLIM,U,4)-$S('$D(D):C2+$L(C),C2+$L(C)>(D2+L):C2+$L(C),1:D2+L)+1
. S C2=C2+X
E S X=$P(DDGFLIM,U,4)-(D2+L)+1
S:$D(D) D2=D2+X
S DX=DX+X
D PAINTS
Q
SCL N X
I T="C" Q:C2'>$P(DDGFLIM,U,2)
I $D(D),D2'>$P(DDGFLIM,U,2) Q
D REDRAW
I T="C" S X=$S('$D(D):C2,C2<D2:C2,1:D2)-$P(DDGFLIM,U,2),C2=C2-X
E S X=D2-$P(DDGFLIM,U,2)
S:$D(D) D2=D2-X
S DX=DX-X
D PAINTS
Q
EDIT ;A SEPARATE SCREENMAN FORM WILL EDIT THIS SINGLE FIELD
G EDIT^DDGFFLD
SUBPG ;
G SUBPG^DDGFPG
;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
N DDGFS
I DDGFR D
. S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
. X IOXY W DDGFS_$J("",7-$L(DDGFS))
S DY=DDGFY,DX=DDGFX X IOXY
Q
;
REDRAW ;
D:T="C" REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C2-P2)_U_1_U_$L(C))
D:$D(D) REPAINT^DDGLIBW(DDGFWID,(D1-P1)_U_(D2-P2)_U_1_U_L)
Q
;
PAINTS ;
N Y,X
S Y=DY,X=DX
I T="C" S DY=C1,DX=C2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10)
I $D(D) S DY=D1,DX=D2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(D,1,$$MIN(L,$P(DDGFLIM,U,4)-D2+1))_$P(DDGLVID,DDGLDEL,10)
D RC(Y,X)
Q
;
MIN(X,Y,Z) ;Return the minimum of two or three numbers
N A
S A=$S(X<Y:X,1:Y)
Q:$G(Z)="" A
Q $S(A<Z:A,1:Z)
;
READ() N S,Y
F R *Y:DTIME D C Q:Y'=-1
Q Y
;
C I Y<0 S Y="TO" Q
S S=""
C1 S S=S_$C(Y)
I DDGF("SIN")'[(U_S) D I Y=-1 W $C(7) Q
. I $C(Y)'?1L S Y=-1 Q
. S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("SIN")'[(U_S_U) Y=-1
;
I DDGF("SIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("SOUT"),U,$L($P(DDGF("SIN"),U_S_U),U)) Q
R *Y:5 G:Y'=-1 C1 W $C(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGF2 5421 printed Sep 23, 2025@20:18:18 Page 2
DDGF2 ;SFISC/MKO - ACTIONS FOR SELECTED FIELDS ;1FEB2017
+1 ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
+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 ;GFT;**1055,1057**
+7 ;
+8 ;Input:
+9 ; B = internal block number
+10 ; F = internal field order
+11 ; T = type of element ("C" = caption, "D" = data)
+12 ; C = caption
+13 ; C1 = $Y of caption
+14 ; C2 = $X of caption
+15 ; D = data representation (underlines)
+16 ; D1 = $Y of data
+17 ; D2 = $X of data
+18 ; L = length of data
+19 ; P1 = page $Y
+20 ; P2 = page $X
+21 ; DDGFWID = "P1" or such
+22 NEW DDGFE
+23 SET DDGFE=0
SET DDGFLSV=DDGFLIM
+24 SET DDGFLIM=$PIECE(@DDGFREF@("F",DDGFPG,B),U,1,2)_U_$PIECE(DDGFLIM,U,3,4)
+25 ;
+26 DO PAINTS
+27 ;MOVE THE FIELD AROUND UNTIL SPACEBAR DESELECTS IT.
SET DDGFE=0
FOR
SET Y=$$READ
if $TEXT(@Y)=""
WRITE $CHAR(7)
if $TEXT(@Y)]""
DO @Y
if DDGFE
QUIT
+28 DO END
+29 if $GET(DDGFSUBP)
DO SUBPG1^DDGFPG
+30 QUIT
+31 ;
END ;Redraw field 'F' on block 'B'
+1 SET DDGFLIM=DDGFLSV
KILL DDGFLSV
+2 if $DATA(^DIST(.404,B,40,F,0))[0
QUIT
+3 NEW OLD,NEW,CAP,DATA
SET (NEW,OLD)=$GET(^(2))
SET CAP=$PIECE(NEW,U,3)
SET DATA=$PIECE(NEW,U,1)
+4 ;^DIST(.404,D0,40,D1,2)= (#4.1) DATA COORDINATE [1F] ^ (#4.2) DATA LENGTH [2N] ^ (#5.1) CAPTION COORDINATE [3F] ^ (#5.2) SUPPRESS COLON AFTER CAPTION? [4S]
+5 ;LENGTH WILL NOT BE THERE, IF THIS IS A CAPTION
SET $PIECE(NEW,U,2)=$GET(L)
+6 SET $PIECE(CAP,",",1)=C1+1
SET $PIECE(CAP,",",2)=C2+1
+7 ;CAPTION END POINT
SET C3=C2+$LENGTH(C)-1
+8 IF T="C"
IF C]""
Begin DoDot:1
+9 DO WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2)
+10 SET @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
End DoDot:1
+11 ;
+12 IF $DATA(D)
Begin DoDot:1
+13 SET $PIECE(DATA,",",1)=D1+1
SET $PIECE(DATA,",",2)=D2+1
+14 ;DATA END POINT
SET D3=D2+L-1
+15 DO WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
+16 SET @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
End DoDot:1
+17 ;
+18 SET @DDGFREF@("F",DDGFPG,B,F)=C1_U_C2_U_C3_U_C_U_$SELECT($DATA(D):D1_U_D2_U_D3_U_L,1:"^^^")_U_1
SET DDGFCHG=1
+19 ;BLOCK MAY BE ON ANOTHER PAGE
DO KILLPGS^DDGFFLDA(B,DDGFWID)
+20 ;
+21 XECUTE IOXY
+22 QUIT
+23 ;
TO ;Time-out
+1 WRITE $CHAR(7)
+2 GOTO DESELECT
+3 ;
DESELECT ;SPACE-BAR HAS DESELECTED FIELD
+1 SET DDGFE=1
+2 QUIT
+3 ;
LNU ;LINE FEED UP
IF T="C"
if C1'>$PIECE(DDGFLIM,U)
QUIT
+1 IF $DATA(D)
IF D1'>$PIECE(DDGFLIM,U)
QUIT
+2 DO REDRAW
if T="C"
SET C1=C1-1
+3 if $DATA(D)
SET D1=D1-1
+4 SET DY=DY-1
+5 DO PAINTS
+6 QUIT
LND ;LINE FEED DOWN
IF T="C"
if C1'<$PIECE(DDGFLIM,U,3)
QUIT
+1 IF $DATA(D)
IF D1'<$PIECE(DDGFLIM,U,3)
QUIT
+2 DO REDRAW
+3 if T="C"
SET C1=C1+1
+4 if $DATA(D)
SET D1=D1+1
+5 SET DY=DY+1
+6 DO PAINTS
+7 QUIT
CHR IF T="C"
if C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)
QUIT
+1 IF $DATA(D)
IF D2+L>$PIECE(DDGFLIM,U,4)
QUIT
+2 DO REDRAW
if T="C"
SET C2=C2+1
+3 if $DATA(D)
SET D2=D2+1
+4 SET DX=DX+1
+5 DO PAINTS
+6 QUIT
CHL IF T="C"
if C2'>$PIECE(DDGFLIM,U,2)
QUIT
+1 IF $DATA(D)
IF D2'>$PIECE(DDGFLIM,U,2)
QUIT
+2 DO REDRAW
if T="C"
SET C2=C2-1
+3 if $DATA(D)
SET D2=D2-1
+4 SET DX=DX-1
+5 DO PAINTS
+6 QUIT
TBR NEW X
+1 IF T="C"
if C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)
QUIT
+2 IF $DATA(D)
IF D2+L>$PIECE(DDGFLIM,U,4)
QUIT
+3 DO REDRAW
+4 IF T="C"
Begin DoDot:1
+5 SET X=$$MIN(5,$PIECE(DDGFLIM,U,4)-(C2+$LENGTH(C)),$SELECT($DATA(D):$PIECE(DDGFLIM,U,4)-(D2+L)+1,1:""))
+6 SET C2=C2+X
End DoDot:1
+7 IF '$TEST
SET X=$$MIN(5,$PIECE(DDGFLIM,U,4)-(D2+L)+1)
+8 if $DATA(D)
SET D2=D2+X
+9 SET DX=DX+X
+10 DO PAINTS
+11 QUIT
TBL NEW X
+1 IF T="C"
if C2'>$PIECE(DDGFLIM,U,2)
QUIT
+2 IF $DATA(D)
IF D2'>$PIECE(DDGFLIM,U,2)
QUIT
+3 DO REDRAW
+4 IF T="C"
Begin DoDot:1
+5 SET X=$$MIN(5,C2-$PIECE(DDGFLIM,U,2),$SELECT($DATA(D):D2-$PIECE(DDGFLIM,U,2),1:""))
+6 SET C2=C2-X
End DoDot:1
+7 IF '$TEST
SET X=$$MIN(5,D2-$PIECE(DDGFLIM,U,2))
+8 if $DATA(D)
SET D2=D2-X
+9 SET DX=DX-X
+10 DO PAINTS
+11 QUIT
SCT NEW Y
+1 IF T="C"
if C1'>$PIECE(DDGFLIM,U)
QUIT
+2 IF $DATA(D)
IF D1'>$PIECE(DDGFLIM,U)
QUIT
+3 DO REDRAW
+4 IF T="C"
SET Y=$SELECT('$DATA(D):C1,C1<D1:C1,1:D1)-$PIECE(DDGFLIM,U)
SET C1=C1-Y
+5 IF '$TEST
SET Y=D1-$PIECE(DDGFLIM,U)
+6 if $DATA(D)
SET D1=D1-Y
+7 SET DY=DY-Y
+8 DO PAINTS
+9 QUIT
SCB NEW Y
+1 IF T="C"
if C1'<$PIECE(DDGFLIM,U,3)
QUIT
+2 IF $DATA(D)
IF D1'<$PIECE(DDGFLIM,U,3)
QUIT
+3 DO REDRAW
+4 IF T="C"
SET Y=$PIECE(DDGFLIM,U,3)-$SELECT('$DATA(D):C1,C1>D1:C1,1:D1)
SET C1=C1+Y
+5 IF '$TEST
SET Y=$PIECE(DDGFLIM,U,3)-D1
+6 if $DATA(D)
SET D1=D1+Y
+7 SET DY=DY+Y
+8 DO PAINTS
+9 QUIT
SCR NEW X
+1 IF T="C"
if C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)
QUIT
+2 IF $DATA(D)
IF D2+L>$PIECE(DDGFLIM,U,4)
QUIT
+3 DO REDRAW
+4 IF T="C"
Begin DoDot:1
+5 SET X=$PIECE(DDGFLIM,U,4)-$SELECT('$DATA(D):C2+$LENGTH(C),C2+$LENGTH(C)>(D2+L):C2+$LENGTH(C),1:D2+L)+1
+6 SET C2=C2+X
End DoDot:1
+7 IF '$TEST
SET X=$PIECE(DDGFLIM,U,4)-(D2+L)+1
+8 if $DATA(D)
SET D2=D2+X
+9 SET DX=DX+X
+10 DO PAINTS
+11 QUIT
SCL NEW X
+1 IF T="C"
if C2'>$PIECE(DDGFLIM,U,2)
QUIT
+2 IF $DATA(D)
IF D2'>$PIECE(DDGFLIM,U,2)
QUIT
+3 DO REDRAW
+4 IF T="C"
SET X=$SELECT('$DATA(D):C2,C2<D2:C2,1:D2)-$PIECE(DDGFLIM,U,2)
SET C2=C2-X
+5 IF '$TEST
SET X=D2-$PIECE(DDGFLIM,U,2)
+6 if $DATA(D)
SET D2=D2-X
+7 SET DX=DX-X
+8 DO PAINTS
+9 QUIT
EDIT ;A SEPARATE SCREENMAN FORM WILL EDIT THIS SINGLE FIELD
+1 GOTO EDIT^DDGFFLD
SUBPG ;
+1 GOTO SUBPG^DDGFPG
+2 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
+1 NEW DDGFS
+2 IF DDGFR
Begin DoDot:1
+3 SET DY=IOSL-6
SET DX=IOM-9
SET DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
+4 XECUTE IOXY
WRITE DDGFS_$JUSTIFY("",7-$LENGTH(DDGFS))
End DoDot:1
+5 SET DY=DDGFY
SET DX=DDGFX
XECUTE IOXY
+6 QUIT
+7 ;
REDRAW ;
+1 if T="C"
DO REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C2-P2)_U_1_U_$LENGTH(C))
+2 if $DATA(D)
DO REPAINT^DDGLIBW(DDGFWID,(D1-P1)_U_(D2-P2)_U_1_U_L)
+3 QUIT
+4 ;
PAINTS ;
+1 NEW Y,X
+2 SET Y=DY
SET X=DX
+3 IF T="C"
SET DY=C1
SET DX=C2
XECUTE IOXY
WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(C,1,$$MIN($LENGTH(C),$PIECE(DDGFLIM,U,4)-C2+1))_$PIECE(DDGLVID,DDGLDEL,10)
+4 IF $DATA(D)
SET DY=D1
SET DX=D2
XECUTE IOXY
WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(D,1,$$MIN(L,$PIECE(DDGFLIM,U,4)-D2+1))_$PIECE(DDGLVID,DDGLDEL,10)
+5 DO RC(Y,X)
+6 QUIT
+7 ;
MIN(X,Y,Z) ;Return the minimum of two or three numbers
+1 NEW A
+2 SET A=$SELECT(X<Y:X,1:Y)
+3 if $GET(Z)=""
QUIT A
+4 QUIT $SELECT(A<Z:A,1:Z)
+5 ;
READ() NEW S,Y
+1 FOR
READ *Y:DTIME
DO C
if Y'=-1
QUIT
+2 QUIT Y
+3 ;
C IF Y<0
SET Y="TO"
QUIT
+1 SET S=""
C1 SET S=S_$CHAR(Y)
+1 IF DDGF("SIN")'[(U_S)
Begin DoDot:1
+2 IF $CHAR(Y)'?1L
SET Y=-1
QUIT
+3 SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)
if DDGF("SIN")'[(U_S_U)
SET Y=-1
End DoDot:1
IF Y=-1
WRITE $CHAR(7)
QUIT
+4 ;
+5 IF DDGF("SIN")[(U_S_U)
IF S'=$CHAR(27)
SET Y=$PIECE(DDGF("SOUT"),U,$LENGTH($PIECE(DDGF("SIN"),U_S_U),U))
QUIT
+6 READ *Y:5
if Y'=-1
GOTO C1
WRITE $CHAR(7)
+7 QUIT
