source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTBL0.m@ 1446

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1ICDTBL0 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 10/30/07 3:36pm
2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
3DRG1 ;line tag for 001,002
4DRG2 ;
5 S ICDRG=$S(ICDMCC=2:1,1:2) Q
6DRG3 S ICDRG=3 Q
7DRG4 S ICDRG=4 Q
8DRG5 ;line tag for 005,006
9DRG6 S ICDRG=$S(ICDMCC=2:5,1:6) D Q
10 . I $D(ICDOP(" 46.97")) S ICDRG=5
11DRG7 S ICDRG=7 Q
12DRG8 S ICDRG=8 Q
13DRG9 S ICDRG=9 Q
14DRG10 S ICDRG=10 Q
15DRG11 ;line tag for 011,012,013
16DRG12 ;
17DRG13 ;
18 S ICDRG=$S(ICDMCC=2:11,ICDMCC=1:12,1:13) Q
19DRG20 ;line tag for 020,021,022
20DRG21 ;
21DRG22 ;
22 S ICDRG=$S((ICDPD["K")&(ICDOR["K")&(ICDMCC=2):20,(ICDPD["K")&(ICDOR["K")&(ICDMCC=1):21,(ICDPD["K")&(ICDOR["K"):22,1:ICDRG) Q
23DRG23 ;line tag for 023,024
24DRG24 ;
25 S ICDRG=$S($D(ICDOP(" 00.10")):23,1:ICDRG) Q:(ICDRG=23)
26 S ICDRG=$S((ICDPD["Q")&(ICDOR["Q")&(ICDMCC=2):23,(ICDPD["Q")&(ICDOR["Q"):24,1:ICDRG) Q:(ICDRG=23)
27 S ICDRG=$S($D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95")))&(ICDMCC=2):23,$D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95"))):24,1:ICDRG)
28 Q
29DRG25 ;line tag for 025,026,027
30DRG26 ;
31DRG27 ;
32 D DRG20 D:'((ICDRG>19)&(ICDRG<23)) DRG23 D:'((ICDRG>22)&(ICDRG<25)) DRG31
33 S ICDRG=$S(ICDRG=20:20,ICDRG=21:21,ICDRG=22:22,ICDRG=23:23,ICDRG=24:24,ICDRG=31:31,ICDRG=32:32,ICDRG=33:33,ICDMCC=2:25,ICDMCC=1:26,1:27)
34 I $D(ICDOP(" 00.62")),'$D(ICDOP(" 00.65")) S ICDRG=999
35 Q
36DRG28 ;line tag for 028,029,030
37DRG29 ;
38DRG30 ;
39 S ICDRG=$S(ICDMCC=2:28,ICDMCC=1:29,1:30) D Q
40 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.94")) S ICDRG=29
41 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.95")) S ICDRG=29
42 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.97")) S ICDRG=29
43 . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.98")) S ICDRG=29
44DRG31 ;line tag for 031,032,033
45DRG32 ;
46DRG33 ;
47 S ICDRG=$S((ICDOR["S")&(ICDMCC=2):31,(ICDOR["S")&(ICDMCC=1):32,ICDOR["S":33,1:ICDRG) Q
48DRG34 ;line tag for 034,035,036
49DRG35 ;
50DRG36 ;
51 S ICDRG=$S(ICDMCC=2:34,ICDMCC=1:35,1:36) Q
52DRG37 ;line tag for 037,038,039
53DRG38 ;
54DRG39 ;
55 S ICDRG=$S(ICDMCC=2:37,ICDMCC=1:38,1:39) D Q
56 . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63")))&(ICDMCC=2) S ICDRG=34
57 . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63")))&(ICDMCC=1) S ICDRG=35
58 . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63"))) S ICDRG=36
59DRG40 ;line tag for 040,041,042
60DRG41 ;
61DRG42 ;
62 S ICDRG=$S(ICDMCC=2:40,ICDMCC=1:41,1:42) D Q
63 . I $D(ICDOP(" 04.92")),$D(ICOP(" 86.94")) S ICDRG=41
64 . I $D(ICDOP(" 04.92")),$D(ICOP(" 86.95")) S ICDRG=41
65 . I $D(ICDOP(" 04.92")),$D(ICOP(" 86.97")) S ICDRG=41
66 . I $D(ICDOP(" 04.92")),$D(ICOP(" 86.98")) S ICDRG=41
67DRG52 ;line tag for 052,053
68DRG53 ;
69 S ICDRG=$S(ICDMCC>0:52,1:53) Q
70DRG54 ;line tag for 054,055
71DRG55 ;
72 S ICDRG=$S(ICDMCC=2:54,1:55) Q
73DRG56 ;line taf for 056,057
74DRG57 ;
75 S ICDRG=$S(ICDMCC=2:56,1:57) Q
76DRG58 ;line tag for 058,059,060
77DRG59 ;
78DRG60 ;
79 S ICDRG=$S(ICDMCC=2:58,ICDMCC=1:59,1:60) Q
80DRG61 ;line tag for 061,062,063
81DRG62 ;
82DRG63 ;
83 S ICDRG=$S(ICDMCC=2:61,ICDMCC=1:62,1:63) Q
84DRG64 ;line tag for 064,065,066
85DRG65 ;
86DRG66 ;
87 S ICDRG=$S(ICDMCC=2:64,ICDMCC=1:65,1:66) Q
88DRG67 ;line tag for 067,068
89DRG68 ;
90 S ICDRG=$S(ICDMCC=2:67,1:68) Q
91DRG69 S ICDRG=69 Q
92DRG70 ;line tag for 070,071,072
93DRG71 ;
94DRG72 ;
95 S ICDRG=$S(ICDMCC=2:70,ICDMCC=1:71,1:72) Q
96DRG73 ;line tag for 073,074
97DRG74 ;
98 S ICDRG=$S(ICDMCC=2:73,1:74) Q
99DRG75 ;line tag for 075,076
100DRG76 ;
101 S ICDRG=$S(ICDMCC>0:75,1:76) Q
102DRG77 ;line tag for 077,078,079
103DRG78 ;
104DRG79 ;
105 S ICDRG=$S(ICDMCC=2:77,ICDMCC=1:78,1:79) Q
106DRG80 ;line tag for 080,081
107DRG81 ;
108 S ICDRG=$S(ICDMCC=2:80,1:81) Q
109DRG82 ;line tag for 082,083,084
110DRG83 ;
111DRG84 ;
112 S ICDRG=$S(ICDMCC=2:82,ICDMCC=1:83,1:84) Q
113DRG85 ;line tag for 085,086,087
114DRG86 ;
115DRG87 ;
116 S ICDRG=$S(ICDMCC=2:85,ICDMCC=1:86,1:87) Q
117DRG88 ;line tag for 088,089,090
118DRG89 ;
119DRG90 ;
120 S ICDRG=$S(ICDMCC=2:88,ICDMCC=1:89,1:90) Q
121DRG91 ;line tag for 091,092,093
122DRG92 ;
123DRG93 ;
124 S ICDRG=$S(ICDMCC=2:91,ICDMCC=1:92,1:93) Q
125DRG94 ;line tag for 094,095,096
126DRG95 ;
127DRG96 ;
128 S ICDRG=$S(ICDMCC=2:94,ICDMCC=1:95,1:96) Q
129DRG97 ;line tag for 097,098,099
130DRG98 ;
131DRG99 ;
132 S ICDRG=$S(ICDMCC=2:97,ICDMCC=1:98,1:99) Q
133 Q
Note: See TracBrowser for help on using the repository browser.