source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTBL4.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1ICDTBL4 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 11/8/07 1:12pm
2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
3DRG405 ;
4DRG406 ;
5DRG407 S ICDRG=$S(ICDMCC=2:405,ICDMCC=1:406,1:407) Q
6DRG408 ;
7 I ICDOR["3" S ICDRG=$S(ICDMCC=2:408,ICDMCC=1:409,1:410) Q
8 I ICDOR["E" I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:411,ICDMCC=1:412,1:413) Q
9 I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22")) S ICDRG=$S(ICDMCC=2:414,ICDMCC=1:415,1:416) Q
10 I $D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:417,ICDMCC=1:418,1:419) Q
11 I ICDOR["h" S ICDRG=$S(ICDMCC=2:420,ICDMCC=1:421,1:422) Q
12 I ICDPD["M"&(ICDOR'["h") S ICDRG=$S(ICDMCC=2:435,ICDMCC=1:436,1:437) Q
13 S ICDRG=$S(ICDMCC=2:438,ICDMCC=1:439,1:440)
14 Q
15DRG409 ;
16DRG410 D DRG408 Q
17DRG411 ;
18DRG412 ;
19DRG413 D DRG408 Q
20DRG414 ;
21DRG415 ;
22DRG416 D DRG408 Q
23DRG417 ;
24DRG418 ;
25DRG419 D DRG408 Q
26DRG420 ;
27DRG421 ;
28DRG422 D DRG408 Q
29DRG423 ;
30DRG424 ;
31DRG425 S ICDRG=$S(ICDMCC=2:423,ICDMCC=1:424,1:425) Q
32DRG432 ;
33DRG433 ;
34DRG434 S ICDRG=$S(ICDMCC=2:432,ICDMCC=1:433,1:434) Q
35DRG435 ;
36DRG436 ;
37DRG437 D DRG408 Q
38DRG438 ;
39DRG439 ;
40DRG440 D DRG408 Q
41DRG441 ;
42DRG442 ;
43DRG443 S ICDRG=$S(ICDMCC=2:441,ICDMCC=1:442,1:443) Q
44DRG444 ;
45DRG445 ;
46DRG446 S ICDRG=$S(ICDMCC=2:444,ICDMCC=1:445,1:446) Q
47DRG453 ;
48DRG454 ;
49DRG455 ;
50 N CNTA,CNTP S CNTA=0,CNTP=0
51 I $D(ICDOP(" 81.02")) S CNTA=1
52 I $D(ICDOP(" 81.04")) S CNTA=1
53 I $D(ICDOP(" 81.06")) S CNTA=1
54 I $D(ICDOP(" 81.32")) S CNTA=1
55 I $D(ICDOP(" 81.36")) S CNTA=1
56 I $D(ICDOP(" 81.03")) S CNTP=1
57 I $D(ICDOP(" 81.05")) S CNTP=1
58 I $D(ICDOP(" 81.07")) S CNTP=1
59 I $D(ICDOP(" 81.08")) S CNTP=1
60 I $D(ICDOP(" 81.33")) S CNTP=1
61 I $D(ICDOP(" 81.35")) S CNTP=1
62 I $D(ICDOP(" 81.37")) S CNTP=1
63 I $D(ICDOP(" 81.38")) S CNTP=1
64 I CNTA=1,CNTP=1 D
65 . S ICDRG=$S(ICDMCC=2:453,ICDMCC=1:454,1:455) Q
66 E S ICDRG=""
67 Q
68DRG456 ;
69DRG457 ;
70DRG458 ;
71 I ICDPD["6",$D(ICDOP(" 81.64")) S ICDRG=$S(ICDMCC=2:456,ICDMCC=1:457,1:458) Q
72 I ICDSD["6",$D(ICDOP(" 81.64")) S ICDRG=$S(ICDMCC=2:456,ICDMCC=1:457,1:458) Q
73DRG459 ;
74DRG460 S ICDRG=$S(ICDMCC=2:459,1:460) Q
75DRG461 ;
76DRG462 ;
77 N CNT S CNT=0
78 I $D(ICDOP(" 00.70")) S CNT=$G(CNT)+1
79 I $D(ICDOP(" 00.80")) S CNT=$G(CNT)+1
80 I $D(ICDOP(" 00.85")) S CNT=$G(CNT)+1
81 I $D(ICDOP(" 00.86")) S CNT=$G(CNT)+1
82 I $D(ICDOP(" 00.87")) S CNT=$G(CNT)+1
83 I $D(ICDOP(" 81.51")) S CNT=$G(CNT)+1
84 I $D(ICDOP(" 81.52")) S CNT=$G(CNT)+1
85 I $D(ICDOP(" 81.54")) S CNT=$G(CNT)+1
86 I $D(ICDOP(" 81.56")) S CNT=$G(CNT)+1
87 I CNT>1 S ICDRG=$S(ICDMCC=2:461,1:462) Q
88 I $D(ICDOP(" 00.70"))!$D(ICDOP(" 00.80")) D DRG466 Q
89 E D DRG469 Q
90DRG463 ;
91DRG464 ;
92DRG465 S ICDRG=$S(ICDMCC=2:463,ICDMCC=1:464,1:465) Q
93DRG466 ;
94DRG467 ;
95DRG468 S ICDRG=$S(ICDMCC=2:466,ICDMCC=1:467,1:468) Q
96DRG469 ;
97DRG470 S ICDRG=$S(ICDMCC=2:469,1:470) Q
98DRG471 ;
99DRG472 ;
100DRG473 S ICDRG=$S(ICDMCC=2:471,ICDMCC=1:472,1:473) Q
101DRG474 ;
102DRG475 ;
103DRG476 S ICDRG=$S(ICDMCC=2:474,ICDMCC=1:475,1:476) Q
104DRG477 ;
105DRG478 ;
106DRG479 S ICDRG=$S(ICDMCC=2:477,ICDMCC=1:478,1:479) Q
107DRG480 ;
108DRG481 ;
109DRG482 S ICDRG=$S(ICDMCC=2:480,ICDMCC=1:481,1:482) Q
110DRG483 ;
111DRG484 S ICDRG=$S(ICDMCC>0:483,1:484) Q
112DRG485 ;
113DRG486 ;
114DRG487 I ICDPD["k" S ICDRG=$S(ICDMCC=2:485,ICDMCC=1:486,1:487) Q
115 E S ICDRG=""
116DRG488 ;
117DRG489 S ICDRG=$S(ICDMCC>0:488,1:489) Q
118DRG490 ;
119DRG491 S ICDRG=$S(ICDMCC>0:490,1:491) D Q
120 . I $D(ICDOP(" 84.59")) S ICDRG=490
121 . I $D(ICDOP(" 84.62")) S ICDRG=490
122 . I $D(ICDOP(" 84.65")) S ICDRG=490
123 . I $D(ICDOP(" 84.80")) S ICDRG=490
124 . I $D(ICDOP(" 84.82")) S ICDRG=490
125 . I $D(ICDOP(" 84.84")) S ICDRG=490
126 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.94")) S ICDRG=490
127 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.95")) S ICDRG=490
128 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.97")) S ICDRG=490
129 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.98")) S ICDRG=490
130DRG492 ;
131DRG493 ;
132DRG494 S ICDRG=$S(ICDMCC=2:492,ICDMCC=1:493,1:494) Q
133DRG495 ;
134DRG496 ;
135DRG497 S ICDRG=$S(ICDMCC=2:495,ICDMCC=1:496,1:497) Q
136DRG498 ;
137DRG499 S ICDRG=$S(ICDMCC>0:498,1:499) Q
138 Q
Note: See TracBrowser for help on using the repository browser.