BDGM202A ; IHS/ANMC/LJF - M202 CALCULATE ; [ 12/27/2004 3:24 PM ]
;;5.3;PIMS;**1001,1003,1005,1006,1008,1010,1013**;MAY 28, 2004
;IHS/ITSC/LJF 10/25/2004 PATCH 1001 count even if service is now inactive
; 04/27/2005 PATCH 1003 fixed code so transfers from observation to inpatient are counted as admissions
;IHS/OIT/LJF 05/04/2006 PATCH 1005 rewrote logic to count authorized beds
; 08/24/2006 PATCH 1006 added separate counts for observations and swing beds
;cmi/anch/maw 11/07/2007 PATCH 1008 Q:'$D(REM) as sometimes its not there when PEAK gets called
;cmi/anch/maw 09/19/2008 PATCH 1010 counts for special service (observations) were not correct in BOM and EOM
;ihs/cmi/maw 04/18/2011 PATCH 1013 RQMT155 added day surgery
;
NEW BDGBD,BDGED,REM,DGA,DGLOS,BDGOB
D INIT ;initialize counts
D LOOP ;loop thru census files and count
D PEAK ;count peak and minimum census
D AUTHBEDS ;count authorized beds
D NONBEN ;count non-beneficiaries discharges
;D OBSERV ;count observations;IHS/OIT/LJF 08/24/2006 PATCH 1006 no longer needed
D ^BDGM202B ;print report
D EXIT ;clean up and close
Q
;
INIT ; -- initialize variables
NEW I,J,X1,X2,X
;
; for 7 service categories in Part I, initialize 10 count categories
; service categories are Med/Surg (adult), Med/Surg (peds), OB
; TB, Alcohol/Subs Abuse, Mental Health and Newborn
; count categories are beginning census, admits, transfers in,
; deaths, other discharges, transfer out, ending census,
; inpt days, los and # of 1 day pts
F I=1:1:7 F J=1:1:10 S DGA(I,J)=0
;
;IHS/OIT/LJF 08/24/2006 PATCH 1006 adding swing bed & observations
;F I=8,9 F J=1:1:10 S DGA(I,J)=0
F I=8,9,10 F J=1:1:10 S DGA(I,J)=0 ;ihs/cmi/maw 04/18/2011 added day surgery
;
; length of stay stats (Part III) only has 3 categories
; adult, peds and newborn
F I=1,2,4 S DGLOS(I)=1
;
; set starting and ending dates
S X1=$E(BDGBM,1,5)_"01",X2=-1 D C^%DTC S BDGBD=X
S BDGED=$E(BDGEM,1,5)_"31.9"
;
Q
;
LOOP ; -- loop census file
; TS=treating specialty ien
; SS=1 if special service, 0 if not, "" if observation (don't count)
; LD=last date (used to find end of month census)
NEW TS,SS,LD
S TS=0 F S TS=$O(^BDGCTX(TS)) Q:'TS D
. S SS=$$SS(TS) I SS'="" D BOM,DAYS,EOM
Q
;
BOM ; -- patients in service (beginning of month)
; -- special service (adult & peds counts)
;I SS S DGA(SS,1)=$P($G(^BDGCTX(TS,1,BDGBD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 orig line
I SS S DGA(SS,1)=DGA(SS,1)+$P($G(^BDGCTX(TS,1,BDGBD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 PATCH 1010 found by Chinle
; -- med/surg (adult=1, ped=2)
S DGA(1,1)=DGA(1,1)+$P($G(^BDGCTX(+TS,1,+BDGBD,0)),U,2)
S DGA(2,1)=DGA(2,1)+$P($G(^BDGCTX(+TS,1,+BDGBD,0)),U,12)
Q
;
DAYS ; -- loop days and count
NEW RD
S RD=BDGBD F S RD=$O(^BDGCTX(TS,1,RD)) Q:'RD!(RD>BDGED) D
. S DATA=$G(^BDGCTX(+TS,1,+RD,0)) D COUNT
. S LD=RD ;set last date
Q
;
COUNT ; count for service and date
NEW SV
; count remaining by date excluding newborns
I SS'=4 S REM(RD)=$G(REM(RD))+$P(DATA,U,2)+$P(DATA,U,12)
;
; -- adult
S SV=$S(SS:SS,1:1) ;subscript for adult data
S DGA(SV,2)=DGA(SV,2)+$P(DATA,U,3) ;admits
S DGA(SV,3)=DGA(SV,3)+$P(DATA,U,7) ;deaths
S DGA(SV,4)=DGA(SV,4)+$P(DATA,U,4) ;discharges
S DGA(SV,6)=DGA(SV,6)+$P(DATA,U,2)+$P(DATA,U,8) ;# remain + 1 day pts
S DGA(SV,7)=DGA(SV,7)+$P(DATA,U,5) ;transfers in
S DGA(SV,8)=DGA(SV,8)+$P(DATA,U,6) ;transfer out
;
;IHS/OIT/LJF 08/24/2006 PATCH 1006 account for observations
;S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,9) ;los for discharges
S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,$S(SV=9:11,1:9)) ;los for discharges
;
S DGA(SV,10)=DGA(SV,10)+$P(DATA,U,8) ;1day pts
;
; count # of adult patients who left service on date
; counts deaths, discharges and transfers out
S DGLOS(1)=DGLOS(1)+$P(DATA,U,4)+$P(DATA,U,7)+$P(DATA,U,6)
;
; -- peds
S SV=$S(SS:SS,1:2) ;subscript for peds data
S DGA(SV,2)=DGA(SV,2)+$P(DATA,U,13) ;admits
S DGA(SV,3)=DGA(SV,3)+$P(DATA,U,17) ;deaths
S DGA(SV,4)=DGA(SV,4)+$P(DATA,U,14) ;discharges
S DGA(SV,6)=DGA(SV,6)+$P(DATA,U,12)+$P(DATA,U,18) ;# remain+1 day pts
S DGA(SV,7)=DGA(SV,7)+$P(DATA,U,15) ;transfers in
S DGA(SV,8)=DGA(SV,8)+$P(DATA,U,16) ;transfers out
;
;IHS/OIT/LJF 08/24/2006 PATCH 1006 account for observations
;S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,19) ;los for discharges
S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,$S(SV=9:21,1:19)) ;los for discharges
;
S DGA(SV,10)=DGA(SV,10)+$P(DATA,U,18) ;1 day pts
;
; count # of peds patients who left service on date
I SS=4 D Q ;count newborns separately
. S DGLOS(4)=DGLOS(4)+$P(DATA,U,3)+$P(DATA,U,6)+$P(DATA,U,5)
S DGLOS(2)=DGLOS(2)+$P(DATA,U,3)+$P(DATA,U,6)+$P(DATA,U,5)
Q
;
EOM ; -- patients in service (end of month)
Q:'$G(LD) ;no data, so no last date
; -- special service (adult & peds counts)
;I SS S DGA(SS,5)=$P($G(^BDGCTX(TS,1,LD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 orig line
I SS S DGA(SS,5)=DGA(SS,5)+$P($G(^BDGCTX(TS,1,LD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 mod line PATCH 1010 found at Chinle
; -- med/surg (adult=1; peds=2)
S DGA(1,5)=DGA(1,5)+$P($G(^BDGCTX(+TS,1,+LD,0)),U,2)
S DGA(2,5)=DGA(2,5)+$P($G(^BDGCTX(+TS,1,+LD,0)),U,12)
Q
;
PEAK ; -- peak and minimum
Q:'$D(REM)
S RD=$O(REM(0)),(DGMAX,DGMIN)=REM(RD)
F S RD=$O(REM(RD)) Q:'RD D
. I REM(RD)>DGMAX S DGMAX=REM(RD) Q
. I REM(RD)<DGMIN S DGMIN=REM(RD)
Q
;
AUTHBEDS ; -- authorized beds by category
D NEWAUTH Q ;IHS/OIT/LJF 05/04/2006 PATCH 1005 rewrote logic under NEWAUTH
NEW C,WD,P,N
F C="AM","AS","PM","PS","I","O","N","T","AL","MH","P" S DGBED(C)=0
S WD=0 F S WD=$O(^BDGWD(WD)) Q:'WD D
. ;Q:$$GET1^DIQ(9009016.5,WD,.03)="INACTIVE" ;IHS/ITSC/LJF 10/25/2004 PATCH 1001
. ;
. ;
. S N=$G(^BDGWD(WD,1)) ;node with authorized bed numbers
. S P=10 F C="AM","AS","PM","PS","O","N","T","AL","MH" D
.. S P=P+1,DGBED(C)=DGBED(C)+$P(N,U,P)
. ;
. ; now for ICU numbers
. S DGBED("I")=DGBED("I")+$P(N,U,2)
. S DGBED("P")=DGBED("P")+$P(N,U,3)
Q
;
NONBEN ; -- # of non-beneficiaries discharged
; DGLOS=total length of stay of non-bens
; DGCNT=total # ofnonbens
NEW RD,DFN,IEN,X,DGPMIFN
S RD=BDGBD,(DGLOS,DGCNT)=0
F S RD=$O(^DGPM("AMV1",RD)) Q:'RD!(RD>BDGED) D
. S DFN=0 F S DFN=$O(^DGPM("AMV1",RD,DFN)) Q:'DFN D
.. Q:$$GET1^DIQ(9000001,DFN,1112)'="INELIGIBLE"
.. S IEN=0 F S IEN=$O(^DGPM("AMV1",RD,DFN,IEN)) Q:'IEN D
... S DGPMIFN=IEN D ^DGPMLOS S DGCNT=DGCNT+1,DGLOS=DGLOS+$P(X,U,5)
Q
;
OBSERV ; count # of observations
; also update inpt counts for unplanned admits from observation status
; for any transfers out of service, find inpt service by code
; then ad one admit for inpt service and subtract one transfer in
; BDGOB = # of observations
;
NEW TS,SS,RD,DATA
S TS=0 F S TS=$O(^BDGCTX(TS)) Q:'TS D
. S SS=$$SS(TS) Q:SS'=""
. S RD=BDGBD F S RD=$O(^BDGCTX(TS,1,RD)) Q:'RD!(RD>BDGED) D
.. S DATA=$G(^BDGCTX(+TS,1,+RD,0))
.. S BDGOB=$G(BDGOB)+$P(DATA,U,4)+$P(DATA,U,7)+$P(DATA,U,14)+$P(DATA,U,17)
.. ;
.. ; if any transfers out, assume admits to inpt status
.. I ($P(DATA,U,6)>0)!($P(DATA,U,16)>0) D
... NEW ITS,ISS,SV
... S ITS=$$ITS(TS) Q:ITS="" ;find inpt service
... S ISS=$$SS(ITS) Q:ISS="" ;find inpt service category
... S SV=$S(ISS:ISS,1:1) ;subscript for adult data
... ; adult counts
... S DGA(SV,2)=DGA(SV,2)+$P(DATA,U,6) ;convert TXO to ADM
... S DGA(SV,7)=DGA(SV,7)-$P(DATA,U,6) ;subtract TXI, now ADM
... ; peds counts
... S SV=$S(ISS:ISS,1:2) ;subscript for peds data
... S DGA(SV,2)=DGA(SV,2)+$P(DATA,U,16) ;convert TXO to ADM
... S DGA(SV,7)=DGA(SV,7)-$P(DATA,U,16) ;subtract TXI, now ADM
Q
;
EXIT ; -- cleanup
W @IOF D ^%ZISC
K DGA,BDGBM,BDGEM,DGMAX,DGMIN,DGLOS,DGCNT,DGBED
Q
;
SS(T) ; -- special service 3 ob, 4 nb, 5 tb, 6 mh, 7 al
; --- ts ihs code 08 07 13 12 15
; --- observation services return ""
; --- non SS = adult (1) or peds (2)
NEW X S X=$$GET1^DIQ(45.7,+T,9999999.01)
;
;IHS/OIT/LJF 08/24/2006 PATCH 1006 accounts for observations & swing bed
;Q $S(X["O":"",X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,1:0)
;Q $S(X["O":9,X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,X="21":8,1:0)
Q $S(X["O":9,X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,X="21":8,X="23":10,1:0) ;ihs/cmi/maw 04/18/2011 added day surgery
;
ITS(T) ; find corresponding inpt service for observation service
NEW X,Y
S X=$$GET1^DIQ(45.7,+T,9999999.01) I X'["O" Q ""
;S Y=$O(^DIC(45.7,"CIHS",+X,0)) I 'Y Q ""
S Y=$O(^DIC(45.7,"CIHS",$E(X,1,2),0)) I 'Y Q "" ;IHS/ITSC/LJF 4/27/2005 PATCH 1003
Q Y
;
NEWAUTH ; -- authorized beds by category ;IHS/OIT/LJF 05/04/2006 PATCH 1005 new logic
NEW TYPE,WARD,IEN,COUNT,TMP,NODE,DATE
;initialize total counts
F TYPE="AM","AS","PM","PS","IC","OB","NB","TB","AL","MH","PC" S DGBED(TYPE)=0
;
;for each ward find all counts
S WARD=0 F S WARD=$O(^BDGWD(WARD)) Q:'WARD D
. K TMP
. S IEN=0 F S IEN=$O(^BDGWD(WARD,2,IEN)) Q:'IEN D
. . S NODE=$G(^BDGWD(WARD,2,IEN,0)) ;node with authorized bed numbers
. . S DATE=$P(NODE,U) Q:DATE>BDGED ;beds added to authorized totals after this month
. . S TYPE=$P(NODE,U,2) S TMP(TYPE,DATE)=$P(NODE,U,3)
. ;
. ; add this ward's counts to totals (find most recent for type)
. S TYPE=0 F S TYPE=$O(TMP(TYPE)) Q:TYPE="" D
. . S DATE=$O(TMP(TYPE,""),-1)
. . S DGBED(TYPE)=DGBED(TYPE)+TMP(TYPE,DATE)
Q
BDGM202A ; IHS/ANMC/LJF - M202 CALCULATE ; [ 12/27/2004 3:24 PM ]
+1 ;;5.3;PIMS;**1001,1003,1005,1006,1008,1010,1013**;MAY 28, 2004
+2 ;IHS/ITSC/LJF 10/25/2004 PATCH 1001 count even if service is now inactive
+3 ; 04/27/2005 PATCH 1003 fixed code so transfers from observation to inpatient are counted as admissions
+4 ;IHS/OIT/LJF 05/04/2006 PATCH 1005 rewrote logic to count authorized beds
+5 ; 08/24/2006 PATCH 1006 added separate counts for observations and swing beds
+6 ;cmi/anch/maw 11/07/2007 PATCH 1008 Q:'$D(REM) as sometimes its not there when PEAK gets called
+7 ;cmi/anch/maw 09/19/2008 PATCH 1010 counts for special service (observations) were not correct in BOM and EOM
+8 ;ihs/cmi/maw 04/18/2011 PATCH 1013 RQMT155 added day surgery
+9 ;
+10 NEW BDGBD,BDGED,REM,DGA,DGLOS,BDGOB
+11 ;initialize counts
DO INIT
+12 ;loop thru census files and count
DO LOOP
+13 ;count peak and minimum census
DO PEAK
+14 ;count authorized beds
DO AUTHBEDS
+15 ;count non-beneficiaries discharges
DO NONBEN
+16 ;D OBSERV ;count observations;IHS/OIT/LJF 08/24/2006 PATCH 1006 no longer needed
+17 ;print report
DO ^BDGM202B
+18 ;clean up and close
DO EXIT
+19 QUIT
+20 ;
INIT ; -- initialize variables
+1 NEW I,J,X1,X2,X
+2 ;
+3 ; for 7 service categories in Part I, initialize 10 count categories
+4 ; service categories are Med/Surg (adult), Med/Surg (peds), OB
+5 ; TB, Alcohol/Subs Abuse, Mental Health and Newborn
+6 ; count categories are beginning census, admits, transfers in,
+7 ; deaths, other discharges, transfer out, ending census,
+8 ; inpt days, los and # of 1 day pts
+9 FOR I=1:1:7
FOR J=1:1:10
SET DGA(I,J)=0
+10 ;
+11 ;IHS/OIT/LJF 08/24/2006 PATCH 1006 adding swing bed & observations
+12 ;F I=8,9 F J=1:1:10 S DGA(I,J)=0
+13 ;ihs/cmi/maw 04/18/2011 added day surgery
FOR I=8,9,10
FOR J=1:1:10
SET DGA(I,J)=0
+14 ;
+15 ; length of stay stats (Part III) only has 3 categories
+16 ; adult, peds and newborn
+17 FOR I=1,2,4
SET DGLOS(I)=1
+18 ;
+19 ; set starting and ending dates
+20 SET X1=$EXTRACT(BDGBM,1,5)_"01"
SET X2=-1
DO C^%DTC
SET BDGBD=X
+21 SET BDGED=$EXTRACT(BDGEM,1,5)_"31.9"
+22 ;
+23 QUIT
+24 ;
LOOP ; -- loop census file
+1 ; TS=treating specialty ien
+2 ; SS=1 if special service, 0 if not, "" if observation (don't count)
+3 ; LD=last date (used to find end of month census)
+4 NEW TS,SS,LD
+5 SET TS=0
FOR
SET TS=$ORDER(^BDGCTX(TS))
IF 'TS
QUIT
Begin DoDot:1
+6 SET SS=$$SS(TS)
IF SS'=""
DO BOM
DO DAYS
DO EOM
End DoDot:1
+7 QUIT
+8 ;
BOM ; -- patients in service (beginning of month)
+1 ; -- special service (adult & peds counts)
+2 ;I SS S DGA(SS,1)=$P($G(^BDGCTX(TS,1,BDGBD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 orig line
+3 ;cmi/anch/maw 9/19/2008 PATCH 1010 found by Chinle
IF SS
SET DGA(SS,1)=DGA(SS,1)+$PIECE($GET(^BDGCTX(TS,1,BDGBD,0)),U,2)+$PIECE($GET(^(0)),U,12)
QUIT
+4 ; -- med/surg (adult=1, ped=2)
+5 SET DGA(1,1)=DGA(1,1)+$PIECE($GET(^BDGCTX(+TS,1,+BDGBD,0)),U,2)
+6 SET DGA(2,1)=DGA(2,1)+$PIECE($GET(^BDGCTX(+TS,1,+BDGBD,0)),U,12)
+7 QUIT
+8 ;
DAYS ; -- loop days and count
+1 NEW RD
+2 SET RD=BDGBD
FOR
SET RD=$ORDER(^BDGCTX(TS,1,RD))
IF 'RD!(RD>BDGED)
QUIT
Begin DoDot:1
+3 SET DATA=$GET(^BDGCTX(+TS,1,+RD,0))
DO COUNT
+4 ;set last date
SET LD=RD
End DoDot:1
+5 QUIT
+6 ;
COUNT ; count for service and date
+1 NEW SV
+2 ; count remaining by date excluding newborns
+3 IF SS'=4
SET REM(RD)=$GET(REM(RD))+$PIECE(DATA,U,2)+$PIECE(DATA,U,12)
+4 ;
+5 ; -- adult
+6 ;subscript for adult data
SET SV=$SELECT(SS:SS,1:1)
+7 ;admits
SET DGA(SV,2)=DGA(SV,2)+$PIECE(DATA,U,3)
+8 ;deaths
SET DGA(SV,3)=DGA(SV,3)+$PIECE(DATA,U,7)
+9 ;discharges
SET DGA(SV,4)=DGA(SV,4)+$PIECE(DATA,U,4)
+10 ;# remain + 1 day pts
SET DGA(SV,6)=DGA(SV,6)+$PIECE(DATA,U,2)+$PIECE(DATA,U,8)
+11 ;transfers in
SET DGA(SV,7)=DGA(SV,7)+$PIECE(DATA,U,5)
+12 ;transfer out
SET DGA(SV,8)=DGA(SV,8)+$PIECE(DATA,U,6)
+13 ;
+14 ;IHS/OIT/LJF 08/24/2006 PATCH 1006 account for observations
+15 ;S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,9) ;los for discharges
+16 ;los for discharges
SET DGA(SV,9)=DGA(SV,9)+$PIECE(DATA,U,$SELECT(SV=9:11,1:9))
+17 ;
+18 ;1day pts
SET DGA(SV,10)=DGA(SV,10)+$PIECE(DATA,U,8)
+19 ;
+20 ; count # of adult patients who left service on date
+21 ; counts deaths, discharges and transfers out
+22 SET DGLOS(1)=DGLOS(1)+$PIECE(DATA,U,4)+$PIECE(DATA,U,7)+$PIECE(DATA,U,6)
+23 ;
+24 ; -- peds
+25 ;subscript for peds data
SET SV=$SELECT(SS:SS,1:2)
+26 ;admits
SET DGA(SV,2)=DGA(SV,2)+$PIECE(DATA,U,13)
+27 ;deaths
SET DGA(SV,3)=DGA(SV,3)+$PIECE(DATA,U,17)
+28 ;discharges
SET DGA(SV,4)=DGA(SV,4)+$PIECE(DATA,U,14)
+29 ;# remain+1 day pts
SET DGA(SV,6)=DGA(SV,6)+$PIECE(DATA,U,12)+$PIECE(DATA,U,18)
+30 ;transfers in
SET DGA(SV,7)=DGA(SV,7)+$PIECE(DATA,U,15)
+31 ;transfers out
SET DGA(SV,8)=DGA(SV,8)+$PIECE(DATA,U,16)
+32 ;
+33 ;IHS/OIT/LJF 08/24/2006 PATCH 1006 account for observations
+34 ;S DGA(SV,9)=DGA(SV,9)+$P(DATA,U,19) ;los for discharges
+35 ;los for discharges
SET DGA(SV,9)=DGA(SV,9)+$PIECE(DATA,U,$SELECT(SV=9:21,1:19))
+36 ;
+37 ;1 day pts
SET DGA(SV,10)=DGA(SV,10)+$PIECE(DATA,U,18)
+38 ;
+39 ; count # of peds patients who left service on date
+40 ;count newborns separately
IF SS=4
Begin DoDot:1
+41 SET DGLOS(4)=DGLOS(4)+$PIECE(DATA,U,3)+$PIECE(DATA,U,6)+$PIECE(DATA,U,5)
End DoDot:1
QUIT
+42 SET DGLOS(2)=DGLOS(2)+$PIECE(DATA,U,3)+$PIECE(DATA,U,6)+$PIECE(DATA,U,5)
+43 QUIT
+44 ;
EOM ; -- patients in service (end of month)
+1 ;no data, so no last date
IF '$GET(LD)
QUIT
+2 ; -- special service (adult & peds counts)
+3 ;I SS S DGA(SS,5)=$P($G(^BDGCTX(TS,1,LD,0)),U,2)+$P($G(^(0)),U,12) Q ;cmi/anch/maw 9/19/2008 orig line
+4 ;cmi/anch/maw 9/19/2008 mod line PATCH 1010 found at Chinle
IF SS
SET DGA(SS,5)=DGA(SS,5)+$PIECE($GET(^BDGCTX(TS,1,LD,0)),U,2)+$PIECE($GET(^(0)),U,12)
QUIT
+5 ; -- med/surg (adult=1; peds=2)
+6 SET DGA(1,5)=DGA(1,5)+$PIECE($GET(^BDGCTX(+TS,1,+LD,0)),U,2)
+7 SET DGA(2,5)=DGA(2,5)+$PIECE($GET(^BDGCTX(+TS,1,+LD,0)),U,12)
+8 QUIT
+9 ;
PEAK ; -- peak and minimum
+1 IF '$DATA(REM)
QUIT
+2 SET RD=$ORDER(REM(0))
SET (DGMAX,DGMIN)=REM(RD)
+3 FOR
SET RD=$ORDER(REM(RD))
IF 'RD
QUIT
Begin DoDot:1
+4 IF REM(RD)>DGMAX
SET DGMAX=REM(RD)
QUIT
+5 IF REM(RD)<DGMIN
SET DGMIN=REM(RD)
End DoDot:1
+6 QUIT
+7 ;
AUTHBEDS ; -- authorized beds by category
+1 ;IHS/OIT/LJF 05/04/2006 PATCH 1005 rewrote logic under NEWAUTH
DO NEWAUTH
QUIT
+2 NEW C,WD,P,N
+3 FOR C="AM","AS","PM","PS","I","O","N","T","AL","MH","P"
SET DGBED(C)=0
+4 SET WD=0
FOR
SET WD=$ORDER(^BDGWD(WD))
IF 'WD
QUIT
Begin DoDot:1
+5 ;Q:$$GET1^DIQ(9009016.5,WD,.03)="INACTIVE" ;IHS/ITSC/LJF 10/25/2004 PATCH 1001
+6 ;
+7 ;
+8 ;node with authorized bed numbers
SET N=$GET(^BDGWD(WD,1))
+9 SET P=10
FOR C="AM","AS","PM","PS","O","N","T","AL","MH"
Begin DoDot:2
+10 SET P=P+1
SET DGBED(C)=DGBED(C)+$PIECE(N,U,P)
End DoDot:2
+11 ;
+12 ; now for ICU numbers
+13 SET DGBED("I")=DGBED("I")+$PIECE(N,U,2)
+14 SET DGBED("P")=DGBED("P")+$PIECE(N,U,3)
End DoDot:1
+15 QUIT
+16 ;
NONBEN ; -- # of non-beneficiaries discharged
+1 ; DGLOS=total length of stay of non-bens
+2 ; DGCNT=total # ofnonbens
+3 NEW RD,DFN,IEN,X,DGPMIFN
+4 SET RD=BDGBD
SET (DGLOS,DGCNT)=0
+5 FOR
SET RD=$ORDER(^DGPM("AMV1",RD))
IF 'RD!(RD>BDGED)
QUIT
Begin DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",RD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+7 IF $$GET1^DIQ(9000001,DFN,1112)'="INELIGIBLE"
QUIT
+8 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("AMV1",RD,DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+9 SET DGPMIFN=IEN
DO ^DGPMLOS
SET DGCNT=DGCNT+1
SET DGLOS=DGLOS+$PIECE(X,U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
OBSERV ; count # of observations
+1 ; also update inpt counts for unplanned admits from observation status
+2 ; for any transfers out of service, find inpt service by code
+3 ; then ad one admit for inpt service and subtract one transfer in
+4 ; BDGOB = # of observations
+5 ;
+6 NEW TS,SS,RD,DATA
+7 SET TS=0
FOR
SET TS=$ORDER(^BDGCTX(TS))
IF 'TS
QUIT
Begin DoDot:1
+8 SET SS=$$SS(TS)
IF SS'=""
QUIT
+9 SET RD=BDGBD
FOR
SET RD=$ORDER(^BDGCTX(TS,1,RD))
IF 'RD!(RD>BDGED)
QUIT
Begin DoDot:2
+10 SET DATA=$GET(^BDGCTX(+TS,1,+RD,0))
+11 SET BDGOB=$GET(BDGOB)+$PIECE(DATA,U,4)+$PIECE(DATA,U,7)+$PIECE(DATA,U,14)+$PIECE(DATA,U,17)
+12 ;
+13 ; if any transfers out, assume admits to inpt status
+14 IF ($PIECE(DATA,U,6)>0)!($PIECE(DATA,U,16)>0)
Begin DoDot:3
+15 NEW ITS,ISS,SV
+16 ;find inpt service
SET ITS=$$ITS(TS)
IF ITS=""
QUIT
+17 ;find inpt service category
SET ISS=$$SS(ITS)
IF ISS=""
QUIT
+18 ;subscript for adult data
SET SV=$SELECT(ISS:ISS,1:1)
+19 ; adult counts
+20 ;convert TXO to ADM
SET DGA(SV,2)=DGA(SV,2)+$PIECE(DATA,U,6)
+21 ;subtract TXI, now ADM
SET DGA(SV,7)=DGA(SV,7)-$PIECE(DATA,U,6)
+22 ; peds counts
+23 ;subscript for peds data
SET SV=$SELECT(ISS:ISS,1:2)
+24 ;convert TXO to ADM
SET DGA(SV,2)=DGA(SV,2)+$PIECE(DATA,U,16)
+25 ;subtract TXI, now ADM
SET DGA(SV,7)=DGA(SV,7)-$PIECE(DATA,U,16)
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
EXIT ; -- cleanup
+1 WRITE @IOF
DO ^%ZISC
+2 KILL DGA,BDGBM,BDGEM,DGMAX,DGMIN,DGLOS,DGCNT,DGBED
+3 QUIT
+4 ;
SS(T) ; -- special service 3 ob, 4 nb, 5 tb, 6 mh, 7 al
+1 ; --- ts ihs code 08 07 13 12 15
+2 ; --- observation services return ""
+3 ; --- non SS = adult (1) or peds (2)
+4 NEW X
SET X=$$GET1^DIQ(45.7,+T,9999999.01)
+5 ;
+6 ;IHS/OIT/LJF 08/24/2006 PATCH 1006 accounts for observations & swing bed
+7 ;Q $S(X["O":"",X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,1:0)
+8 ;Q $S(X["O":9,X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,X="21":8,1:0)
+9 ;ihs/cmi/maw 04/18/2011 added day surgery
QUIT $SELECT(X["O":9,X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,X="21":8,X="23":10,1:0)
+10 ;
ITS(T) ; find corresponding inpt service for observation service
+1 NEW X,Y
+2 SET X=$$GET1^DIQ(45.7,+T,9999999.01)
IF X'["O"
QUIT ""
+3 ;S Y=$O(^DIC(45.7,"CIHS",+X,0)) I 'Y Q ""
+4 ;IHS/ITSC/LJF 4/27/2005 PATCH 1003
SET Y=$ORDER(^DIC(45.7,"CIHS",$EXTRACT(X,1,2),0))
IF 'Y
QUIT ""
+5 QUIT Y
+6 ;
NEWAUTH ; -- authorized beds by category ;IHS/OIT/LJF 05/04/2006 PATCH 1005 new logic
+1 NEW TYPE,WARD,IEN,COUNT,TMP,NODE,DATE
+2 ;initialize total counts
+3 FOR TYPE="AM","AS","PM","PS","IC","OB","NB","TB","AL","MH","PC"
SET DGBED(TYPE)=0
+4 ;
+5 ;for each ward find all counts
+6 SET WARD=0
FOR
SET WARD=$ORDER(^BDGWD(WARD))
IF 'WARD
QUIT
Begin DoDot:1
+7 KILL TMP
+8 SET IEN=0
FOR
SET IEN=$ORDER(^BDGWD(WARD,2,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+9 ;node with authorized bed numbers
SET NODE=$GET(^BDGWD(WARD,2,IEN,0))
+10 ;beds added to authorized totals after this month
SET DATE=$PIECE(NODE,U)
IF DATE>BDGED
QUIT
+11 SET TYPE=$PIECE(NODE,U,2)
SET TMP(TYPE,DATE)=$PIECE(NODE,U,3)
End DoDot:2
+12 ;
+13 ; add this ward's counts to totals (find most recent for type)
+14 SET TYPE=0
FOR
SET TYPE=$ORDER(TMP(TYPE))
IF TYPE=""
QUIT
Begin DoDot:2
+15 SET DATE=$ORDER(TMP(TYPE,""),-1)
+16 SET DGBED(TYPE)=DGBED(TYPE)+TMP(TYPE,DATE)
End DoDot:2
End DoDot:1
+17 QUIT
