BDGCENI ; IHS/ANMC/LJF - AUTO INITIALIZE CENSUS ; [ 06/28/2002 4:31 PM ]
;;5.3;PIMS;**1005**;MAY 28, 2004
;IHS/OIT/LJF 12/29/2005 PATCH 1005 cahnged AGE^BDGF2 to official API
;
NEW BDGBEG,DEFAULT,DA,DR,DIE
;
; ask min age for adult patient
S DA=$$DIV^BSDU Q:'DA S DR=.05,DIE=9009020.1 D ^DIE Q:$D(Y)
;
; ask begin date for census
S DA=1,DIE=43,DR=10 D ^DIE Q:$D(Y)
S BDGBEG=$$GET1^DIQ(43,1,10,"I") Q:BDGBEG<1
S DIE=43,DA=1,DR="1000.11///"_BDGBEG_";1000.07///"_BDGBEG D ^DIE
;
D MSG^BDGF("I will now DELETE all data in your census files and start over.",2,1)
Q:'$$READ^BDGF("YO","Ready to Initialize Census for "_$$FMTE^XLFDT(BDGBEG),"NO")
;
; reset G&L dates in file 43
S DR="1000.01///"_BDGBEG_";1000.07///"_BDGBEG_";1000.11///"_BDGBEG
S DIE=43,DA=1 D ^DIE
;
; queue to background
S ZTIO="",ZTRTN="EN^BDGCENI",ZTDESC="AUTO INITIALIZE CENSUS"
S ZTDTH=$H,ZTSAVE("BDGBEG")=""
D ^%ZTLOAD
D MSG^BDGF("Queued to run in the background.",2,1),PAUSE^BDGF
Q
;
EN ;EP; entry point after queuing to background
NEW X,BEGCEN,DFN,CA,DATE,IEN,LAST,SRV,WARD,ADULT
;
; delete all data in census files
I '$D(ZTQUEUED) D MSG^BDGF("Deleting old data in census files...",2,0)
S X=0 F S X=$O(^BDGCWD(X)) Q:X="" K ^BDGCWD(X)
S X=0 F S X=$O(^BDGCTX(X)) Q:X="" K ^BDGCTX(X)
;
S BDGCEN=$$FMADD^XLFDT(BDGBEG,-1) ;set census init date (begin-1)
;
I '$D(ZTQUEUED) D MSG^BDGF("Finding all inpatients for initialization date...",1,0)
S CA=0 F S CA=$O(^DGPM(CA)) Q:'CA D
. ;
. ; check if in date range
. Q:'$G(^DGPM(CA,0)) ;bad node
. Q:$P(^DGPM(CA,0),U,2)'=1 ;not admission node
. I $$DSCH(CA)<BDGBEG Q ;if patient discharged before begin date
. I +^DGPM(CA,0)>BDGBEG Q ;if patient admitted after census date
. ;
. ; get patient
. S DFN=$$GET1^DIQ(405,CA,.03,"I") ;patient pointer
. ;
. ; set ADULT=1 if at least min age for adult; 0=peds
. ;S ADULT=$S($$AGE^BDGF2(DFN,+^DGPM(CA,0))<$$ADULT^BDGPAR:0,1:1)
. S ADULT=$S($$AGE^AUPNPAT(DFN,+^DGPM(CA,0))<$$ADULT^BDGPAR:0,1:1) ;IHS/OIT/LJF 12/29/2005 PATCH 1005
. ;
. ; find last ward transfer date before census date
. S (LAST,DATE)=0
. F S DATE=$O(^DGPM("APCA",DFN,CA,DATE)) Q:'DATE Q:(DATE>BDGBEG) D
.. S LAST=DATE
. Q:'LAST ;bad xref
. ; find ien for last transfer before begin date
. S IEN=$O(^DGPM("APCA",DFN,CA,LAST,0)) Q:'IEN
. ; get last ward
. S WARD=$$GET1^DIQ(405,IEN,.06,"I") Q:'WARD
. ;
. ; find last service transfer before census date
. S LAST=9999999.9999999-BDGBEG
. S LAST=$O(^DGPM("ATS",DFN,CA,(9999999.9999999-BDGBEG)))
. Q:'LAST ;bad xref
. S SRV=$O(^DGPM("ATS",DFN,CA,LAST,0))
. ;
. ; put this admission into census file
. I '$D(ZTQUEUED) D MSG^BDGF("Adding patient data to file...",0,0)
. D SET(WARD,SRV,ADULT)
;
; now recalculate census from initialization date to today
I '$D(ZTQUEUED) D MSG^BDGF("Running recalc from initialization date...",2,0)
NEW RC,BDGFRM,BDGREP
S RC=BDGBEG,BDGFRM="",BDGREP=0
D DEFS^DGPMBSAR,QUE^DGPMBSAR
;
; send e-amil to person starting job
NEW DUZ D MAIL^XBMAIL("DGZMGR","MSG^BDGCENI")
;
Q
;
DSCH(ADM) ; return discharge date for admission ADM
NEW X
S X=$P($G(^DGPM(ADM,0)),U,17) I X="" Q 9999999 ;still inpatient
Q $S($G(^DGPM(X,0)):+^(0),1:9999999)
;
SET(WD,SV,ADULT) ; stuff census files
NEW PIECE
I (WD="")!(SV="")!(ADULT="") Q
S PIECE=$S(ADULT:2,1:12)
;
; set wardnodes if first time for this ward
I '$D(^BDGCWD(WD)) D
. S ^BDGCWD(WD,0)=WD,^BDGCWD("B",WD,WD)=""
. S $P(^BDGCWD(0),U,3,4)=WD_U_($P(^BDGCWD(0),U,4)+1)
I '$D(^BDGCWD(WD,1,0)) S ^BDGCWD(WD,1,0)="^9009016.21D^"_BDGCEN_"^1"
I '$D(^BDGCWD(WD,1,BDGCEN,0)) S ^BDGCWD(WD,1,BDGCEN,0)=BDGCEN
;
; increment count for ward
S $P(^BDGCWD(WD,1,BDGCEN,0),U,2)=$P(^BDGCWD(WD,1,BDGCEN,0),U,2)+1
;
; set service within ward node if first time for service/ward pair
I '$D(^BDGCWD(WD,1,BDGCEN,1,0)) S ^BDGCWD(WD,1,BDGCEN,1,0)="^9009016.211P"
I '$D(^BDGCWD(WD,1,BDGCEN,1,SV)) D
. S $P(^BDGCWD(WD,1,BDGCEN,1,0),U,3,4)=SV_U_($P(^BDGCWD(WD,1,BDGCEN,1,0),U,4)+1)
. S ^BDGCWD(WD,1,BDGCEN,1,SV,0)=SV
;
; increment count for service within ward
S $P(^BDGCWD(WD,1,BDGCEN,1,0),U,3,4)=SV_U_($P(^BDGCWD(WD,1,BDGCEN,1,0),U,4)+1)
S $P(^BDGCWD(WD,1,BDGCEN,1,SV,0),U,PIECE)=$P(^BDGCWD(WD,1,BDGCEN,1,SV,0),U,PIECE)+1
;
; set service node if first time for this service
I '$D(^BDGCTX(SV)) D
. S ^BDGCTX(SV,0)=SV,^BDGCTX("B",SV,SV)=""
. S $P(^BDGCTX(0),U,3,4)=SV_U_($P(^BDGCTX(0),U,4)+1)
I '$D(^BDGCTX(SV,1,0)) S ^BDGCTX(SV,1,0)="^9009016.61D^"_BDGCEN_"^1"
I '$D(^BDGCTX(SV,1,BDGCEN,0)) S ^BDGCTX(SV,1,BDGCEN,0)=BDGCEN
;
; increment count for service
S $P(^BDGCTX(SV,1,BDGCEN,0),U,PIECE)=$P(^BDGCTX(SV,1,BDGCEN,0),U,PIECE)+1
Q
;
MSG ;EP; text of mail message
;;ADT CENSUS FILES INITIALIZATION
;;The initialization of the census files has been completed.
BDGCENI ; IHS/ANMC/LJF - AUTO INITIALIZE CENSUS ; [ 06/28/2002 4:31 PM ]
+1 ;;5.3;PIMS;**1005**;MAY 28, 2004
+2 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 cahnged AGE^BDGF2 to official API
+3 ;
+4 NEW BDGBEG,DEFAULT,DA,DR,DIE
+5 ;
+6 ; ask min age for adult patient
+7 SET DA=$$DIV^BSDU
IF 'DA
QUIT
SET DR=.05
SET DIE=9009020.1
DO ^DIE
IF $DATA(Y)
QUIT
+8 ;
+9 ; ask begin date for census
+10 SET DA=1
SET DIE=43
SET DR=10
DO ^DIE
IF $DATA(Y)
QUIT
+11 SET BDGBEG=$$GET1^DIQ(43,1,10,"I")
IF BDGBEG<1
QUIT
+12 SET DIE=43
SET DA=1
SET DR="1000.11///"_BDGBEG_";1000.07///"_BDGBEG
DO ^DIE
+13 ;
+14 DO MSG^BDGF("I will now DELETE all data in your census files and start over.",2,1)
+15 IF '$$READ^BDGF("YO","Ready to Initialize Census for "_$$FMTE^XLFDT(BDGBEG),"NO")
QUIT
+16 ;
+17 ; reset G&L dates in file 43
+18 SET DR="1000.01///"_BDGBEG_";1000.07///"_BDGBEG_";1000.11///"_BDGBEG
+19 SET DIE=43
SET DA=1
DO ^DIE
+20 ;
+21 ; queue to background
+22 SET ZTIO=""
SET ZTRTN="EN^BDGCENI"
SET ZTDESC="AUTO INITIALIZE CENSUS"
+23 SET ZTDTH=$HOROLOG
SET ZTSAVE("BDGBEG")=""
+24 DO ^%ZTLOAD
+25 DO MSG^BDGF("Queued to run in the background.",2,1)
DO PAUSE^BDGF
+26 QUIT
+27 ;
EN ;EP; entry point after queuing to background
+1 NEW X,BEGCEN,DFN,CA,DATE,IEN,LAST,SRV,WARD,ADULT
+2 ;
+3 ; delete all data in census files
+4 IF '$DATA(ZTQUEUED)
DO MSG^BDGF("Deleting old data in census files...",2,0)
+5 SET X=0
FOR
SET X=$ORDER(^BDGCWD(X))
IF X=""
QUIT
KILL ^BDGCWD(X)
+6 SET X=0
FOR
SET X=$ORDER(^BDGCTX(X))
IF X=""
QUIT
KILL ^BDGCTX(X)
+7 ;
+8 ;set census init date (begin-1)
SET BDGCEN=$$FMADD^XLFDT(BDGBEG,-1)
+9 ;
+10 IF '$DATA(ZTQUEUED)
DO MSG^BDGF("Finding all inpatients for initialization date...",1,0)
+11 SET CA=0
FOR
SET CA=$ORDER(^DGPM(CA))
IF 'CA
QUIT
Begin DoDot:1
+12 ;
+13 ; check if in date range
+14 ;bad node
IF '$GET(^DGPM(CA,0))
QUIT
+15 ;not admission node
IF $PIECE(^DGPM(CA,0),U,2)'=1
QUIT
+16 ;if patient discharged before begin date
IF $$DSCH(CA)<BDGBEG
QUIT
+17 ;if patient admitted after census date
IF +^DGPM(CA,0)>BDGBEG
QUIT
+18 ;
+19 ; get patient
+20 ;patient pointer
SET DFN=$$GET1^DIQ(405,CA,.03,"I")
+21 ;
+22 ; set ADULT=1 if at least min age for adult; 0=peds
+23 ;S ADULT=$S($$AGE^BDGF2(DFN,+^DGPM(CA,0))<$$ADULT^BDGPAR:0,1:1)
+24 ;IHS/OIT/LJF 12/29/2005 PATCH 1005
SET ADULT=$SELECT($$AGE^AUPNPAT(DFN,+^DGPM(CA,0))<$$ADULT^BDGPAR:0,1:1)
+25 ;
+26 ; find last ward transfer date before census date
+27 SET (LAST,DATE)=0
+28 FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CA,DATE))
IF 'DATE
QUIT
IF (DATE>BDGBEG)
QUIT
Begin DoDot:2
+29 SET LAST=DATE
End DoDot:2
+30 ;bad xref
IF 'LAST
QUIT
+31 ; find ien for last transfer before begin date
+32 SET IEN=$ORDER(^DGPM("APCA",DFN,CA,LAST,0))
IF 'IEN
QUIT
+33 ; get last ward
+34 SET WARD=$$GET1^DIQ(405,IEN,.06,"I")
IF 'WARD
QUIT
+35 ;
+36 ; find last service transfer before census date
+37 SET LAST=9999999.9999999-BDGBEG
+38 SET LAST=$ORDER(^DGPM("ATS",DFN,CA,(9999999.9999999-BDGBEG)))
+39 ;bad xref
IF 'LAST
QUIT
+40 SET SRV=$ORDER(^DGPM("ATS",DFN,CA,LAST,0))
+41 ;
+42 ; put this admission into census file
+43 IF '$DATA(ZTQUEUED)
DO MSG^BDGF("Adding patient data to file...",0,0)
+44 DO SET(WARD,SRV,ADULT)
End DoDot:1
+45 ;
+46 ; now recalculate census from initialization date to today
+47 IF '$DATA(ZTQUEUED)
DO MSG^BDGF("Running recalc from initialization date...",2,0)
+48 NEW RC,BDGFRM,BDGREP
+49 SET RC=BDGBEG
SET BDGFRM=""
SET BDGREP=0
+50 DO DEFS^DGPMBSAR
DO QUE^DGPMBSAR
+51 ;
+52 ; send e-amil to person starting job
+53 NEW DUZ
DO MAIL^XBMAIL("DGZMGR","MSG^BDGCENI")
+54 ;
+55 QUIT
+56 ;
DSCH(ADM) ; return discharge date for admission ADM
+1 NEW X
+2 ;still inpatient
SET X=$PIECE($GET(^DGPM(ADM,0)),U,17)
IF X=""
QUIT 9999999
+3 QUIT $SELECT($GET(^DGPM(X,0)):+^(0),1:9999999)
+4 ;
SET(WD,SV,ADULT) ; stuff census files
+1 NEW PIECE
+2 IF (WD="")!(SV="")!(ADULT="")
QUIT
+3 SET PIECE=$SELECT(ADULT:2,1:12)
+4 ;
+5 ; set wardnodes if first time for this ward
+6 IF '$DATA(^BDGCWD(WD))
Begin DoDot:1
+7 SET ^BDGCWD(WD,0)=WD
SET ^BDGCWD("B",WD,WD)=""
+8 SET $PIECE(^BDGCWD(0),U,3,4)=WD_U_($PIECE(^BDGCWD(0),U,4)+1)
End DoDot:1
+9 IF '$DATA(^BDGCWD(WD,1,0))
SET ^BDGCWD(WD,1,0)="^9009016.21D^"_BDGCEN_"^1"
+10 IF '$DATA(^BDGCWD(WD,1,BDGCEN,0))
SET ^BDGCWD(WD,1,BDGCEN,0)=BDGCEN
+11 ;
+12 ; increment count for ward
+13 SET $PIECE(^BDGCWD(WD,1,BDGCEN,0),U,2)=$PIECE(^BDGCWD(WD,1,BDGCEN,0),U,2)+1
+14 ;
+15 ; set service within ward node if first time for service/ward pair
+16 IF '$DATA(^BDGCWD(WD,1,BDGCEN,1,0))
SET ^BDGCWD(WD,1,BDGCEN,1,0)="^9009016.211P"
+17 IF '$DATA(^BDGCWD(WD,1,BDGCEN,1,SV))
Begin DoDot:1
+18 SET $PIECE(^BDGCWD(WD,1,BDGCEN,1,0),U,3,4)=SV_U_($PIECE(^BDGCWD(WD,1,BDGCEN,1,0),U,4)+1)
+19 SET ^BDGCWD(WD,1,BDGCEN,1,SV,0)=SV
End DoDot:1
+20 ;
+21 ; increment count for service within ward
+22 SET $PIECE(^BDGCWD(WD,1,BDGCEN,1,0),U,3,4)=SV_U_($PIECE(^BDGCWD(WD,1,BDGCEN,1,0),U,4)+1)
+23 SET $PIECE(^BDGCWD(WD,1,BDGCEN,1,SV,0),U,PIECE)=$PIECE(^BDGCWD(WD,1,BDGCEN,1,SV,0),U,PIECE)+1
+24 ;
+25 ; set service node if first time for this service
+26 IF '$DATA(^BDGCTX(SV))
Begin DoDot:1
+27 SET ^BDGCTX(SV,0)=SV
SET ^BDGCTX("B",SV,SV)=""
+28 SET $PIECE(^BDGCTX(0),U,3,4)=SV_U_($PIECE(^BDGCTX(0),U,4)+1)
End DoDot:1
+29 IF '$DATA(^BDGCTX(SV,1,0))
SET ^BDGCTX(SV,1,0)="^9009016.61D^"_BDGCEN_"^1"
+30 IF '$DATA(^BDGCTX(SV,1,BDGCEN,0))
SET ^BDGCTX(SV,1,BDGCEN,0)=BDGCEN
+31 ;
+32 ; increment count for service
+33 SET $PIECE(^BDGCTX(SV,1,BDGCEN,0),U,PIECE)=$PIECE(^BDGCTX(SV,1,BDGCEN,0),U,PIECE)+1
+34 QUIT
+35 ;
MSG ;EP; text of mail message
+1 ;;ADT CENSUS FILES INITIALIZATION
+2 ;;The initialization of the census files has been completed.
