- 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
