DDGF4 ;SFISC/MKO-ACTIONS AFTER BLOCK SELECTION ;02:49 PM 12 Oct 1994
;;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.
;
;Input:
; B = Block number
; C = Block name
; C1 = Block $Y
; C2 = Block $X1
; C3 = Block $X2
; DDGFHDR = 1, if block is immobile (header block)
;
N DDGFE
S:'$G(DDGFHDR) DDGFHDR=0
D PAINTS
;
S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE
D CLEANUP
Q
;
LNU Q:C1'>$P(DDGFLIM,U)!DDGFHDR
D REDRAW
S C1=C1-1,DY=DY-1
D PAINTS
Q
LND Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR
D REDRAW
S C1=C1+1,DY=DY+1
D PAINTS
Q
CHR Q:C2'<$P(DDGFLIM,U,4)!DDGFHDR
D REDRAW
S C2=C2+1,DX=DX+1
D PAINTS
Q
CHL Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
D REDRAW
S C2=C2-1,DX=DX-1
D PAINTS
Q
TBR N X
Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR
D REDRAW
S X=$$MIN(5,$P(DDGFLIM,U,4)-C2-$L(C)+1)
S C2=C2+X,DX=DX+X
D PAINTS
Q
TBL N X
Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
D REDRAW
S X=$$MIN(5,C2-$P(DDGFLIM,U,2))
S C2=C2-X,DX=DX-X
D PAINTS
Q
SCT Q:C1'>$P(DDGFLIM,U)!DDGFHDR
D REDRAW
S (C1,DY)=$P(DDGFLIM,U)
D PAINTS
Q
SCB Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR
D REDRAW
S (C1,DY)=$P(DDGFLIM,U,3)
D PAINTS
Q
SCR N X
Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR
D REDRAW
S X=$P(DDGFLIM,U,4)-C2-$L(C)+1
S C2=C2+X,DX=DX+X
D PAINTS
Q
SCL N X
Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
D REDRAW
S X=C2-$P(DDGFLIM,U,2)
S C2=C2-X,DX=DX-X
D PAINTS
Q
;
EDIT ;Edit block parameters
G:'$G(DDGFHDR) EDIT^DDGFBK
G EDIT^DDGFHBK
;
REORDER ;Reorder fields on block
D EN^DDGFORD(B)
Q
;
TO ;Time-out
W $C(7)
G DESELECT
;
DESELECT ;
S DDGFE=1
Q
;
CLEANUP ;
I '$G(DDGFBDEL) D
. S C3=C2+$L(C)-1
. S @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1,DDGFCHG=1
. S @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$S($G(DDGFHDR):"H",1:"")
;
I '$G(DDGFEBV),'$G(DDGFBDEL) D
. D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2))
. X IOXY
K DDGFHDR,DDGFBDEL
Q
;
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
;
REDRAW ;
D REPAINT^DDGLIBW(DDGFWIDB,(C1-$P(DDGFLIM,U))_U_(C2-$P(DDGFLIM,U,2))_U_1_U_$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))
Q
;
PAINTS ;
N Y,X
S Y=DY,X=DX
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)
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[HDDGF4 3208 printed Dec 13, 2024@02:42:14 Page 2
DDGF4 ;SFISC/MKO-ACTIONS AFTER BLOCK SELECTION ;02:49 PM 12 Oct 1994
+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 ;
+7 ;Input:
+8 ; B = Block number
+9 ; C = Block name
+10 ; C1 = Block $Y
+11 ; C2 = Block $X1
+12 ; C3 = Block $X2
+13 ; DDGFHDR = 1, if block is immobile (header block)
+14 ;
+15 NEW DDGFE
+16 if '$GET(DDGFHDR)
SET DDGFHDR=0
+17 DO PAINTS
+18 ;
+19 SET DDGFE=0
FOR
SET Y=$$READ
if $TEXT(@Y)=""
WRITE $CHAR(7)
if $TEXT(@Y)]""
DO @Y
if DDGFE
QUIT
+20 DO CLEANUP
+21 QUIT
+22 ;
LNU if C1'>$PIECE(DDGFLIM,U)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET C1=C1-1
SET DY=DY-1
+3 DO PAINTS
+4 QUIT
LND if C1'<$PIECE(DDGFLIM,U,3)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET C1=C1+1
SET DY=DY+1
+3 DO PAINTS
+4 QUIT
CHR if C2'<$PIECE(DDGFLIM,U,4)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET C2=C2+1
SET DX=DX+1
+3 DO PAINTS
+4 QUIT
CHL if C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET C2=C2-1
SET DX=DX-1
+3 DO PAINTS
+4 QUIT
TBR NEW X
+1 if C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)!DDGFHDR
QUIT
+2 DO REDRAW
+3 SET X=$$MIN(5,$PIECE(DDGFLIM,U,4)-C2-$LENGTH(C)+1)
+4 SET C2=C2+X
SET DX=DX+X
+5 DO PAINTS
+6 QUIT
TBL NEW X
+1 if C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR
QUIT
+2 DO REDRAW
+3 SET X=$$MIN(5,C2-$PIECE(DDGFLIM,U,2))
+4 SET C2=C2-X
SET DX=DX-X
+5 DO PAINTS
+6 QUIT
SCT if C1'>$PIECE(DDGFLIM,U)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET (C1,DY)=$PIECE(DDGFLIM,U)
+3 DO PAINTS
+4 QUIT
SCB if C1'<$PIECE(DDGFLIM,U,3)!DDGFHDR
QUIT
+1 DO REDRAW
+2 SET (C1,DY)=$PIECE(DDGFLIM,U,3)
+3 DO PAINTS
+4 QUIT
SCR NEW X
+1 if C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)!DDGFHDR
QUIT
+2 DO REDRAW
+3 SET X=$PIECE(DDGFLIM,U,4)-C2-$LENGTH(C)+1
+4 SET C2=C2+X
SET DX=DX+X
+5 DO PAINTS
+6 QUIT
SCL NEW X
+1 if C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR
QUIT
+2 DO REDRAW
+3 SET X=C2-$PIECE(DDGFLIM,U,2)
+4 SET C2=C2-X
SET DX=DX-X
+5 DO PAINTS
+6 QUIT
+7 ;
EDIT ;Edit block parameters
+1 if '$GET(DDGFHDR)
GOTO EDIT^DDGFBK
+2 GOTO EDIT^DDGFHBK
+3 ;
REORDER ;Reorder fields on block
+1 DO EN^DDGFORD(B)
+2 QUIT
+3 ;
TO ;Time-out
+1 WRITE $CHAR(7)
+2 GOTO DESELECT
+3 ;
DESELECT ;
+1 SET DDGFE=1
+2 QUIT
+3 ;
CLEANUP ;
+1 IF '$GET(DDGFBDEL)
Begin DoDot:1
+2 SET C3=C2+$LENGTH(C)-1
+3 SET @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1
SET DDGFCHG=1
+4 SET @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$SELECT($GET(DDGFHDR):"H",1:"")
End DoDot:1
+5 ;
+6 IF '$GET(DDGFEBV)
IF '$GET(DDGFBDEL)
Begin DoDot:1
+7 DO WRITE^DDGLIBW(DDGFWIDB,C,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2))
+8 XECUTE IOXY
End DoDot:1
+9 KILL DDGFHDR,DDGFBDEL
+10 QUIT
+11 ;
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 ;
REDRAW ;
+1 DO REPAINT^DDGLIBW(DDGFWIDB,(C1-$PIECE(DDGFLIM,U))_U_(C2-$PIECE(DDGFLIM,U,2))_U_1_U_$$MIN($LENGTH(C),$PIECE(DDGFLIM,U,4)-C2+1))
+2 QUIT
+3 ;
PAINTS ;
+1 NEW Y,X
+2 SET Y=DY
SET X=DX
+3 SET DY=C1
SET DX=C2
XECUTE IOXY
+4 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(C,1,$$MIN($LENGTH(C),$PIECE(DDGFLIM,U,4)-C2+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
