DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 PM 13 Sep 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.
;
ADD ;Add a new block
N B,C1,C2,C3
S DDGFDY=DY,DDGFDX=DX
;
;Invoke form to enter block name
K DDGFBNUM,DDGFBNAM
D DDS(.404,"[DDGF BLOCK ADD]")
G:'$D(DDGFBNUM) ADDQ
;
;Ask whether block should be added or indicate duplicate block
K DDGFANS
S DDSPAGE=$S($P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$D(^(40,"B",DDGFBNUM)):21,1:11)
D DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
G:DDSPAGE=21 ADDQ
I '$G(DDGFANS) D G ADDQ
. I $D(^DIST(.404,DDGFBNUM,0))#2,'$P(^(0),U,2) D
.. N DIK,DA
.. S DIK="^DIST(.404,",DA=DDGFBNUM
.. D ^DIK
K DDSPAGE,DDGFANS
;
;Add block to page
S DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,",DIC(0)="L"
S DA(2)=+DDGFFM,DA(1)=DDGFPG
S DIC("P")=$P(^DD(.4031,40,0),U,2)
S (DINUM,X)=DDGFBNUM
K DO,DD D FILE^DICN K DINUM,X
G:Y=-1 ADDQ
;
;Stuff in values for block order, coordinates, and type
S DIE=DIC,DA=+Y
S DDGFC=DDGFDY-$P(DDGFLIM,U)+1_","_(DDGFDX-$P(DDGFLIM,U,2)+1)
S DR="1////"_($O(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
D ^DIE K DA,DIC,DIE,DR,X,Y,DDGFC
;
;If this looks like a brand new block, stuff in DD number
I $L(^DIST(.404,DDGFBNUM,0),U)=1,'$O(^(0)) D
. S DIE="^DIST(.404,",DA=DDGFBNUM
. S DR="1////"_$P(^DIST(.403,+DDGFFM,0),U,8)
. D ^DIE K DA,DIE,DR
;
D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
;
S DY=DDGFDY,DX=DDGFDX
S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
S C1=DY,C2=DX,C3=C2+$L(DDGFBNAM)-1
S DDGFADD=1
K DDGFBNUM,DDGFBNAM
S:$G(DDGFBV) DDGFORIG(B)=DY_U_DX
G EDIT
;
ADDQ ;Adding aborted
D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
K DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
Q
;
EDIT ;Edit block
;In: B,C1,C2,C3,C
S DDGFDY=DY,DDGFDX=DX
S DDGFBK=B,DDGFC1=C1,DDGFC2=C2,DDGFC3=C3
S DDGFBKCO=C1-$P(DDGFLIM,U)+1_","_(C2-$P(DDGFLIM,U,2)+1)
S DDGFBKNO=C
;
;Invoke form to edit block
S DDSFILE=.403,DDSFILE(1)=.4032
S DA(2)=+DDGFFM,DA(1)=DDGFPG,DA=B
S DR="[DDGF BLOCK EDIT]",DDSPARM="KTW"
D ^DDS K DDSFILE,DA,DR,DDSPARM
;
;If block was deleted, remove data from DDGFREF
I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0 D DELETE(DDGFBK) G EDITQ
;
S:$D(DDGFBKCN)[0 DDGFBKCN=DDGFBKCO
S:$D(DDGFBKNN)[0 DDGFBKNN=DDGFBKNO
;
S C=DDGFBKNN
S C1=$P(DDGFBKCN,",")-1+$P(DDGFLIM,U)
S C2=$P(DDGFBKCN,",",2)-1+$P(DDGFLIM,U,2)
S C3=C2+$L(C)-1
;
;Update TMP if coordinates or name changed, or new block
I DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$G(DDGFADD) D
. D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),DDGFC1-$P(DDGFLIM,U),DDGFC2-$P(DDGFLIM,U,2),"",1)
. D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
;
EDITQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
S:'$G(DDGFADD) DDGFE=1
K DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
K DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
Q
;
DELETE(B,E) ;Remove block from DDGFREF
;E : means don't set DDGFEBV or DDGFBDEL
; (used by EDIT^DDGFHBK when a different header block is chosen)
N F,N
;Remove from TMP
S F="" F S F=$O(@DDGFREF@("F",DDGFPG,B,F)) Q:F="" D
. S N=@DDGFREF@("F",DDGFPG,B,F)
. K:$P(N,U,4)]"" @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B)
. K:$P(N,U,8)>0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B)
K @DDGFREF@("F",DDGFPG,B)
;
;If no blocks on page, set DDGFEBV to exit Block Viewer
;DDGFBDEL indicates block name should not be painted
I $G(DDGFBV) D:'$G(E)
. I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1
. S DDGFBDEL=1
E D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
;
;If used on no other forms, ask whether to delete from block file
I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D
. K DDGFANS S DDGFBK=B
. D DDS(.404,"[DDGF BLOCK DELETE]")
. I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA
. K DDGFANS,DDGFBK
Q
;
DDS(DDSFILE,DR,DA,DDSPAGE) ;
;Call DDS
S DDSPARM="KTW" D ^DDS K DDSPARM
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFBK 4512 printed Sep 23, 2025@20:18:23 Page 2
DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 PM 13 Sep 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 ;
ADD ;Add a new block
+1 NEW B,C1,C2,C3
+2 SET DDGFDY=DY
SET DDGFDX=DX
+3 ;
+4 ;Invoke form to enter block name
+5 KILL DDGFBNUM,DDGFBNAM
+6 DO DDS(.404,"[DDGF BLOCK ADD]")
+7 if '$DATA(DDGFBNUM)
GOTO ADDQ
+8 ;
+9 ;Ask whether block should be added or indicate duplicate block
+10 KILL DDGFANS
+11 SET DDSPAGE=$SELECT($PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$DATA(^(40,"B",DDGFBNUM)):21,1:11)
+12 DO DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
+13 if DDSPAGE=21
GOTO ADDQ
+14 IF '$GET(DDGFANS)
Begin DoDot:1
+15 IF $DATA(^DIST(.404,DDGFBNUM,0))#2
IF '$PIECE(^(0),U,2)
Begin DoDot:2
+16 NEW DIK,DA
+17 SET DIK="^DIST(.404,"
SET DA=DDGFBNUM
+18 DO ^DIK
End DoDot:2
End DoDot:1
GOTO ADDQ
+19 KILL DDSPAGE,DDGFANS
+20 ;
+21 ;Add block to page
+22 SET DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,"
SET DIC(0)="L"
+23 SET DA(2)=+DDGFFM
SET DA(1)=DDGFPG
+24 SET DIC("P")=$PIECE(^DD(.4031,40,0),U,2)
+25 SET (DINUM,X)=DDGFBNUM
+26 KILL DO,DD
DO FILE^DICN
KILL DINUM,X
+27 if Y=-1
GOTO ADDQ
+28 ;
+29 ;Stuff in values for block order, coordinates, and type
+30 SET DIE=DIC
SET DA=+Y
+31 SET DDGFC=DDGFDY-$PIECE(DDGFLIM,U)+1_","_(DDGFDX-$PIECE(DDGFLIM,U,2)+1)
+32 SET DR="1////"_($ORDER(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
+33 DO ^DIE
KILL DA,DIC,DIE,DR,X,Y,DDGFC
+34 ;
+35 ;If this looks like a brand new block, stuff in DD number
+36 IF $LENGTH(^DIST(.404,DDGFBNUM,0),U)=1
IF '$ORDER(^(0))
Begin DoDot:1
+37 SET DIE="^DIST(.404,"
SET DA=DDGFBNUM
+38 SET DR="1////"_$PIECE(^DIST(.403,+DDGFFM,0),U,8)
+39 DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+40 ;
+41 DO BK^DDGFLOAD(DDGFPG,DDGFBNUM,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
+42 ;
+43 SET DY=DDGFDY
SET DX=DDGFDX
+44 SET B=DDGFBNUM
SET C=$PIECE(@DDGFREF@("F",DDGFPG,B),U,4)
+45 SET C1=DY
SET C2=DX
SET C3=C2+$LENGTH(DDGFBNAM)-1
+46 SET DDGFADD=1
+47 KILL DDGFBNUM,DDGFBNAM
+48 if $GET(DDGFBV)
SET DDGFORIG(B)=DY_U_DX
+49 GOTO EDIT
+50 ;
ADDQ ;Adding aborted
+1 DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+2 KILL DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
+3 QUIT
+4 ;
EDIT ;Edit block
+1 ;In: B,C1,C2,C3,C
+2 SET DDGFDY=DY
SET DDGFDX=DX
+3 SET DDGFBK=B
SET DDGFC1=C1
SET DDGFC2=C2
SET DDGFC3=C3
+4 SET DDGFBKCO=C1-$PIECE(DDGFLIM,U)+1_","_(C2-$PIECE(DDGFLIM,U,2)+1)
+5 SET DDGFBKNO=C
+6 ;
+7 ;Invoke form to edit block
+8 SET DDSFILE=.403
SET DDSFILE(1)=.4032
+9 SET DA(2)=+DDGFFM
SET DA(1)=DDGFPG
SET DA=B
+10 SET DR="[DDGF BLOCK EDIT]"
SET DDSPARM="KTW"
+11 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM
+12 ;
+13 ;If block was deleted, remove data from DDGFREF
+14 IF $DATA(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0
DO DELETE(DDGFBK)
GOTO EDITQ
+15 ;
+16 if $DATA(DDGFBKCN)[0
SET DDGFBKCN=DDGFBKCO
+17 if $DATA(DDGFBKNN)[0
SET DDGFBKNN=DDGFBKNO
+18 ;
+19 SET C=DDGFBKNN
+20 SET C1=$PIECE(DDGFBKCN,",")-1+$PIECE(DDGFLIM,U)
+21 SET C2=$PIECE(DDGFBKCN,",",2)-1+$PIECE(DDGFLIM,U,2)
+22 SET C3=C2+$LENGTH(C)-1
+23 ;
+24 ;Update TMP if coordinates or name changed, or new block
+25 IF DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$GET(DDGFADD)
Begin DoDot:1
+26 DO WRITE^DDGLIBW(DDGFWIDB,$JUSTIFY("",$LENGTH(DDGFBKNO)),DDGFC1-$PIECE(DDGFLIM,U),DDGFC2-$PIECE(DDGFLIM,U,2),"",1)
+27 DO WRITE^DDGLIBW(DDGFWIDB,C,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"",1)
End DoDot:1
+28 ;
EDITQ DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+1 if '$GET(DDGFADD)
SET DDGFE=1
+2 KILL DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
+3 KILL DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
+4 QUIT
+5 ;
DELETE(B,E) ;Remove block from DDGFREF
+1 ;E : means don't set DDGFEBV or DDGFBDEL
+2 ; (used by EDIT^DDGFHBK when a different header block is chosen)
+3 NEW F,N
+4 ;Remove from TMP
+5 SET F=""
FOR
SET F=$ORDER(@DDGFREF@("F",DDGFPG,B,F))
if F=""
QUIT
Begin DoDot:1
+6 SET N=@DDGFREF@("F",DDGFPG,B,F)
+7 if $PIECE(N,U,4)]""
KILL @DDGFREF@("RC",DDGFWID,$PIECE(N,U),$PIECE(N,U,2),$PIECE(N,U,3),B)
+8 if $PIECE(N,U,8)>0
KILL @DDGFREF@("RC",DDGFWID,$PIECE(N,U,5),$PIECE(N,U,6),$PIECE(N,U,7),B)
End DoDot:1
+9 KILL @DDGFREF@("F",DDGFPG,B)
+10 ;
+11 ;If no blocks on page, set DDGFEBV to exit Block Viewer
+12 ;DDGFBDEL indicates block name should not be painted
+13 IF $GET(DDGFBV)
if '$GET(E)
Begin DoDot:1
+14 IF '$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
IF '$ORDER(^(40,0))
SET DDGFEBV=1
+15 SET DDGFBDEL=1
End DoDot:1
+16 IF '$TEST
DO PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
+17 ;
+18 ;If used on no other forms, ask whether to delete from block file
+19 IF '$ORDER(^DIST(.403,"AB",B,""))
IF '$ORDER(^DIST(.403,"AC",B,""))
Begin DoDot:1
+20 KILL DDGFANS
SET DDGFBK=B
+21 DO DDS(.404,"[DDGF BLOCK DELETE]")
+22 IF $GET(DDGFANS)
SET DIK="^DIST(.404,"
SET DA=DDGFBK
DO ^DIK
KILL DIK,DA
+23 KILL DDGFANS,DDGFBK
End DoDot:1
+24 QUIT
+25 ;
DDS(DDSFILE,DR,DA,DDSPAGE) ;
+1 ;Call DDS
+2 SET DDSPARM="KTW"
DO ^DDS
KILL DDSPARM
+3 QUIT
+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
