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 Oct 16, 2024@18:53:38 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
