DDGFHBK ;SFISC/MKO-ADD, EDIT, DELETE HEADER BLOCK ;01:48 PM 22 Nov 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.
;
ADD ;Add a header block
;Check to see if a header block already exists for this page
S DDGFBH=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
I DDGFBH D MSG^DDGF($C(7)_"This page already has a header block.") H 2 D MSG^DDGF() K DDGFBH Q
;
N B
S DDGFDY=DY,DDGFDX=DX
;
;Invoke form to enter block name
K DDGFBNUM,DDGFBNAM
D DDS(.404,"[DDGF HEADER BLOCK SELECT]")
G:$G(DDGFBNUM)=DDGFBH!'$G(DDGFBNUM) ADDQ
;
I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,"B",DDGFBNUM)) D DDS(.404,"[DDGF BLOCK ADD]","",21) G ADDQ
;
S $P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM
;
;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 DIE,DA,DR
;
D:DDGFBH DELETE^DDGFBK(DDGFBH,1)
D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)
;
S DY=DDGFDY,DX=DDGFDX
S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
S DDGFADD=1
K DDGFBNUM,DDGFBNAM
G EDIT
;
ADDQ ;Abort adding a header block
D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
K DDGFANS,DDGFBH,DDGFBNUM,DDGFBNAM,DDGFDY,DDGFDX
Q
;
EDIT ;Edit/Delete header block
;In: B,C
N C1,C2,C3
S DDGFDY=DY,DDGFDX=DX,DDGFBH=B
S (DDGFBKNN,DDGFBKNO)=C
S DDSFILE=.403,DDSFILE(1)=.4031,DA(1)=+DDGFFM,DA=DDGFPG
S DR="[DDGF HEADER BLOCK EDIT]",DDSPARM="KTW"
D ^DDS K DDSFILE,DA,DR,DDSPARM
S DDGFBHN=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
;
I DDGFBHN'=DDGFBH D
. D DELETE^DDGFBK(DDGFBH,DDGFBHN)
. D:DDGFBHN BK^DDGFLOAD(DDGFPG,DDGFBHN,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)
;
S C=DDGFBKNN,B=DDGFBHN
;
;Update TMP if coordinates or name changed, or new block
I DDGFBKNN'=DDGFBKNO!$G(DDGFADD) D
. D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)
. D WRITE^DDGLIBW(DDGFWIDB,C,$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)
;
D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
S:'$G(DDGFADD) DDGFE=1
K DDGFADD,DDGFBH,DDGFBHN,DDGFBKNN,DDGFBKNO,DDGFDY,DDGFDX
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[HDDGFHBK 2691 printed Dec 13, 2024@02:42:25 Page 2
DDGFHBK ;SFISC/MKO-ADD, EDIT, DELETE HEADER BLOCK ;01:48 PM 22 Nov 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 ;
ADD ;Add a header block
+1 ;Check to see if a header block already exists for this page
+2 SET DDGFBH=$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
+3 IF DDGFBH
DO MSG^DDGF($CHAR(7)_"This page already has a header block.")
HANG 2
DO MSG^DDGF()
KILL DDGFBH
QUIT
+4 ;
+5 NEW B
+6 SET DDGFDY=DY
SET DDGFDX=DX
+7 ;
+8 ;Invoke form to enter block name
+9 KILL DDGFBNUM,DDGFBNAM
+10 DO DDS(.404,"[DDGF HEADER BLOCK SELECT]")
+11 if $GET(DDGFBNUM)=DDGFBH!'$GET(DDGFBNUM)
GOTO ADDQ
+12 ;
+13 IF $DATA(^DIST(.403,+DDGFFM,40,DDGFPG,40,"B",DDGFBNUM))
DO DDS(.404,"[DDGF BLOCK ADD]","",21)
GOTO ADDQ
+14 ;
+15 SET $PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM
+16 ;
+17 ;If this looks like a brand new block, stuff in DD number
+18 IF $LENGTH(^DIST(.404,DDGFBNUM,0),U)=1
IF '$ORDER(^(0))
Begin DoDot:1
+19 SET DIE="^DIST(.404,"
SET DA=DDGFBNUM
+20 SET DR="1////"_$PIECE(^DIST(.403,+DDGFFM,0),U,8)
+21 DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+22 ;
+23 if DDGFBH
DO DELETE^DDGFBK(DDGFBH,1)
+24 DO BK^DDGFLOAD(DDGFPG,DDGFBNUM,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),0,0,1,1)
+25 ;
+26 SET DY=DDGFDY
SET DX=DDGFDX
+27 SET B=DDGFBNUM
SET C=$PIECE(@DDGFREF@("F",DDGFPG,B),U,4)
+28 SET DDGFADD=1
+29 KILL DDGFBNUM,DDGFBNAM
+30 GOTO EDIT
+31 ;
ADDQ ;Abort adding a header block
+1 DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+2 KILL DDGFANS,DDGFBH,DDGFBNUM,DDGFBNAM,DDGFDY,DDGFDX
+3 QUIT
+4 ;
EDIT ;Edit/Delete header block
+1 ;In: B,C
+2 NEW C1,C2,C3
+3 SET DDGFDY=DY
SET DDGFDX=DX
SET DDGFBH=B
+4 SET (DDGFBKNN,DDGFBKNO)=C
+5 SET DDSFILE=.403
SET DDSFILE(1)=.4031
SET DA(1)=+DDGFFM
SET DA=DDGFPG
+6 SET DR="[DDGF HEADER BLOCK EDIT]"
SET DDSPARM="KTW"
+7 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM
+8 SET DDGFBHN=$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
+9 ;
+10 IF DDGFBHN'=DDGFBH
Begin DoDot:1
+11 DO DELETE^DDGFBK(DDGFBH,DDGFBHN)
+12 if DDGFBHN
DO BK^DDGFLOAD(DDGFPG,DDGFBHN,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),0,0,1,1)
End DoDot:1
+13 ;
+14 SET C=DDGFBKNN
SET B=DDGFBHN
+15 ;
+16 ;Update TMP if coordinates or name changed, or new block
+17 IF DDGFBKNN'=DDGFBKNO!$GET(DDGFADD)
Begin DoDot:1
+18 DO WRITE^DDGLIBW(DDGFWIDB,$JUSTIFY("",$LENGTH(DDGFBKNO)),$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),"",1)
+19 DO WRITE^DDGLIBW(DDGFWIDB,C,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),"",1)
End DoDot:1
+20 ;
+21 DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+22 if '$GET(DDGFADD)
SET DDGFE=1
+23 KILL DDGFADD,DDGFBH,DDGFBHN,DDGFBKNN,DDGFBKNO,DDGFDY,DDGFDX
+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
