Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTODCM

DGPTODCM.m

Go to the documentation of this file.
  1. 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
  1. ; called from DGPTOD1
  1. N DGREF,DGDEF,DGWGT,DGS,DGSPEC,DGP,DGSVC,DGBED,DGPRO
  1. N DGPASS,X,Y,B1,B2,B3,B4,T1,T2,T3,T4
  1. N E,P,P3,%,DGCPG,DGFLAG,DGTCH,DGSNM
  1. S DGREF=$NA(^UTILITY("DGPTOD1","CASEMIX"))
  1. S DGDEF=$TR(DGREF,")",",")
  1. F S DGREF=$Q(@DGREF) Q:DGREF="" Q:$E(DGREF,1,$L(DGDEF))'=DGDEF D
  1. .S DGWGT=$P(@DGREF,U,2),DGS=$P(@DGREF,U,3)
  1. .S DGSPEC=$P(@DGREF,U,4),DGP=$P(@DGREF,U,5)
  1. .I DGS="" S DGS="ZZ"
  1. .I DGSPEC="" S DGSPEC=0
  1. .I DGP="" S DGP=0
  1. .; set up table by Service
  1. .I '$D(DGSVC(DGS)) S DGSVC(DGS)=DGWGT_U_1
  1. .E S $P(DGSVC(DGS),U)=$P(DGSVC(DGS),U)+DGWGT,$P(DGSVC(DGS),U,2)=$P(DGSVC(DGS),U,2)+1
  1. .; set up table by Specialty (bed section)
  1. .I '$D(DGBED(DGSPEC)) S DGBED(DGSPEC)=DGWGT_U_1
  1. .E S $P(DGBED(DGSPEC),U)=$P(DGBED(DGSPEC),U)+DGWGT,$P(DGBED(DGSPEC),U,2)=$P(DGBED(DGSPEC),U,2)+1
  1. .; set up table by Provider
  1. .I '$D(DGPRO(DGP)) S DGPRO(DGP)=DGWGT_U_1
  1. .E S $P(DGPRO(DGP),U)=$P(DGPRO(DGP),U)+DGWGT,$P(DGPRO(DGP),U,2)=$P(DGPRO(DGP),U,2)+1
  1. ;
  1. ; start printing
  1. S (DGPASS,P)=0
  1. S DGFLAG="Medical Center",P3="DRG"
  1. D COVER,HEAD
  1. S (T2,T3)=0
  1. D UNLOAD
  1. K ^UTILITY("DGPTOD1","CASEMIX")
  1. Q
  1. COVER ; cover page
  1. S DGCPG(1)="DRG Case Mix Summary for "_DGFLAG
  1. S DGCPG(2)=$S(DGD:"for Discharge Dates Between ",1:"Active Admissions")
  1. 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"
  1. S DGTCH="CASE MIX SUMMARY by DRG^"_P3_"^PAGE #" D C^DGUTL
  1. Q
  1. I P S %=IOSL-14 F E=$Y:1:% W !
  1. I P W !,?10,"Total Weight: Sum of all DRGs",!!
  1. 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"
  1. 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)
  1. W ?110,"Printed: " S Y=DT D DT^DIQ W !?15,$S('DGB:"not ",1:""),"including TRANSFER DRGs"
  1. I DGPASS=0 D
  1. .W !!,"By Service:",!!
  1. .W ?5,"Service",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
  1. I DGPASS=1 D
  1. .W !!,"By Specialty (bed section):",!!
  1. .W ?5,"Specialty",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
  1. I DGPASS=2 D
  1. .W !!,"By Provider:",!!
  1. .W ?5,"Provider",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
  1. K E S $P(E,"=",133)="" W E K E
  1. S P=P+1 Q
  1. UNLOAD ;
  1. I $D(DGSVC) S X="" D
  1. .F S X=$O(DGSVC(X)) Q:X="" D
  1. ..D SVC S B1=DGSNM
  1. ..S B2=$P(DGSVC(X),U),B3=$P(DGSVC(X),U,2),B4=B2/B3
  1. ..D PRINT
  1. .D TOT
  1. .S DGPASS=1 D HEAD
  1. I $D(DGBED) S X="" D
  1. .F S X=$O(DGBED(X)) Q:X="" D
  1. ..S B1=$P($G(^DIC(42.4,X,0)),U) I X=0 S B1="UNKNOWN"
  1. ..S B2=$P(DGBED(X),U),B3=$P(DGBED(X),U,2),B4=B2/B3
  1. ..D PRINT
  1. .D TOT
  1. .S DGPASS=2 D HEAD
  1. I $D(DGPRO) S X="" D
  1. .F S X=$O(DGPRO(X)) Q:X="" D
  1. ..S B1=$P($G(^VA(200,X,0)),U) I X=0 S B1="UNKNOWN"
  1. ..S B2=$P(DGPRO(X),U),B3=$P(DGPRO(X),U,2),B4=B2/B3
  1. ..D PRINT
  1. .D TOT
  1. I P S %=IOSL-14 F E=$Y:1:% W !
  1. I P W !,?10,"Total Weight: Sum of all DRGs",!!
  1. W:P ?62,"-",P,"-" W @IOF,!
  1. Q
  1. PRINT ; print a line
  1. D HEAD:$Y>(IOSL-14)
  1. W !,?5,B1,?38,$J(B2,12,2),?58,$J(B3,10),?75,$J(B4,14,2)
  1. S T2=T2+B2,T3=T3+B3,T4=T2/T3
  1. Q
  1. TOT ; print totals
  1. W !!,?5,"TOTALS",?38,$J(T2,12,2),?58,$J(T3,10),?75,$J(T4,14,2)
  1. S (T2,T3)=0
  1. Q
  1. SVC ; Service names
  1. 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")
  1. Q