BDGAD4 ; IHS/ANMC/LJF - A&D DISCHARGES ;
;;5.3;PIMS;**1003,1005,1009,1013,1018,1019**;MAY 28, 2004;Build 3
;IHS/ITSC/LJF 06/03/2005 PATCH 1003 added code for multiple discharges per patient
;IHS/OIT/LJF 12/29/2005 PATCH 1005 changed AGE^BDGF2 to official API
;cmi/anch/maw 02/11/2008 added fix in GATHER PATCH 1009
;ihs/cmi/maw 09/14/2011 added check of service being DAY SURGERY
;
LOOP ;--loop discharges
NEW DGDT,DFN,IFN
S DGDT=DGBEG
F S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>DGEND) D
. S DFN=0 F S DFN=$O(^DGPM("AMV3",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV3",DGDT,DFN,IFN)) Q:'IFN D GATHER
Q
;
GATHER ; gather info on discharges and put counts into arrays
NEW ADM,ADULT,OLDWD,OLDSV,OLDSVN,X,TYPE,LOS,D0,PIECE,NAME,DATA
S ADM=$P(^DGPM(IFN,0),U,14) ;admit ien
S ADULT=$S($$AGE<$$ADULT^BDGPAR:0,1:1) ;1=adult, 0=peds
S TYPE=$$GET1^DIQ(405,IFN,.04) ;type of disch
S D0=ADM D EN^DGPMLOS S LOS=$P(X,U,5) ;length of stay
;
S OLDWD=$P($G(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6) ;old ward
;ihs/cmi/maw 08/07/2015 this line needs to be removed or counts will be off, interward transfers are being created without a ward causing the counts and errors
;Q:'$G(OLDWD) ;cmi/maw 2/11/2008 added for no ward being returned PATCH 1009
;
S OLDSV=$P(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9) ;old srv
S OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
I OLDSVN["OBSERVATION" S LOS=$$LOSHRS^BDGF1(ADM,DGDT,DFN) ;los-hours
;
; collect patient data for report
S NAME=$$GET1^DIQ(2,DFN,.01),X=$S(OLDSVN["OBSERVATION":"O",OLDSVN="DAY SURGERY":"D",1:"I")
Q:$$DEMO^APCLUTL(DFN,"E") ;ihs/cmi/maw patch 1019
S DATA=OLDSV_U_OLDWD
;IHS/OIT/LJF 12/29/2005 PATCH 1005 changed AGE call to official API
;I BDGFRM="D" S DATA=DATA_U_$$LASTPRV^BDGF1(ADM,DFN)_U_$$AGE^BDGF2(DFN,+$G(^DGPM(ADM,0))) ;add provider and age at admission
I BDGFRM="D" S DATA=DATA_U_$$LASTPRV^BDGF1(ADM,DFN)_U_$$AGE^AUPNPAT(DFN,+$G(^DGPM(ADM,0))) ;add provider and age at admission
;
I TYPE["DEATH" D
. S ^TMP("BDGAD",$J,"DEATH",NAME,DFN)=DATA
;
;IHS/ITSC/LJF 6/3/2005 PATCH 1003
E D
. I OLDSVN="NEWBORN" D
.. ;S ^TMP("BDGAD",$J,"DSCH","N",NAME,DFN)=DATA
.. S ^TMP("BDGAD",$J,"DSCH","N",NAME,DFN,IFN)=DATA
. ;E S ^TMP("BDGAD",$J,"DSCH",X,NAME,DFN)=DATA
. E S ^TMP("BDGAD",$J,"DSCH",X,NAME,DFN,IFN)=DATA
;end of PATCH 1003 changes
;
Q:$G(BDGREP) ;reprint, not recalculating
;
;
; -- increment counts in ADT Census files
; --- discharge for service within ward
; ---- set zero node if needed
I '$D(^BDGCWD(OLDWD,1,BDGT,1,OLDSV)) D
. S ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV
. S $P(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($P(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)
;
; ---- increment discharge/death counts
S PIECE=$S(ADULT:4,1:14)
I TYPE["DEATH" D
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,(PIECE+3))=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,(PIECE+3))+1
. S $P(^BDGCWD(OLDWD,1,BDGT,0),U,7)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,7)+1
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,(PIECE+3))=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,(PIECE+3))+1
E D
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,PIECE)+1
. S $P(^BDGCWD(OLDWD,1,BDGT,0),U,4)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,4)+1
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,PIECE)+1
;
; --- increment LOS (inpt in days/observations in hours)
I OLDSVN["OBSERVATION" S PIECE=$S(ADULT:11,1:21)
E S PIECE=$S(ADULT:9,1:19)
S $P(^BDGCWD(OLDWD,1,BDGT,0),U,$S(PIECE=19:9,PIECE=21:11,1:PIECE))=$P(^BDGCWD(OLDWD,1,BDGT,0),U,$S(PIECE=19:9,PIECE=21:11,1:PIECE))+LOS
S $P(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$P(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)+LOS
S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)+LOS
;
; --- increment one day inpatients
I (DGDT\1)=($P(^DGPM(ADM,0),U)\1) D
. S $P(^BDGCWD(OLDWD,1,BDGT,0),U,8)=$P(^BDGCWD(OLDWD,1,BDGT,0),U,8)+1
. S PIECE=$S(ADULT:8,1:18)
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$P(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)+1
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)+1
;
Q
;
AGE() ;--age at admit
NEW X,X1,X2
S X1=+$G(^DGPM(ADM,0)) ;admit date
S X2=$P($G(^DPT(DFN,0)),U,3) D ^%DTC ;date of birth
Q:'X "" Q X\365.25
;
BDGAD4 ; IHS/ANMC/LJF - A&D DISCHARGES ;
+1 ;;5.3;PIMS;**1003,1005,1009,1013,1018,1019**;MAY 28, 2004;Build 3
+2 ;IHS/ITSC/LJF 06/03/2005 PATCH 1003 added code for multiple discharges per patient
+3 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 changed AGE^BDGF2 to official API
+4 ;cmi/anch/maw 02/11/2008 added fix in GATHER PATCH 1009
+5 ;ihs/cmi/maw 09/14/2011 added check of service being DAY SURGERY
+6 ;
LOOP ;--loop discharges
+1 NEW DGDT,DFN,IFN
+2 SET DGDT=DGBEG
+3 FOR
SET DGDT=$ORDER(^DGPM("AMV3",DGDT))
IF 'DGDT!(DGDT>DGEND)
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+5 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV3",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO GATHER
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
GATHER ; gather info on discharges and put counts into arrays
+1 NEW ADM,ADULT,OLDWD,OLDSV,OLDSVN,X,TYPE,LOS,D0,PIECE,NAME,DATA
+2 ;admit ien
SET ADM=$PIECE(^DGPM(IFN,0),U,14)
+3 ;1=adult, 0=peds
SET ADULT=$SELECT($$AGE<$$ADULT^BDGPAR:0,1:1)
+4 ;type of disch
SET TYPE=$$GET1^DIQ(405,IFN,.04)
+5 ;length of stay
SET D0=ADM
DO EN^DGPMLOS
SET LOS=$PIECE(X,U,5)
+6 ;
+7 ;old ward
SET OLDWD=$PIECE($GET(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6)
+8 ;ihs/cmi/maw 08/07/2015 this line needs to be removed or counts will be off, interward transfers are being created without a ward causing the counts and errors
+9 ;Q:'$G(OLDWD) ;cmi/maw 2/11/2008 added for no ward being returned PATCH 1009
+10 ;
+11 ;old srv
SET OLDSV=$PIECE(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9)
+12 SET OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
+13 ;los-hours
IF OLDSVN["OBSERVATION"
SET LOS=$$LOSHRS^BDGF1(ADM,DGDT,DFN)
+14 ;
+15 ; collect patient data for report
+16 SET NAME=$$GET1^DIQ(2,DFN,.01)
SET X=$SELECT(OLDSVN["OBSERVATION":"O",OLDSVN="DAY SURGERY":"D",1:"I")
+17 ;ihs/cmi/maw patch 1019
IF $$DEMO^APCLUTL(DFN,"E")
QUIT
+18 SET DATA=OLDSV_U_OLDWD
+19 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 changed AGE call to official API
+20 ;I BDGFRM="D" S DATA=DATA_U_$$LASTPRV^BDGF1(ADM,DFN)_U_$$AGE^BDGF2(DFN,+$G(^DGPM(ADM,0))) ;add provider and age at admission
+21 ;add provider and age at admission
IF BDGFRM="D"
SET DATA=DATA_U_$$LASTPRV^BDGF1(ADM,DFN)_U_$$AGE^AUPNPAT(DFN,+$GET(^DGPM(ADM,0)))
+22 ;
+23 IF TYPE["DEATH"
Begin DoDot:1
+24 SET ^TMP("BDGAD",$JOB,"DEATH",NAME,DFN)=DATA
End DoDot:1
+25 ;
+26 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003
+27 IF '$TEST
Begin DoDot:1
+28 IF OLDSVN="NEWBORN"
Begin DoDot:2
+29 ;S ^TMP("BDGAD",$J,"DSCH","N",NAME,DFN)=DATA
+30 SET ^TMP("BDGAD",$JOB,"DSCH","N",NAME,DFN,IFN)=DATA
End DoDot:2
+31 ;E S ^TMP("BDGAD",$J,"DSCH",X,NAME,DFN)=DATA
+32 IF '$TEST
SET ^TMP("BDGAD",$JOB,"DSCH",X,NAME,DFN,IFN)=DATA
End DoDot:1
+33 ;end of PATCH 1003 changes
+34 ;
+35 ;reprint, not recalculating
IF $GET(BDGREP)
QUIT
+36 ;
+37 ;
+38 ; -- increment counts in ADT Census files
+39 ; --- discharge for service within ward
+40 ; ---- set zero node if needed
+41 IF '$DATA(^BDGCWD(OLDWD,1,BDGT,1,OLDSV))
Begin DoDot:1
+42 SET ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV
+43 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)
End DoDot:1
+44 ;
+45 ; ---- increment discharge/death counts
+46 SET PIECE=$SELECT(ADULT:4,1:14)
+47 IF TYPE["DEATH"
Begin DoDot:1
+48 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,(PIECE+3))=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,(PIECE+3))+1
+49 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,7)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,7)+1
+50 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,(PIECE+3))=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,(PIECE+3))+1
End DoDot:1
+51 IF '$TEST
Begin DoDot:1
+52 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,PIECE)+1
+53 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,4)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,4)+1
+54 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,PIECE)+1
End DoDot:1
+55 ;
+56 ; --- increment LOS (inpt in days/observations in hours)
+57 IF OLDSVN["OBSERVATION"
SET PIECE=$SELECT(ADULT:11,1:21)
+58 IF '$TEST
SET PIECE=$SELECT(ADULT:9,1:19)
+59 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,$SELECT(PIECE=19:9,PIECE=21:11,1:PIECE))=$PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,$SELECT(PIECE=19:9,PIECE=21:11,1:PIECE))+LOS
+60 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)+LOS
+61 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)+LOS
+62 ;
+63 ; --- increment one day inpatients
+64 IF (DGDT\1)=($PIECE(^DGPM(ADM,0),U)\1)
Begin DoDot:1
+65 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,8)=$PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,8)+1
+66 SET PIECE=$SELECT(ADULT:8,1:18)
+67 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)=$PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,PIECE)+1
+68 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)=$PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,PIECE)+1
End DoDot:1
+69 ;
+70 QUIT
+71 ;
AGE() ;--age at admit
+1 NEW X,X1,X2
+2 ;admit date
SET X1=+$GET(^DGPM(ADM,0))
+3 ;date of birth
SET X2=$PIECE($GET(^DPT(DFN,0)),U,3)
DO ^%DTC
+4 IF 'X
QUIT ""
QUIT X\365.25
+5 ;
