source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTODCM.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1DGPTODCM ;ALB/JAT - PTF DRG CASE MIX REPORT ; 9/14/01 10:35am
2 ;;5.3;Registration;**375**;Aug 13,1993
3 ; called from DGPTOD1
4 N DGREF,DGDEF,DGWGT,DGS,DGB,DGP,DGSVC,DGBED,DGPRO
5 N DGPASS,X,Y,B1,B2,B3,B4,T1,T2,T3,T4
6 N E,P,P3,%,DGCPG,DGFLAG,DGTCH,DGSNM
7 S DGREF=$NA(^UTILITY("DGPTOD1","CASEMIX"))
8 S DGDEF=$TR(DGREF,")",",")
9 F S DGREF=$Q(@DGREF) Q:DGREF="" Q:$E(DGREF,1,$L(DGDEF))'=DGDEF D
10 .S DGWGT=$P(@DGREF,U,2),DGS=$P(@DGREF,U,3)
11 .S DGB=$P(@DGREF,U,4),DGP=$P(@DGREF,U,5)
12 .I DGS="" S DGS="ZZ"
13 .I DGB="" S DGB=0
14 .I DGP="" S DGP=0
15 .; set up table by Service
16 .I '$D(DGSVC(DGS)) S DGSVC(DGS)=DGWGT_U_1
17 .E S $P(DGSVC(DGS),U)=$P(DGSVC(DGS),U)+DGWGT,$P(DGSVC(DGS),U,2)=$P(DGSVC(DGS),U,2)+1
18 .; set up table by Specialty (bed section)
19 .I '$D(DGBED(DGB)) S DGBED(DGB)=DGWGT_U_1
20 .E S $P(DGBED(DGB),U)=$P(DGBED(DGB),U)+DGWGT,$P(DGBED(DGB),U,2)=$P(DGBED(DGB),U,2)+1
21 .; set up table by Provider
22 .I '$D(DGPRO(DGP)) S DGPRO(DGP)=DGWGT_U_1
23 .E S $P(DGPRO(DGP),U)=$P(DGPRO(DGP),U)+DGWGT,$P(DGPRO(DGP),U,2)=$P(DGPRO(DGP),U,2)+1
24 ;
25 ; start printing
26 S (DGPASS,P)=0
27 S DGFLAG="Medical Center",P3="DRG"
28 D COVER,HEAD
29 S (T2,T3)=0
30 D UNLOAD
31 K ^UTILITY("DGPTOD1","CASEMIX")
32 Q
33COVER ; cover page
34 S DGCPG(1)="DRG Case Mix Summary for "_DGFLAG
35 S DGCPG(2)=$S(DGD:"for Discharge Dates Between ",1:"Active Admissions")
36 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"
37 S DGTCH="CASE MIX SUMMARY by DRG^"_P3_"^PAGE #" D C^DGUTL
38 Q
39HEAD ; top of page
40 I P S %=IOSL-14 F E=$Y:1:% W !
41 I P W !,?10,"Total Weight: Sum of all DRGs",!!
42 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"
43 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)
44 W ?110,"Printed: " S Y=DT D DT^DIQ W !?15,$S('DGB:"not ",1:""),"including TRANSFER DRGs"
45 I DGPASS=0 D
46 .W !!,"By Service:",!!
47 .W ?5,"Service",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
48 I DGPASS=1 D
49 .W !!,"By Specialty (bed section):",!!
50 .W ?5,"Specialty",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
51 I DGPASS=2 D
52 .W !!,"By Provider:",!!
53 .W ?5,"Provider",?40,"Total Weight",?55,"Total # Discharges",?80,"Average Weight",!
54 K E S $P(E,"=",133)="" W E K E
55 S P=P+1 Q
56UNLOAD ;
57 I $D(DGSVC) S X="" D
58 .F S X=$O(DGSVC(X)) Q:X="" D
59 ..D SVC S B1=DGSNM
60 ..S B2=$P(DGSVC(X),U),B3=$P(DGSVC(X),U,2),B4=B2/B3
61 ..D PRINT
62 .D TOT
63 .S DGPASS=1 D HEAD
64 I $D(DGBED) S X="" D
65 .F S X=$O(DGBED(X)) Q:X="" D
66 ..S B1=$P($G(^DIC(42.4,X,0)),U) I X=0 S B1="UNKNOWN"
67 ..S B2=$P(DGBED(X),U),B3=$P(DGBED(X),U,2),B4=B2/B3
68 ..D PRINT
69 .D TOT
70 .S DGPASS=2 D HEAD
71 I $D(DGPRO) S X="" D
72 .F S X=$O(DGPRO(X)) Q:X="" D
73 ..S B1=$P($G(^VA(200,X,0)),U) I X=0 S B1="UNKNOWN"
74 ..S B2=$P(DGPRO(X),U),B3=$P(DGPRO(X),U,2),B4=B2/B3
75 ..D PRINT
76 .D TOT
77 I P S %=IOSL-14 F E=$Y:1:% W !
78 I P W !,?10,"Total Weight: Sum of all DRGs",!!
79 W:P ?62,"-",P,"-" W @IOF,!
80 Q
81PRINT ; print a line
82 D HEAD:$Y>(IOSL-14)
83 W !,?5,B1,?38,$J(B2,12,2),?58,$J(B3,10),?75,$J(B4,14,2)
84 S T2=T2+B2,T3=T3+B3,T4=T2/T3
85 Q
86TOT ; print totals
87 W !!,?5,"TOTALS",?38,$J(T2,12,2),?58,$J(T3,10),?75,$J(T4,14,2)
88 S (T2,T3)=0
89 Q
90SVC ; Service names
91 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")
92 Q
Note: See TracBrowser for help on using the repository browser.