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

BDGAD1.m

Go to the documentation of this file. 
  1. BDGAD1 ; IHS/ANMC/LJF - A&D ADMISSIONS ;  [ 01/07/2004  1:05 PM ]
  1.  ;;5.3;PIMS;**1003,1005,1010,1013,1019**;MAY 28, 2004;Build 3
  1.  ;IHS/ITSC/LJF 06/03/2005 PATCH 1003 track multiple admits per patient
  1.  ;IHS/OIT/LJF  12/29/2005 PATCH 1005 changed AGE^BGDF2 to official API
  1.  ;cmi/anch/maw 12/18/2008 PATCH 1010 change set of ward to ?? in GATHER to quitting if now ward
  1.  ;ihs/cmi/maw  09/13/2011 PATCH 1013 added code to filter day surgery in totals
  1.  ;ihs/cmi/maw  01/29/2016 PATCH 1019 add code to screen out DEMO PATIENTS
  1.  ;
  1.  ;Variables defined in calling VA routines DGPMGL*
  1.  ; RD = report date
  1.  ; GL = 1 if recalculating
  1.  ;
  1.  ; IHS variables defined in calling routines:
  1.  ; BDGFRM="D" for detailed, "S" for summary format
  1.  ;
  1.  NEW DGBEG,DGEND,BDGT
  1. A ; -- main driver
  1.  D INIT,LOOP                  ;admissions
  1.  D ^BDGAD2                    ;ward transfers
  1.  D ^BDGAD3                    ;service transfers
  1.  D ^BDGAD4                    ;discharges
  1.  I '$G(BDGREP) D ^BDGAD5      ;update patients remaining
  1.  D QUIT Q
  1.  ;
  1. INIT ;--initialize variables
  1.  S BDGT=RD,BDGFRM=$S($D(BDGFRM):BDGFRM,1:"")  ;rename VA variable
  1.  S DGBEG=RD-.0001,DGEND=RD+.24                ;date range
  1.  K ^TMP("BDGAD",$J)
  1.  ;
  1.  Q:$G(BDGREP)                ;don't initialize if reprint
  1.  ; initialize files
  1.  S WD=0 F  S WD=$O(^DIC(42,WD)) Q:'WD  D
  1.  . Q:'$D(^BDGWD(WD))    ;not moved over
  1.  . ;
  1.  . I '$D(^BDGCWD(WD)) D   ;add ward for first time
  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.  . ;
  1.  . S:'$D(^BDGCWD(WD,1,0)) ^BDGCWD(WD,1,0)="^9009016.21D"
  1.  . S $P(^BDGCWD(WD,1,0),U,3,4)=BDGT_U_($P(^BDGCWD(WD,1,0),U,4)+1)
  1.  . S ^BDGCWD(WD,1,BDGT,0)=BDGT
  1.  . S ^BDGCWD(WD,1,BDGT,1,0)="^9009016.211P"
  1.  ;
  1.  S TS=0 F  S TS=$O(^DIC(45.7,TS)) Q:'TS  D
  1.  . Q:$$GET1^DIQ(45.7,TS,9999999.03)'="YES"   ;not admitting service
  1.  . ;
  1.  . I '$D(^BDGCTX(TS,0)) D     ;add service for first time
  1.  .. S ^BDGCTX(TS,0)=TS,^BDGCTX("B",TS,TS)=""
  1.  .. S $P(^BDGCTX(0),U,3,4)=TS_U_($P(^BDGCTX(0),U,4)+1)
  1.  . ;
  1.  . S:'$D(^BDGCTX(TS,1,0)) ^BDGCTX(TS,1,0)="^9009016.61D"
  1.  . S $P(^BDGCTX(TS,1,0),U,3,4)=BDGT_U_($P(^BDGCTX(TS,1,0),U,4)+1)
  1.  . S ^BDGCTX(TS,1,BDGT,0)=BDGT
  1.  Q
  1.  ;
  1. LOOP ;--loop admissions
  1.  NEW DGDT,DFN,IFN
  1.  S DGDT=DGBEG
  1.  F  S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>DGEND)  D
  1.  . S DFN=0 F  S DFN=$O(^DGPM("AMV1",DGDT,DFN)) Q:'DFN  D
  1.  .. S IFN=0 F  S IFN=$O(^DGPM("AMV1",DGDT,DFN,IFN)) Q:'IFN  D GATHER
  1.  Q
  1.  ;
  1. GATHER ; gather info on admission and put counts into arrays
  1.  NEW DATA,ADULT,WARD,SERV,TYPE,SERVN,NAME
  1.  ;S WARD=$P($G(^DGPM(IFN,0)),U,6) I 'WARD S WARD="??"  ;cmi/maw 12/18/2008 orig line
  1.  S WARD=$P($G(^DGPM(IFN,0)),U,6) I 'WARD Q  ;cmi/maw 12/18/2008 changed to quit
  1.  S ADULT=$S($$AGE<$$ADULT^BDGPAR:0,1:1)               ;1=adult, 0=peds
  1.  S SERV=$$ADMSRVN^BDGF1(IFN,DFN)                      ;service ien
  1.  S SERVN=$$ADMSRV^BDGF1(IFN,DFN)                      ;service name
  1.  ;S TYPE=$S(SERVN["OBSERVATION":"O",1:"I")             ;inpt vs observ ihs/cmi/maw 09/13/2011 orig
  1.  S TYPE=$S(SERVN["OBSERVATION":"O",SERVN="DAY SURGERY":"D",1:"I")             ;inpt vs observ  09/13/2011 mod for ds
  1.  S NAME=$$GET1^DIQ(2,DFN,.01)                         ;patient name
  1.  Q:$$DEMO^APCLUTL(DFN,"E")  ;ihs/cmi/maw patch 1019
  1.  ;
  1.  S DATA=SERV_U_WARD
  1.  ;IHS/OIT/LJF 12/29/2005 PATCH 1005 changed age call to official API
  1.  ;I BDGFRM="D" S DATA=DATA_U_$$ADMPRV^BDGF1(IFN,DFN,"ADM")_U_$$AGE^BDGF2(DFN,+^DGPM(IFN,0))  ;add admitting provider and age at admission
  1.  I BDGFRM="D" S DATA=DATA_U_$$ADMPRV^BDGF1(IFN,DFN,"ADM")_U_$$AGE^AUPNPAT(DFN,+^DGPM(IFN,0))  ;add admitting provider and age at admission
  1.  ;
  1.  ;  collect patient for report
  1.  ;
  1.  ;IHS/ITSC/LJF 6/3/2005 PATCH 1003
  1.  I SERVN="NEWBORN" D
  1.  . ;S ^TMP("BDGAD",$J,"ADMIT","N",NAME,DFN)=DATA
  1.  . S ^TMP("BDGAD",$J,"ADMIT","N",NAME,DFN,IFN)=DATA
  1.  ;E  S ^TMP("BDGAD",$J,"ADMIT",TYPE,NAME,DFN)=DATA
  1.  E  S ^TMP("BDGAD",$J,"ADMIT",TYPE,NAME,DFN,IFN)=DATA
  1.  ;
  1.  Q:$G(BDGREP)                               ;reprint, not recalculating
  1.  ;
  1.  ; increment counts in ADT Census files
  1.  S $P(^BDGCWD(WARD,1,BDGT,0),U,3)=$P($G(^BDGCWD(WARD,1,BDGT,0)),U,3)+1
  1.  ;
  1.  I SERV D                                       ;service zero nodes
  1.  . I '$D(^BDGCWD(WARD,1,BDGT,1,SERV)) D
  1.  .. S ^BDGCWD(WARD,1,BDGT,1,SERV,0)=SERV
  1.  .. S $P(^BDGCWD(WARD,1,BDGT,1,0),U,3,4)=SERV_U_($P(^BDGCWD(WARD,1,BDGT,1,0),U,4)+1)
  1.  . ;
  1.  . I ADULT D  Q                                 ;adult admissions
  1.  .. S $P(^BDGCWD(WARD,1,BDGT,1,SERV,0),U,3)=$P($G(^BDGCWD(WARD,1,BDGT,1,SERV,0)),U,3)+1
  1.  .. S $P(^BDGCTX(SERV,1,BDGT,0),U,3)=$P($G(^BDGCTX(SERV,1,BDGT,0)),U,3)+1
  1.  . ;
  1.  . I 'ADULT D                                   ;peds admissions
  1.  .. S $P(^BDGCWD(WARD,1,BDGT,1,SERV,0),U,13)=$P($G(^BDGCWD(WARD,1,BDGT,1,SERV,0)),U,13)+1
  1.  .. S $P(^BDGCTX(SERV,1,BDGT,0),U,13)=$P($G(^BDGCTX(SERV,1,BDGT,0)),U,13)+1
  1.  ;
  1.  Q
  1.  ;
  1. QUIT ;--cleanup all
  1.  L -^BDGCWD   ;unlock census file
  1.  Q
  1.  ;
  1. AGE() ;--age at admit
  1.  NEW X,X1,X2
  1.  S X1=DGDT,X2=$P($G(^DPT(DFN,0)),U,3) D ^%DTC
  1.  Q:'X "" Q X\365.25
  1.  ;