ADGSRVC ; IHS/ADC/PDW/ENM - HSA-202 CALCULATE ; [ 09/25/2000 4:00 PM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
;
N ED,IEN,LD,LN,ND,PD,PED,RD,ADU,X,Y,X1,X2
D INI I '$D(^ADGTX(+$O(^ADGTX(0)),1,+PD)) W !!,"No data",!! Q
A ; -- driver
D LTX,PK,AB,NB,^ADGSRVP,^ADGSRVP1,Q Q
;
INI ; -- initialize variables
N I,J F I=1:1:7 F J=1:1:10 S DGA(I,J)=0
F I=1,2,4 S DGLOS(I)=1
S X1=$E(DGMON,1,5)_"01",X2=-1 D C^%DTC S PD=X
S ED=$E(DGMON,1,5)_"31.9" Q
;
LTX ; -- loop census file
S TS=0 F S TS=$O(^ADGTX(TS)) Q:'TS D BOM,LRD,EOM
Q
;
BOM ; -- patients in service (beginning of month)
; -- special service
I $$SS S DGA($$SS,1)=$P($G(^ADGTX(+TS,1,+PD,0)),U,2)+$P($G(^(1)),U) Q
; -- other (adult=1, ped=2)
S DGA(1,1)=DGA(1,1)+$P($G(^ADGTX(+TS,1,+PD,0)),U,2)
S DGA(2,1)=DGA(2,1)+$P($G(^ADGTX(+TS,1,+PD,1)),U) Q
;
LRD ; -- loop days
S RD=PD F S RD=$O(^ADGTX(TS,1,RD)) Q:'RD!(RD>ED) D
. S:'$D(DGC(RD)) DGC(RD)=0 S ADU=$G(^ADGTX(+TS,1,+RD,0)),PED=$G(^(1))
. S LD=RD D SC:$$SS,OS:'$$SS
Q
;
SC ; -- counts, special service
S DGA($$SS,2)=DGA($$SS,2)+$P(ADU,U,3)+$P(PED,U,2) ;adm
S DGA($$SS,3)=DGA($$SS,3)+$P(ADU,U,7)+$P(PED,U,6) ;dth
S DGA($$SS,4)=DGA($$SS,4)+$P(ADU,U,4)+$P(PED,U,3) ;dsc
S DGA($$SS,6)=DGA($$SS,6)+$P(ADU,U,2)+$P(ADU,U,8)
S DGA($$SS,6)=DGA($$SS,6)+$P(PED,U)+$P(PED,U,7) ;rem
S DGA($$SS,7)=DGA($$SS,7)+$P(ADU,U,5)+$P(PED,U,4) ;tx in
S DGA($$SS,8)=DGA($$SS,8)+$P(ADU,U,6)+$P(PED,U,5) ;tx out
; -- adult
S DGA(1,9)=DGA(1,9)+$P(ADU,U,9) ;los
S DGA(1,10)=DGA(1,10)+$P(ADU,U,8) ;1day
S DGLOS(1)=DGLOS(1)+$P(ADU,U,4)+$P(ADU,U,7)+$P(ADU,U,6)
; -- day's count (exclude newborn)
S:$$SS'=4 DGC(RD)=DGC(RD)+$P(ADU,U,2)+$P(PED,U)
; -- newborn
I $$SS=4 D Q
. S DGA(4,9)=DGA(4,9)+$P(PED,U,8) ;los
. S DGA(4,10)=DGA(4,10)+$P(PED,U,7) ;1day
. S DGLOS(4)=DGLOS(4)+$P(PED,U,3)+$P(PED,U,6)+$P(PED,U,5)
; -- ped
S DGA(2,9)=DGA(2,9)+$P(PED,U,8) ;los
S DGA(2,10)=DGA(2,10)+$P(PED,U,7) ;1day
S DGLOS(2)=DGLOS(2)+$P(PED,U,3)+$P(PED,U,6)+$P(PED,U,5) Q
;
OS ; -- counts, other service
S DGC(RD)=DGC(RD)+$P(ADU,U,2)+$P(PED,U)
; -- adult
S DGA(1,2)=DGA(1,2)+$P(ADU,U,3) ;adm
S DGA(1,3)=DGA(1,3)+$P(ADU,U,7) ;dth
S DGA(1,4)=DGA(1,4)+$P(ADU,U,4) ;dsc
S DGA(1,6)=DGA(1,6)+$P(ADU,U,2)+$P(ADU,U,8) ;rem
S DGA(1,7)=DGA(1,7)+$P(ADU,U,5) ;IHS/ANMC/LJF/enm 4/10/97 ;tx in
S DGA(1,8)=DGA(1,8)+$P(ADU,U,6) ;IHS/ANMC/LJF/enm 4/10/97 ;tx out
S DGA(1,9)=DGA(1,9)+$P(ADU,U,9) ;los
S DGA(1,10)=DGA(1,10)+$P(ADU,U,8) ;1day
S DGLOS(1)=DGLOS(1)+$P(ADU,U,4)+$P(ADU,U,7)+$P(ADU,U,6)
; -- peds
S DGA(2,2)=DGA(2,2)+$P(PED,U,2) ;adm
S DGA(2,3)=DGA(2,3)+$P(PED,U,6) ;dth
S DGA(2,4)=DGA(2,4)+$P(PED,U,3) ;dsc
S DGA(2,6)=DGA(2,6)+$P(PED,U)+$P(PED,U,7) ;rem
S DGA(2,7)=DGA(2,7)+$P(PED,U,4) ;IHS/ANMC/LJF/ENM 4/10/97 ;tx in
S DGA(2,8)=DGA(2,8)+$P(PED,U,5) ;IHS/ANMC/LJF/ENM 4/10/97 ;tx out
S DGA(2,9)=DGA(2,9)+$P(PED,U,8) ;los
S DGA(2,10)=DGA(2,10)+$P(PED,U,7) ;1day
S DGLOS(2)=DGLOS(2)+$P(PED,U,3)+$P(PED,U,6)+$P(PED,U,5) Q
;
EOM ; -- patients in service (end of month)
I $$SS S DGA($$SS,5)=$P($G(^ADGTX(+TS,1,+LD,0)),U,2)+$P($G(^(1)),U) Q
S DGA(1,5)=DGA(1,5)+$P($G(^ADGTX(+TS,1,+LD,0)),U,2)
S DGA(2,5)=DGA(2,5)+$P($G(^ADGTX(+TS,1,+LD,1)),U) Q
;
PK ; -- peak and minimum
S RD=$O(DGC(0)),(DGMAX,DGMIN)=DGC(RD)
F S RD=$O(DGC(RD)) Q:'RD D
. I DGC(RD)>DGMAX S DGMAX=DGC(RD) Q
. I DGC(RD)<DGMIN S DGMIN=DGC(RD) Q
Q
;
AB ; -- authorized beds by category
N 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(^DIC(42,WD)) Q:'WD D
. Q:$G(^DIC(42,+WD,"I"))="I" Q:'$D(^DIC(42,+WD,"IHS1")) S N=^("IHS1")
. S P=0 F C="AM","AS","PM","PS","O","N","T","AL","MH" D
.. S P=P+1,DGBED(C)=DGBED(C)+$P(N,U,P)
. S DGBED("I")=DGBED("I")+$P($G(^DIC(42,WD,"IHS")),U,2)
. S DGBED("P")=DGBED("P")+$P($G(^DIC(42,WD,"IHS")),U,3)
Q
;
NB ; -- # of non-beneficiaries discharged
S RD=PD,(DGLOS,DGCNT)=0
F S RD=$O(^DGPM("AMV1",RD)) Q:'RD!(RD>ED) D
. S DFN=0 F S DFN=$O(^DGPM("AMV1",RD,DFN)) Q:'DFN D
.. Q:$P($G(^AUPNPAT(+DFN,11)),U,12)'="I"
.. 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
;
Q ; -- cleanup
W @IOF D ^%ZISC,KILL^ADGUTIL K DGA,DGMON,DGMAX,DGMIN,DGX,DGPMIFN Q
;
SS() ; -- special service 3 ob, 4 nb, 5 tb, 6 mh, 7 al ;non SS
; -- ts ihs code 08 07 13 12 15 ;------
N X S X=$P($G(^DIC(45.7,+TS,9999999)),U) ;adu 1
Q $S(X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,1:0) ;ped 2
ADGSRVC ; IHS/ADC/PDW/ENM - HSA-202 CALCULATE ; [ 09/25/2000 4:00 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
+2 ;
+3 NEW ED,IEN,LD,LN,ND,PD,PED,RD,ADU,X,Y,X1,X2
+4 DO INI
IF '$DATA(^ADGTX(+$ORDER(^ADGTX(0)),1,+PD))
WRITE !!,"No data",!!
QUIT
A ; -- driver
+1 DO LTX
DO PK
DO AB
DO NB
DO ^ADGSRVP
DO ^ADGSRVP1
DO Q
QUIT
+2 ;
INI ; -- initialize variables
+1 NEW I,J
FOR I=1:1:7
FOR J=1:1:10
SET DGA(I,J)=0
+2 FOR I=1,2,4
SET DGLOS(I)=1
+3 SET X1=$EXTRACT(DGMON,1,5)_"01"
SET X2=-1
DO C^%DTC
SET PD=X
+4 SET ED=$EXTRACT(DGMON,1,5)_"31.9"
QUIT
+5 ;
LTX ; -- loop census file
+1 SET TS=0
FOR
SET TS=$ORDER(^ADGTX(TS))
IF 'TS
QUIT
DO BOM
DO LRD
DO EOM
+2 QUIT
+3 ;
BOM ; -- patients in service (beginning of month)
+1 ; -- special service
+2 IF $$SS
SET DGA($$SS,1)=$PIECE($GET(^ADGTX(+TS,1,+PD,0)),U,2)+$PIECE($GET(^(1)),U)
QUIT
+3 ; -- other (adult=1, ped=2)
+4 SET DGA(1,1)=DGA(1,1)+$PIECE($GET(^ADGTX(+TS,1,+PD,0)),U,2)
+5 SET DGA(2,1)=DGA(2,1)+$PIECE($GET(^ADGTX(+TS,1,+PD,1)),U)
QUIT
+6 ;
LRD ; -- loop days
+1 SET RD=PD
FOR
SET RD=$ORDER(^ADGTX(TS,1,RD))
IF 'RD!(RD>ED)
QUIT
Begin DoDot:1
+2 IF '$DATA(DGC(RD))
SET DGC(RD)=0
SET ADU=$GET(^ADGTX(+TS,1,+RD,0))
SET PED=$GET(^(1))
+3 SET LD=RD
IF $$SS
DO SC
IF '$$SS
DO OS
End DoDot:1
+4 QUIT
+5 ;
SC ; -- counts, special service
+1 ;adm
SET DGA($$SS,2)=DGA($$SS,2)+$PIECE(ADU,U,3)+$PIECE(PED,U,2)
+2 ;dth
SET DGA($$SS,3)=DGA($$SS,3)+$PIECE(ADU,U,7)+$PIECE(PED,U,6)
+3 ;dsc
SET DGA($$SS,4)=DGA($$SS,4)+$PIECE(ADU,U,4)+$PIECE(PED,U,3)
+4 SET DGA($$SS,6)=DGA($$SS,6)+$PIECE(ADU,U,2)+$PIECE(ADU,U,8)
+5 ;rem
SET DGA($$SS,6)=DGA($$SS,6)+$PIECE(PED,U)+$PIECE(PED,U,7)
+6 ;tx in
SET DGA($$SS,7)=DGA($$SS,7)+$PIECE(ADU,U,5)+$PIECE(PED,U,4)
+7 ;tx out
SET DGA($$SS,8)=DGA($$SS,8)+$PIECE(ADU,U,6)+$PIECE(PED,U,5)
+8 ; -- adult
+9 ;los
SET DGA(1,9)=DGA(1,9)+$PIECE(ADU,U,9)
+10 ;1day
SET DGA(1,10)=DGA(1,10)+$PIECE(ADU,U,8)
+11 SET DGLOS(1)=DGLOS(1)+$PIECE(ADU,U,4)+$PIECE(ADU,U,7)+$PIECE(ADU,U,6)
+12 ; -- day's count (exclude newborn)
+13 IF $$SS'=4
SET DGC(RD)=DGC(RD)+$PIECE(ADU,U,2)+$PIECE(PED,U)
+14 ; -- newborn
+15 IF $$SS=4
Begin DoDot:1
+16 ;los
SET DGA(4,9)=DGA(4,9)+$PIECE(PED,U,8)
+17 ;1day
SET DGA(4,10)=DGA(4,10)+$PIECE(PED,U,7)
+18 SET DGLOS(4)=DGLOS(4)+$PIECE(PED,U,3)+$PIECE(PED,U,6)+$PIECE(PED,U,5)
End DoDot:1
QUIT
+19 ; -- ped
+20 ;los
SET DGA(2,9)=DGA(2,9)+$PIECE(PED,U,8)
+21 ;1day
SET DGA(2,10)=DGA(2,10)+$PIECE(PED,U,7)
+22 SET DGLOS(2)=DGLOS(2)+$PIECE(PED,U,3)+$PIECE(PED,U,6)+$PIECE(PED,U,5)
QUIT
+23 ;
OS ; -- counts, other service
+1 SET DGC(RD)=DGC(RD)+$PIECE(ADU,U,2)+$PIECE(PED,U)
+2 ; -- adult
+3 ;adm
SET DGA(1,2)=DGA(1,2)+$PIECE(ADU,U,3)
+4 ;dth
SET DGA(1,3)=DGA(1,3)+$PIECE(ADU,U,7)
+5 ;dsc
SET DGA(1,4)=DGA(1,4)+$PIECE(ADU,U,4)
+6 ;rem
SET DGA(1,6)=DGA(1,6)+$PIECE(ADU,U,2)+$PIECE(ADU,U,8)
+7 ;IHS/ANMC/LJF/enm 4/10/97 ;tx in
SET DGA(1,7)=DGA(1,7)+$PIECE(ADU,U,5)
+8 ;IHS/ANMC/LJF/enm 4/10/97 ;tx out
SET DGA(1,8)=DGA(1,8)+$PIECE(ADU,U,6)
+9 ;los
SET DGA(1,9)=DGA(1,9)+$PIECE(ADU,U,9)
+10 ;1day
SET DGA(1,10)=DGA(1,10)+$PIECE(ADU,U,8)
+11 SET DGLOS(1)=DGLOS(1)+$PIECE(ADU,U,4)+$PIECE(ADU,U,7)+$PIECE(ADU,U,6)
+12 ; -- peds
+13 ;adm
SET DGA(2,2)=DGA(2,2)+$PIECE(PED,U,2)
+14 ;dth
SET DGA(2,3)=DGA(2,3)+$PIECE(PED,U,6)
+15 ;dsc
SET DGA(2,4)=DGA(2,4)+$PIECE(PED,U,3)
+16 ;rem
SET DGA(2,6)=DGA(2,6)+$PIECE(PED,U)+$PIECE(PED,U,7)
+17 ;IHS/ANMC/LJF/ENM 4/10/97 ;tx in
SET DGA(2,7)=DGA(2,7)+$PIECE(PED,U,4)
+18 ;IHS/ANMC/LJF/ENM 4/10/97 ;tx out
SET DGA(2,8)=DGA(2,8)+$PIECE(PED,U,5)
+19 ;los
SET DGA(2,9)=DGA(2,9)+$PIECE(PED,U,8)
+20 ;1day
SET DGA(2,10)=DGA(2,10)+$PIECE(PED,U,7)
+21 SET DGLOS(2)=DGLOS(2)+$PIECE(PED,U,3)+$PIECE(PED,U,6)+$PIECE(PED,U,5)
QUIT
+22 ;
EOM ; -- patients in service (end of month)
+1 IF $$SS
SET DGA($$SS,5)=$PIECE($GET(^ADGTX(+TS,1,+LD,0)),U,2)+$PIECE($GET(^(1)),U)
QUIT
+2 SET DGA(1,5)=DGA(1,5)+$PIECE($GET(^ADGTX(+TS,1,+LD,0)),U,2)
+3 SET DGA(2,5)=DGA(2,5)+$PIECE($GET(^ADGTX(+TS,1,+LD,1)),U)
QUIT
+4 ;
PK ; -- peak and minimum
+1 SET RD=$ORDER(DGC(0))
SET (DGMAX,DGMIN)=DGC(RD)
+2 FOR
SET RD=$ORDER(DGC(RD))
IF 'RD
QUIT
Begin DoDot:1
+3 IF DGC(RD)>DGMAX
SET DGMAX=DGC(RD)
QUIT
+4 IF DGC(RD)<DGMIN
SET DGMIN=DGC(RD)
QUIT
End DoDot:1
+5 QUIT
+6 ;
AB ; -- authorized beds by category
+1 NEW C,WD,P,N
+2 FOR C="AM","AS","PM","PS","I","O","N","T","AL","MH","P"
SET DGBED(C)=0
+3 SET WD=0
FOR
SET WD=$ORDER(^DIC(42,WD))
IF 'WD
QUIT
Begin DoDot:1
+4 IF $GET(^DIC(42,+WD,"I"))="I"
QUIT
IF '$DATA(^DIC(42,+WD,"IHS1"))
QUIT
SET N=^("IHS1")
+5 SET P=0
FOR C="AM","AS","PM","PS","O","N","T","AL","MH"
Begin DoDot:2
+6 SET P=P+1
SET DGBED(C)=DGBED(C)+$PIECE(N,U,P)
End DoDot:2
+7 SET DGBED("I")=DGBED("I")+$PIECE($GET(^DIC(42,WD,"IHS")),U,2)
+8 SET DGBED("P")=DGBED("P")+$PIECE($GET(^DIC(42,WD,"IHS")),U,3)
End DoDot:1
+9 QUIT
+10 ;
NB ; -- # of non-beneficiaries discharged
+1 SET RD=PD
SET (DGLOS,DGCNT)=0
+2 FOR
SET RD=$ORDER(^DGPM("AMV1",RD))
IF 'RD!(RD>ED)
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",RD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^AUPNPAT(+DFN,11)),U,12)'="I"
QUIT
+5 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("AMV1",RD,DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+6 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
+7 QUIT
+8 ;
Q ; -- cleanup
+1 WRITE @IOF
DO ^%ZISC
DO KILL^ADGUTIL
KILL DGA,DGMON,DGMAX,DGMIN,DGX,DGPMIFN
QUIT
+2 ;
SS() ; -- special service 3 ob, 4 nb, 5 tb, 6 mh, 7 al ;non SS
+1 ; -- ts ihs code 08 07 13 12 15 ;------
+2 ;adu 1
NEW X
SET X=$PIECE($GET(^DIC(45.7,+TS,9999999)),U)
+3 ;ped 2
QUIT $SELECT(X="08":3,X="07":4,X="13":5,X="15":6,X="12":7,1:0)
