- 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")
