- 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 ;
