ADGSRVP1 ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 08/05/1999 8:51 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2,3**;MAR 25, 1999
;
N ND,LN S ND=$$ND,LN="",$P(LN,"-",40)=""
P3 W !,DGLINE,!?16,"Part III",!?13,"Beds Available"
W ?50,"Comments",!,LN,!,"STAFF UNITS",?21,"# of Beds",?32,"% Occup."
;W ?45,"ALOS: ",?60,"ADULT: ",$J(DGA(1,9)/DGLOS(1),1,2) ;adu alos
W ?45,"ALOS: ",?60,"ADULT: ",$J($$LOS1(),1,2)
W !,LN,?56,"PEDIATRIC: ",$J($$LOS2(),1,2) ;ped alos
W !?58,"NEWBORN: ",$J($$LOS4(),1,2) ;nb alos
W !,"MEDICAL (Adult)",?28,DGBED("AM") ;# med beds
W !,"SURGICAL (Adult)",?28,DGBED("AS"),?27,"_____" ;# sur beds
W ?45,"ADPL:",?60,"ADULT: ",$J(DGA(1,6)+DGA(3,6)/ND,1,2) ;adu adpl
W !?15,"Subtotal",?28,DGBED("AM")+DGBED("AS"),?35,$$OA ;adu # & %
W ?56,"PEDIATRIC: ",$J(DGA(2,6)/ND,1,2) ;ped adpl
W !?58,"NEWBORN: ",$J(DGA(4,6)/ND,1,2) ;nb adpl
W !,"MEDICAL (Pediatric)",?28,DGBED("PM") ;# m ped beds
W !,"SURGICAL (Pediatric)",?28,DGBED("PS"),?27,"_____" ;# s ped beds
W ?45,"1 DAY PATIENTS ADULT: ",DGA(1,10) ;1day
W !?15,"Subtotal",?28,DGBED("PM")+DGBED("PS"),?35,$$OP ;ped # & %
W ?56,"PEDIATRIC: ",DGA(2,10),!?58,"NEWBORN: ",DGA(4,10) ;1day
W !,"OBSTETRIC",?28,DGBED("O"),?35,$$OO ;ob # & %
W !,"TUBERCULOSIS",?28,DGBED("T"),?35,$$OT ;tb # & %
W ?45,"ICU/SCU PATIENT DAYS: ",$$ICU
W !,"ALCOHOL/SUBSTANCE ABUSE",?28,DGBED("AL"),?35,$$OL ;al # & %
W ?49,"PCU PATIENT DAYS: ",$$PCU
W !,"MENTAL HEALTH",?28,DGBED("MH"),?35,$$OM ;mh # & %
W !,"ICU/SCU",?28,DGBED("I"),?35,$$OI ;icu # & %
W !,"PCU",?28,DGBED("P"),?35,$$OU ;pcu # & %
W ?48,"NON-BENEFICIARIES: ",!?27,"_____",?53,"# Discharged: ",DGCNT
W !?18,"Total",?28,$$TOT,?48,"With total LOS of ",DGLOS," days"
W !!,"NEWBORN",?28,DGBED("N"),?35,$$ON ;nb # & %
W ?51,"% OF OCCUPANCY: ",$$OC,!,DGLINE
W !,"Name of SUD",?35,"Signature Of SUD",?65,"Date" Q
;
DAY ;;31 28 31 30 31 30 31 31 30 31 30 31
;
ND() ; -- # days in month
N X S X=$P($P($T(DAY),";;",2)," ",$E(DGMON,4,5))
Q $S(X'=28:X,$E(DGMON,1,3)#4=0:29,1:X)
;
OA() ; -- occup, adult
Q:'(DGBED("AM")+DGBED("AS")) ""
Q $J(DGA(1,6)/ND/(DGBED("AM")+DGBED("AS"))*100,3,0)_"%"
;
OP() ; -- occup, ped
Q:'(DGBED("PM")+DGBED("PS")) ""
Q $J(DGA(2,6)/ND/(DGBED("PM")+DGBED("PS"))*100,3,0)_"%"
;
OO() ; -- occup, ob
Q:'DGBED("O") "" Q $J(DGA(3,6)/ND/DGBED("O")*100,3,0)_"%"
;
OT() ; -- occup, tb
Q:'DGBED("T") "" Q $J(DGA(5,6)/ND/DGBED("T")*100,3,0)_"%"
;
OL() ; -- occup, al
Q:'DGBED("AL") "" Q $J(DGA(6,6)/ND/DGBED("AL")*100,3,0)_"%"
;
OM() ; -- occup, mh
Q:'DGBED("MH") "" Q $J(DGA(7,6)/ND/DGBED("MH")*100,3,0)_"%"
;
OI() ; -- occup, icu
Q:'DGBED("I") "" Q $J($$ICU/ND/DGBED("I")*100,3,0)_"%"
;
OU() ; -- occup, pcu
Q:'DGBED("P") "" Q $J($$PCU/ND/DGBED("P")*100,3,0)_"%"
;
ON() ; -- occup, nb
Q:'DGBED("N") "" Q $J(DGA(4,6)/ND/DGBED("N")*100,3,0)_"%"
;
OC() ; -- % of occupancy
N X S X=DGX(6)/ND/$$TOT*100 Q:'X "0.00%" Q $J(X,3,0)_"%"
;
ICU() ; -- icu patient days
N X,D,T,E
S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D
. Q:$P($G(^DIC(42,X,"IHS")),U)'="Y"
. S D=DGMON,E=$E(DGMON,1,5)_"31"
. F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D
.. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8)
Q T
;
PCU() ; -- pcu patient days
N X,D,T,E
S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D
. Q:$P($G(^DIC(42,X,"IHS")),U,5)'=1
. S D=DGMON,E=$E(DGMON,1,5)_"31"
. F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D
.. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8)
Q T
;
LOS1() ; -- alos, adult
;IHS/DSD/ENM 08/04/99 DIV ERROR MOD
;Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4))
Q (DGA(3,6)+DGA(1,6))/$S(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)>0:DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4),1:1)
;
LOS2() ; -- alos, ped
;IHS/DSD/ENM 05/17/99 DIV ERROR MOD
;Q DGA(2,6)/(DGA(2,3)+DGA(2,4))
Q DGA(2,6)/$S(DGA(2,3)+DGA(2,4)>0:DGA(2,3)+DGA(2,4),1:1)
;
LOS4() ; -- alos, ped
;IHS/DSD/ENM 05/17/99 DIV ERROR MOD
;Q DGA(4,6)/(DGA(4,3)+DGA(4,4))
Q DGA(4,6)/$S(DGA(4,3)+DGA(4,4)>0:DGA(4,3)+DGA(4,4),1:1)
;
TOT() ; -- total # of beds ('nb)
Q DGBED("AM")+DGBED("AS")+DGBED("PM")+DGBED("PS")+DGBED("O")+DGBED("I")+DGBED("T")+DGBED("AL")+DGBED("MH")+DGBED("P")
ADGSRVP1 ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 08/05/1999 8:51 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2,3**;MAR 25, 1999
+2 ;
+3 NEW ND,LN
SET ND=$$ND
SET LN=""
SET $PIECE(LN,"-",40)=""
P3 WRITE !,DGLINE,!?16,"Part III",!?13,"Beds Available"
+1 WRITE ?50,"Comments",!,LN,!,"STAFF UNITS",?21,"# of Beds",?32,"% Occup."
+2 ;W ?45,"ALOS: ",?60,"ADULT: ",$J(DGA(1,9)/DGLOS(1),1,2) ;adu alos
+3 WRITE ?45,"ALOS: ",?60,"ADULT: ",$JUSTIFY($$LOS1(),1,2)
+4 ;ped alos
WRITE !,LN,?56,"PEDIATRIC: ",$JUSTIFY($$LOS2(),1,2)
+5 ;nb alos
WRITE !?58,"NEWBORN: ",$JUSTIFY($$LOS4(),1,2)
+6 ;# med beds
WRITE !,"MEDICAL (Adult)",?28,DGBED("AM")
+7 ;# sur beds
WRITE !,"SURGICAL (Adult)",?28,DGBED("AS"),?27,"_____"
+8 ;adu adpl
WRITE ?45,"ADPL:",?60,"ADULT: ",$JUSTIFY(DGA(1,6)+DGA(3,6)/ND,1,2)
+9 ;adu # & %
WRITE !?15,"Subtotal",?28,DGBED("AM")+DGBED("AS"),?35,$$OA
+10 ;ped adpl
WRITE ?56,"PEDIATRIC: ",$JUSTIFY(DGA(2,6)/ND,1,2)
+11 ;nb adpl
WRITE !?58,"NEWBORN: ",$JUSTIFY(DGA(4,6)/ND,1,2)
+12 ;# m ped beds
WRITE !,"MEDICAL (Pediatric)",?28,DGBED("PM")
+13 ;# s ped beds
WRITE !,"SURGICAL (Pediatric)",?28,DGBED("PS"),?27,"_____"
+14 ;1day
WRITE ?45,"1 DAY PATIENTS ADULT: ",DGA(1,10)
+15 ;ped # & %
WRITE !?15,"Subtotal",?28,DGBED("PM")+DGBED("PS"),?35,$$OP
+16 ;1day
WRITE ?56,"PEDIATRIC: ",DGA(2,10),!?58,"NEWBORN: ",DGA(4,10)
+17 ;ob # & %
WRITE !,"OBSTETRIC",?28,DGBED("O"),?35,$$OO
+18 ;tb # & %
WRITE !,"TUBERCULOSIS",?28,DGBED("T"),?35,$$OT
+19 WRITE ?45,"ICU/SCU PATIENT DAYS: ",$$ICU
+20 ;al # & %
WRITE !,"ALCOHOL/SUBSTANCE ABUSE",?28,DGBED("AL"),?35,$$OL
+21 WRITE ?49,"PCU PATIENT DAYS: ",$$PCU
+22 ;mh # & %
WRITE !,"MENTAL HEALTH",?28,DGBED("MH"),?35,$$OM
+23 ;icu # & %
WRITE !,"ICU/SCU",?28,DGBED("I"),?35,$$OI
+24 ;pcu # & %
WRITE !,"PCU",?28,DGBED("P"),?35,$$OU
+25 WRITE ?48,"NON-BENEFICIARIES: ",!?27,"_____",?53,"# Discharged: ",DGCNT
+26 WRITE !?18,"Total",?28,$$TOT,?48,"With total LOS of ",DGLOS," days"
+27 ;nb # & %
WRITE !!,"NEWBORN",?28,DGBED("N"),?35,$$ON
+28 WRITE ?51,"% OF OCCUPANCY: ",$$OC,!,DGLINE
+29 WRITE !,"Name of SUD",?35,"Signature Of SUD",?65,"Date"
QUIT
+30 ;
DAY ;;31 28 31 30 31 30 31 31 30 31 30 31
+1 ;
ND() ; -- # days in month
+1 NEW X
SET X=$PIECE($PIECE($TEXT(DAY),";;",2)," ",$EXTRACT(DGMON,4,5))
+2 QUIT $SELECT(X'=28:X,$EXTRACT(DGMON,1,3)#4=0:29,1:X)
+3 ;
OA() ; -- occup, adult
+1 IF '(DGBED("AM")+DGBED("AS"))
QUIT ""
+2 QUIT $JUSTIFY(DGA(1,6)/ND/(DGBED("AM")+DGBED("AS"))*100,3,0)_"%"
+3 ;
OP() ; -- occup, ped
+1 IF '(DGBED("PM")+DGBED("PS"))
QUIT ""
+2 QUIT $JUSTIFY(DGA(2,6)/ND/(DGBED("PM")+DGBED("PS"))*100,3,0)_"%"
+3 ;
OO() ; -- occup, ob
+1 IF 'DGBED("O")
QUIT ""
QUIT $JUSTIFY(DGA(3,6)/ND/DGBED("O")*100,3,0)_"%"
+2 ;
OT() ; -- occup, tb
+1 IF 'DGBED("T")
QUIT ""
QUIT $JUSTIFY(DGA(5,6)/ND/DGBED("T")*100,3,0)_"%"
+2 ;
OL() ; -- occup, al
+1 IF 'DGBED("AL")
QUIT ""
QUIT $JUSTIFY(DGA(6,6)/ND/DGBED("AL")*100,3,0)_"%"
+2 ;
OM() ; -- occup, mh
+1 IF 'DGBED("MH")
QUIT ""
QUIT $JUSTIFY(DGA(7,6)/ND/DGBED("MH")*100,3,0)_"%"
+2 ;
OI() ; -- occup, icu
+1 IF 'DGBED("I")
QUIT ""
QUIT $JUSTIFY($$ICU/ND/DGBED("I")*100,3,0)_"%"
+2 ;
OU() ; -- occup, pcu
+1 IF 'DGBED("P")
QUIT ""
QUIT $JUSTIFY($$PCU/ND/DGBED("P")*100,3,0)_"%"
+2 ;
ON() ; -- occup, nb
+1 IF 'DGBED("N")
QUIT ""
QUIT $JUSTIFY(DGA(4,6)/ND/DGBED("N")*100,3,0)_"%"
+2 ;
OC() ; -- % of occupancy
+1 NEW X
SET X=DGX(6)/ND/$$TOT*100
IF 'X
QUIT "0.00%"
QUIT $JUSTIFY(X,3,0)_"%"
+2 ;
ICU() ; -- icu patient days
+1 NEW X,D,T,E
+2 SET (X,T)=0
FOR
SET X=$ORDER(^DIC(42,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^DIC(42,X,"IHS")),U)'="Y"
QUIT
+4 SET D=DGMON
SET E=$EXTRACT(DGMON,1,5)_"31"
+5 FOR
SET D=$ORDER(^ADGWD(X,1,D))
IF 'D!(D>E)
QUIT
Begin DoDot:2
+6 SET T=T+$PIECE($GET(^ADGWD(+X,1,D,0)),U,2)+$PIECE($GET(^(0)),U,8)
End DoDot:2
End DoDot:1
+7 QUIT T
+8 ;
PCU() ; -- pcu patient days
+1 NEW X,D,T,E
+2 SET (X,T)=0
FOR
SET X=$ORDER(^DIC(42,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^DIC(42,X,"IHS")),U,5)'=1
QUIT
+4 SET D=DGMON
SET E=$EXTRACT(DGMON,1,5)_"31"
+5 FOR
SET D=$ORDER(^ADGWD(X,1,D))
IF 'D!(D>E)
QUIT
Begin DoDot:2
+6 SET T=T+$PIECE($GET(^ADGWD(+X,1,D,0)),U,2)+$PIECE($GET(^(0)),U,8)
End DoDot:2
End DoDot:1
+7 QUIT T
+8 ;
LOS1() ; -- alos, adult
+1 ;IHS/DSD/ENM 08/04/99 DIV ERROR MOD
+2 ;Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4))
+3 QUIT (DGA(3,6)+DGA(1,6))/$SELECT(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)>0:DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4),1:1)
+4 ;
LOS2() ; -- alos, ped
+1 ;IHS/DSD/ENM 05/17/99 DIV ERROR MOD
+2 ;Q DGA(2,6)/(DGA(2,3)+DGA(2,4))
+3 QUIT DGA(2,6)/$SELECT(DGA(2,3)+DGA(2,4)>0:DGA(2,3)+DGA(2,4),1:1)
+4 ;
LOS4() ; -- alos, ped
+1 ;IHS/DSD/ENM 05/17/99 DIV ERROR MOD
+2 ;Q DGA(4,6)/(DGA(4,3)+DGA(4,4))
+3 QUIT DGA(4,6)/$SELECT(DGA(4,3)+DGA(4,4)>0:DGA(4,3)+DGA(4,4),1:1)
+4 ;
TOT() ; -- total # of beds ('nb)
+1 QUIT DGBED("AM")+DGBED("AS")+DGBED("PM")+DGBED("PS")+DGBED("O")+DGBED("I")+DGBED("T")+DGBED("AL")+DGBED("MH")+DGBED("P")
