- DGPTODCM ;ALB/JAT,WOIFO/PMK - PTF DRG CASE MIX REPORT ;4/28/15 7:14pm
- ;;5.3;Registration;**375,884**;Aug 13,1993;Build 31
- ; called from DGPTOD1
- N DGREF,DGDEF,DGWGT,DGS,DGSPEC,DGP,DGSVC,DGBED,DGPRO
- N DGPASS,X,Y,B1,B2,B3,B4,T1,T2,T3,T4
- N E,P,P3,%,DGCPG,DGFLAG,DGTCH,DGSNM
- S DGREF=$NA(^UTILITY("DGPTOD1","CASEMIX"))
- S DGDEF=$TR(DGREF,")",",")
- F S DGREF=$Q(@DGREF) Q:DGREF="" Q:$E(DGREF,1,$L(DGDEF))'=DGDEF D
- .S DGWGT=$P(@DGREF,U,2),DGS=$P(@DGREF,U,3)
- .S DGSPEC=$P(@DGREF,U,4),DGP=$P(@DGREF,U,5)
- .I DGS="" S DGS="ZZ"
- .I DGSPEC="" S DGSPEC=0
- .I DGP="" S DGP=0
- .; set up table by Service
- .I '$D(DGSVC(DGS)) S DGSVC(DGS)=DGWGT_U_1
- .E S $P(DGSVC(DGS),U)=$P(DGSVC(DGS),U)+DGWGT,$P(DGSVC(DGS),U,2)=$P(DGSVC(DGS),U,2)+1
- .; set up table by Specialty (bed section)
- .I '$D(DGBED(DGSPEC)) S DGBED(DGSPEC)=DGWGT_U_1
- .E S $P(DGBED(DGSPEC),U)=$P(DGBED(DGSPEC),U)+DGWGT,$P(DGBED(DGSPEC),U,2)=$P(DGBED(DGSPEC),U,2)+1
- .; set up table by Provider
- .I '$D(DGPRO(DGP)) S DGPRO(DGP)=DGWGT_U_1
- .E S $P(DGPRO(DGP),U)=$P(DGPRO(DGP),U)+DGWGT,$P(DGPRO(DGP),U,2)=$P(DGPRO(DGP),U,2)+1
- ;
- ; start printing
- S (DGPASS,P)=0
- S DGFLAG="Medical Center",P3="DRG"
- D COVER,HEAD
- S (T2,T3)=0
- D UNLOAD
- K ^UTILITY("DGPTOD1","CASEMIX")
- Q
- COVER ; cover page
- S DGCPG(1)="DRG Case Mix Summary for "_DGFLAG
- S DGCPG(2)=$S(DGD:"for Discharge Dates Between ",1:"Active Admissions")
- I DGD S Y=DGSD+.1 X ^DD("DD") S %=Y,Y=$P(DGED,".") X ^DD("DD") S DGCPG(2)=DGCPG(2)_%_" to "_Y,DGCPG(3)=$S('DGB:"not ",1:"")_"including TRANSFER DRGs"
- S DGTCH="CASE MIX SUMMARY by DRG^"_P3_"^PAGE #" D C^DGUTL
- Q
- HEAD ; top of page
- I P S %=IOSL-14 F E=$Y:1:% W !
- I P W !,?10,"Total Weight: Sum of all DRGs",!!
- W:P ?62,"-",P,"-" W @IOF,!,"DRG Case Mix Summary for ",$S(DGFLAG'["M":G2_" SERVICE",1:"MEDICAL CENTER"),$S(DGFLAG["Spec":" by Specialty",1:"") I 'DGD W " for Active Admissions"
- I DGD W !,"Discharge Dates from " S Y=DGSD+.1 X ^DD("DD") W $P(Y,"@",1)," to " S Y=DGED X ^DD("DD") W $P(Y,"@",1)
- W ?110,"Printed: " S Y=DT D DT^DIQ W !?15,$S('DGB:"not ",1:""),"including TRANSFER DRGs"
- I DGPASS=0 D
- .W !!,"By Service:",!!
- .W ?5,"Service",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- I DGPASS=1 D
- .W !!,"By Specialty (bed section):",!!
- .W ?5,"Specialty",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- I DGPASS=2 D
- .W !!,"By Provider:",!!
- .W ?5,"Provider",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- K E S $P(E,"=",133)="" W E K E
- S P=P+1 Q
- UNLOAD ;
- I $D(DGSVC) S X="" D
- .F S X=$O(DGSVC(X)) Q:X="" D
- ..D SVC S B1=DGSNM
- ..S B2=$P(DGSVC(X),U),B3=$P(DGSVC(X),U,2),B4=B2/B3
- ..D PRINT
- .D TOT
- .S DGPASS=1 D HEAD
- I $D(DGBED) S X="" D
- .F S X=$O(DGBED(X)) Q:X="" D
- ..S B1=$P($G(^DIC(42.4,X,0)),U) I X=0 S B1="UNKNOWN"
- ..S B2=$P(DGBED(X),U),B3=$P(DGBED(X),U,2),B4=B2/B3
- ..D PRINT
- .D TOT
- .S DGPASS=2 D HEAD
- I $D(DGPRO) S X="" D
- .F S X=$O(DGPRO(X)) Q:X="" D
- ..S B1=$P($G(^VA(200,X,0)),U) I X=0 S B1="UNKNOWN"
- ..S B2=$P(DGPRO(X),U),B3=$P(DGPRO(X),U,2),B4=B2/B3
- ..D PRINT
- .D TOT
- I P S %=IOSL-14 F E=$Y:1:% W !
- I P W !,?10,"Total Weight: Sum of all DRGs",!!
- W:P ?62,"-",P,"-" W @IOF,!
- Q
- PRINT ; print a line
- D HEAD:$Y>(IOSL-14)
- W !,?5,B1,?38,$J(B2,12,2),?58,$J(B3,10),?75,$J(B4,14,2)
- S T2=T2+B2,T3=T3+B3,T4=T2/T3
- Q
- TOT ; print totals
- W !!,?5,"TOTALS",?38,$J(T2,12,2),?58,$J(T3,10),?75,$J(T4,14,2)
- S (T2,T3)=0
- Q
- SVC ; Service names
- S DGSNM=$S(X="M":"MEDICINE",X="S":"SURGERY",X="P":"PSYCHIATRY",X="NE":"NEUROLOGY",X="R":"REHAB MEDICINE",X="NH":"NHCU",X="I":"INTERMEDIATE MED",X="SCI":"SPINAL CORD INJURY",X="D":"DOMICILIARY",X="B":"BLIND REHAB",1:"RESPITE CARE")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTODCM 3732 printed Feb 19, 2025@00:19:06 Page 2
- DGPTODCM ;ALB/JAT,WOIFO/PMK - PTF DRG CASE MIX REPORT ;4/28/15 7:14pm
- +1 ;;5.3;Registration;**375,884**;Aug 13,1993;Build 31
- +2 ; called from DGPTOD1
- +3 NEW DGREF,DGDEF,DGWGT,DGS,DGSPEC,DGP,DGSVC,DGBED,DGPRO
- +4 NEW DGPASS,X,Y,B1,B2,B3,B4,T1,T2,T3,T4
- +5 NEW E,P,P3,%,DGCPG,DGFLAG,DGTCH,DGSNM
- +6 SET DGREF=$NAME(^UTILITY("DGPTOD1","CASEMIX"))
- +7 SET DGDEF=$TRANSLATE(DGREF,")",",")
- +8 FOR
- SET DGREF=$QUERY(@DGREF)
- if DGREF=""
- QUIT
- if $EXTRACT(DGREF,1,$LENGTH(DGDEF))'=DGDEF
- QUIT
- Begin DoDot:1
- +9 SET DGWGT=$PIECE(@DGREF,U,2)
- SET DGS=$PIECE(@DGREF,U,3)
- +10 SET DGSPEC=$PIECE(@DGREF,U,4)
- SET DGP=$PIECE(@DGREF,U,5)
- +11 IF DGS=""
- SET DGS="ZZ"
- +12 IF DGSPEC=""
- SET DGSPEC=0
- +13 IF DGP=""
- SET DGP=0
- +14 ; set up table by Service
- +15 IF '$DATA(DGSVC(DGS))
- SET DGSVC(DGS)=DGWGT_U_1
- +16 IF '$TEST
- SET $PIECE(DGSVC(DGS),U)=$PIECE(DGSVC(DGS),U)+DGWGT
- SET $PIECE(DGSVC(DGS),U,2)=$PIECE(DGSVC(DGS),U,2)+1
- +17 ; set up table by Specialty (bed section)
- +18 IF '$DATA(DGBED(DGSPEC))
- SET DGBED(DGSPEC)=DGWGT_U_1
- +19 IF '$TEST
- SET $PIECE(DGBED(DGSPEC),U)=$PIECE(DGBED(DGSPEC),U)+DGWGT
- SET $PIECE(DGBED(DGSPEC),U,2)=$PIECE(DGBED(DGSPEC),U,2)+1
- +20 ; set up table by Provider
- +21 IF '$DATA(DGPRO(DGP))
- SET DGPRO(DGP)=DGWGT_U_1
- +22 IF '$TEST
- SET $PIECE(DGPRO(DGP),U)=$PIECE(DGPRO(DGP),U)+DGWGT
- SET $PIECE(DGPRO(DGP),U,2)=$PIECE(DGPRO(DGP),U,2)+1
- End DoDot:1
- +23 ;
- +24 ; start printing
- +25 SET (DGPASS,P)=0
- +26 SET DGFLAG="Medical Center"
- SET P3="DRG"
- +27 DO COVER
- DO HEAD
- +28 SET (T2,T3)=0
- +29 DO UNLOAD
- +30 KILL ^UTILITY("DGPTOD1","CASEMIX")
- +31 QUIT
- COVER ; cover page
- +1 SET DGCPG(1)="DRG Case Mix Summary for "_DGFLAG
- +2 SET DGCPG(2)=$SELECT(DGD:"for Discharge Dates Between ",1:"Active Admissions")
- +3 IF DGD
- SET Y=DGSD+.1
- XECUTE ^DD("DD")
- SET %=Y
- SET Y=$PIECE(DGED,".")
- XECUTE ^DD("DD")
- SET DGCPG(2)=DGCPG(2)_%_" to "_Y
- SET DGCPG(3)=$SELECT('DGB:"not ",1:"")_"including TRANSFER DRGs"
- +4 SET DGTCH="CASE MIX SUMMARY by DRG^"_P3_"^PAGE #"
- DO C^DGUTL
- +5 QUIT
- HEAD ; top of page
- +1 IF P
- SET %=IOSL-14
- FOR E=$Y:1:%
- WRITE !
- +2 IF P
- WRITE !,?10,"Total Weight: Sum of all DRGs",!!
- +3 if P
- WRITE ?62,"-",P,"-"
- WRITE @IOF,!,"DRG Case Mix Summary for ",$SELECT(DGFLAG'["M":G2_" SERVICE",1:"MEDICAL CENTER"),$SELECT(DGFLAG["Spec":" by Specialty",1:"")
- IF 'DGD
- WRITE " for Active Admissions"
- +4 IF DGD
- WRITE !,"Discharge Dates from "
- SET Y=DGSD+.1
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@",1)," to "
- SET Y=DGED
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@",1)
- +5 WRITE ?110,"Printed: "
- SET Y=DT
- DO DT^DIQ
- WRITE !?15,$SELECT('DGB:"not ",1:""),"including TRANSFER DRGs"
- +6 IF DGPASS=0
- Begin DoDot:1
- +7 WRITE !!,"By Service:",!!
- +8 WRITE ?5,"Service",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- End DoDot:1
- +9 IF DGPASS=1
- Begin DoDot:1
- +10 WRITE !!,"By Specialty (bed section):",!!
- +11 WRITE ?5,"Specialty",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- End DoDot:1
- +12 IF DGPASS=2
- Begin DoDot:1
- +13 WRITE !!,"By Provider:",!!
- +14 WRITE ?5,"Provider",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
- End DoDot:1
- +15 KILL E
- SET $PIECE(E,"=",133)=""
- WRITE E
- KILL E
- +16 SET P=P+1
- QUIT
- UNLOAD ;
- +1 IF $DATA(DGSVC)
- SET X=""
- Begin DoDot:1
- +2 FOR
- SET X=$ORDER(DGSVC(X))
- if X=""
- QUIT
- Begin DoDot:2
- +3 DO SVC
- SET B1=DGSNM
- +4 SET B2=$PIECE(DGSVC(X),U)
- SET B3=$PIECE(DGSVC(X),U,2)
- SET B4=B2/B3
- +5 DO PRINT
- End DoDot:2
- +6 DO TOT
- +7 SET DGPASS=1
- DO HEAD
- End DoDot:1
- +8 IF $DATA(DGBED)
- SET X=""
- Begin DoDot:1
- +9 FOR
- SET X=$ORDER(DGBED(X))
- if X=""
- QUIT
- Begin DoDot:2
- +10 SET B1=$PIECE($GET(^DIC(42.4,X,0)),U)
- IF X=0
- SET B1="UNKNOWN"
- +11 SET B2=$PIECE(DGBED(X),U)
- SET B3=$PIECE(DGBED(X),U,2)
- SET B4=B2/B3
- +12 DO PRINT
- End DoDot:2
- +13 DO TOT
- +14 SET DGPASS=2
- DO HEAD
- End DoDot:1
- +15 IF $DATA(DGPRO)
- SET X=""
- Begin DoDot:1
- +16 FOR
- SET X=$ORDER(DGPRO(X))
- if X=""
- QUIT
- Begin DoDot:2
- +17 SET B1=$PIECE($GET(^VA(200,X,0)),U)
- IF X=0
- SET B1="UNKNOWN"
- +18 SET B2=$PIECE(DGPRO(X),U)
- SET B3=$PIECE(DGPRO(X),U,2)
- SET B4=B2/B3
- +19 DO PRINT
- End DoDot:2
- +20 DO TOT
- End DoDot:1
- +21 IF P
- SET %=IOSL-14
- FOR E=$Y:1:%
- WRITE !
- +22 IF P
- WRITE !,?10,"Total Weight: Sum of all DRGs",!!
- +23 if P
- WRITE ?62,"-",P,"-"
- WRITE @IOF,!
- +24 QUIT
- PRINT ; print a line
- +1 if $Y>(IOSL-14)
- DO HEAD
- +2 WRITE !,?5,B1,?38,$JUSTIFY(B2,12,2),?58,$JUSTIFY(B3,10),?75,$JUSTIFY(B4,14,2)
- +3 SET T2=T2+B2
- SET T3=T3+B3
- SET T4=T2/T3
- +4 QUIT
- TOT ; print totals
- +1 WRITE !!,?5,"TOTALS",?38,$JUSTIFY(T2,12,2),?58,$JUSTIFY(T3,10),?75,$JUSTIFY(T4,14,2)
- +2 SET (T2,T3)=0
- +3 QUIT
- SVC ; Service names
- +1 SET DGSNM=$SELECT(X="M":"MEDICINE",X="S":"SURGERY",X="P":"PSYCHIATRY",X="NE":"NEUROLOGY",X="R":"REHAB MEDICINE",X="NH":"NHCU",X="I":"INTERMEDIATE MED",X="SCI":"SPINAL CORD INJURY",X="D":"DOMICILIARY",X="B":"BLIND REHAB",1:"RESPITE CARE")
- +2 QUIT