BDGAD0 ; IHS/ANMC/LJF - A&D UTILITY CALLS ;
;;5.3;PIMS;;APR 26, 2002
;
FORMAT ;EP; -- ask user which format to print
; called by DGPMGL1
I $G(BDGREC) S BDGFRM="" Q ;recalculate only; no printing
S BDGFRM=$$READ^BDGF("SB^D:Detailed Format;S:Summary Format","Select Report Format - DETAILED or SUMMARY","","^D FRMHLP^BDGAD0")
I (BDGFRM="")!(BDGFRM=U) S BDGQUIT=1 Q
I BDGFRM="D" W !!?20,"Paper margin must be at least 110."
Q
;
FRMHLP ;EP; help for format question
D MSG^BDGF("Enter 'D' for DETAILED or 'S' for SUMMARY",1,1)
D MSG^BDGF("DETAILED FORMAT uses a right margin of 110.",1,0)
D MSG^BDGF("It lists each patient name along with provider, age,",1,0)
D MSG^BDGF("ward, service, community, and chart number. Newborn",1,0)
D MSG^BDGF("admissions and discharges are listed separately.",1,1)
D MSG^BDGF("SUMMARY FORMAT uses a right margin of 80.",1,0)
D MSG^BDGF("It gives a summary of movements by service. Then",1,0)
D MSG^BDGF("lists each patient with chart number, service,",1,0)
D MSG^BDGF("and ward.",1,0)
Q
;
MAN ;EP; -- manual purge
N Y,X1,X2,PD
; -- date selection
S PD=$$READ^BDGF("DO^::EPX","Purge from what date")
I PD<1 Q
;
; -- procede?
S Y=$$READ^BDGF("Y","Do you want to purge census files from "_$$FMTE^XLFDT(PD),"NO") Q:'Y
;
; -- call purge subroutine
S X1=PD,X2=-1 D C^%DTC S PD=X ;set to date before
D PURG(PD)
Q
;
PURG(PD) ;EP; -- purge called from recalc and manual purge options
; PD= day before purge date
NEW WD,TS,DATE
; for each ward
S WD=0 F S WD=$O(^BDGCWD(WD)) Q:'WD D
. ;
. ; set zero node of multiple if not there
. S:$P($G(^BDGCWD(WD,1,0)),U,2)="" $P(^(0),U,2)="9009016.21D"
. ;
. ; loop thru dates from purge date to present
. S DATE=PD F S DATE=$O(^BDGCWD(WD,1,DATE)) Q:'DATE D
.. ;
.. ; call DIK to delete multiple entry for date
.. S DA(1)=WD,DA=DATE,DIK="^BDGCWD("_DA(1)_",1,"
.. NEW WD,DATE D ^DIK K DA,DIK
;
;
; for each treating specialty
S TS=0 F S TS=$O(^BDGCTX(TS)) Q:'TS D
. ;
. ; set zero node for multiple if not there
. S:$P($G(^BDGCTX(TS,1,0)),U,2)="" $P(^(0),U,2)="9009016.61D"
. ;
. ; loop thru dates from purge date to present
. S DATE=PD F S DATE=$O(^BDGCTX(TS,1,DATE)) Q:'DATE D
.. ;
.. ; call DIK to delete multiple entry for date
.. S DA(1)=TS,DA=DATE,DIK="^BDGCTX("_DA(1)_",1,"
.. NEW TS,DATE D ^DIK K DA,DIK
Q
BDGAD0 ; IHS/ANMC/LJF - A&D UTILITY CALLS ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
FORMAT ;EP; -- ask user which format to print
+1 ; called by DGPMGL1
+2 ;recalculate only; no printing
IF $GET(BDGREC)
SET BDGFRM=""
QUIT
+3 SET BDGFRM=$$READ^BDGF("SB^D:Detailed Format;S:Summary Format","Select Report Format - DETAILED or SUMMARY","","^D FRMHLP^BDGAD0")
+4 IF (BDGFRM="")!(BDGFRM=U)
SET BDGQUIT=1
QUIT
+5 IF BDGFRM="D"
WRITE !!?20,"Paper margin must be at least 110."
+6 QUIT
+7 ;
FRMHLP ;EP; help for format question
+1 DO MSG^BDGF("Enter 'D' for DETAILED or 'S' for SUMMARY",1,1)
+2 DO MSG^BDGF("DETAILED FORMAT uses a right margin of 110.",1,0)
+3 DO MSG^BDGF("It lists each patient name along with provider, age,",1,0)
+4 DO MSG^BDGF("ward, service, community, and chart number. Newborn",1,0)
+5 DO MSG^BDGF("admissions and discharges are listed separately.",1,1)
+6 DO MSG^BDGF("SUMMARY FORMAT uses a right margin of 80.",1,0)
+7 DO MSG^BDGF("It gives a summary of movements by service. Then",1,0)
+8 DO MSG^BDGF("lists each patient with chart number, service,",1,0)
+9 DO MSG^BDGF("and ward.",1,0)
+10 QUIT
+11 ;
MAN ;EP; -- manual purge
+1 NEW Y,X1,X2,PD
+2 ; -- date selection
+3 SET PD=$$READ^BDGF("DO^::EPX","Purge from what date")
+4 IF PD<1
QUIT
+5 ;
+6 ; -- procede?
+7 SET Y=$$READ^BDGF("Y","Do you want to purge census files from "_$$FMTE^XLFDT(PD),"NO")
IF 'Y
QUIT
+8 ;
+9 ; -- call purge subroutine
+10 ;set to date before
SET X1=PD
SET X2=-1
DO C^%DTC
SET PD=X
+11 DO PURG(PD)
+12 QUIT
+13 ;
PURG(PD) ;EP; -- purge called from recalc and manual purge options
+1 ; PD= day before purge date
+2 NEW WD,TS,DATE
+3 ; for each ward
+4 SET WD=0
FOR
SET WD=$ORDER(^BDGCWD(WD))
IF 'WD
QUIT
Begin DoDot:1
+5 ;
+6 ; set zero node of multiple if not there
+7 IF $PIECE($GET(^BDGCWD(WD,1,0)),U,2)=""
SET $PIECE(^(0),U,2)="9009016.21D"
+8 ;
+9 ; loop thru dates from purge date to present
+10 SET DATE=PD
FOR
SET DATE=$ORDER(^BDGCWD(WD,1,DATE))
IF 'DATE
QUIT
Begin DoDot:2
+11 ;
+12 ; call DIK to delete multiple entry for date
+13 SET DA(1)=WD
SET DA=DATE
SET DIK="^BDGCWD("_DA(1)_",1,"
+14 NEW WD,DATE
DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+15 ;
+16 ;
+17 ; for each treating specialty
+18 SET TS=0
FOR
SET TS=$ORDER(^BDGCTX(TS))
IF 'TS
QUIT
Begin DoDot:1
+19 ;
+20 ; set zero node for multiple if not there
+21 IF $PIECE($GET(^BDGCTX(TS,1,0)),U,2)=""
SET $PIECE(^(0),U,2)="9009016.61D"
+22 ;
+23 ; loop thru dates from purge date to present
+24 SET DATE=PD
FOR
SET DATE=$ORDER(^BDGCTX(TS,1,DATE))
IF 'DATE
QUIT
Begin DoDot:2
+25 ;
+26 ; call DIK to delete multiple entry for date
+27 SET DA(1)=TS
SET DA=DATE
SET DIK="^BDGCTX("_DA(1)_",1,"
+28 NEW TS,DATE
DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+29 QUIT
