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