Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGCENI

BDGCENI.m

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