source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB6A.m@ 1420

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1ICDTLB6A ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2005; 9/29/03 2:47pm ; 6/16/05 1:31pm
2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000
3DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
4DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
5DRG405 D DRG404 Q
6DRG406 ;
7 I ICDORNI["K" D
8 .S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407)
9 I ICDORNI'["K" D DRG408
10 Q
11DRG407 D DRG406 Q
12DRG408 I $D(ICDDX(1))&(ICDOPCT=0) D Q:ICDRG=409
13 .I ICDDX(1)=$O(^ICD9("AB","V58.0 ",0)) S ICDRG=409 Q
14 .I ICDDX(1)=$O(^ICD9("AB","V67.1 ",0)) S ICDRG=409 Q
15 .Q
16 I $D(ICDDX(1))&(ICDOPCT=0) D Q:"410^492"[ICDRG
17 .I ICDDX(1)=$O(^ICD9("AB","V58.1 ",0)) S ICDRG=$S(ICDSD["2":492,1:410) Q
18 .I ICDDX(1)=$O(^ICD9("AB","V67.2 ",0)) S ICDRG=$S(ICDSD["2":492,1:410) Q
19 I ICDOPCT>0 S ICDRG=$S(ICDPD'["L":408,ICDCC:401,1:402) Q
20 I ICDOPCT=0 D DRG412
21 Q
22DRG411 S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N":412,1:411) Q
23DRG412 ;S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N"&($D(ICDPDRG(412))):412,$D(ICDPDRG(411)):411,ICDCC:413,1:414)
24 I ICDOPCT>0 D DRG408 Q
25 D DRG412^ICDTLB61
26 Q
27DRG413 S ICDRG=$S(ICDCC:413,1:414) Q
28DRG414 S ICDRG=$S(ICDCC:413,1:414) Q
29DRG416 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:416,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
30DRG417 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:416,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
31DRG418 S ICDRG=$S(ICDOR["O":415,1:418) Q
32DRG419 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
33DRG420 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
34DRG421 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
35DRG422 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
36DRG423 S ICDRG=$S(ICDOR["O":415,1:423) Q
37DRG424 S ICDRG=$S(ICDOR["O":424,1:425) Q
38DRG425 S ICDRG=$S(ICDOR["O":424,1:425) Q
39DRG426 S ICDRG=$S(ICDOR["O":424,1:426) Q
40DRG427 S ICDRG=$S(ICDOR["O":424,1:427) Q
41DRG428 S ICDRG=$S(ICDOR["O":424,1:428) Q
42DRG429 S ICDRG=$S(ICDOR["O":424,1:429) Q
43DRG430 S ICDRG=$S(ICDOR["O":424,1:430) Q
44DRG431 S ICDRG=$S(ICDOR["O":424,1:431) Q
45DRG432 S ICDRG=$S(ICDOR["O":424,1:432) Q
46DRG434 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
47DRG435 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
48DRG436 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
49DRG437 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
50DRG439 S ICDRG=$S($D(ICDODRG(440)):440,1:439) Q
51DRG442 S ICDRG=$S(ICDCC:442,1:443) Q
52DRG443 D EN1^ICDDRG5 S ICDRG=$S(ICDCC3:$S(ICDCC:442,1:443),1:"") Q
53DRG444 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
54 Q
55DRG445 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
56 Q
57DRG446 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
58 Q
59DRG447 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
60 Q
61DRG448 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
62 Q
63DRG449 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
64 Q
65DRG450 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
66 Q
67DRG451 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
68 Q
69DRG452 S ICDRG=$S(ICDCC:452,1:453) Q
70DRG453 S ICDRG=$S(ICDCC:452,1:453) Q
71DRG454 S ICDRG=$S(ICDCC:454,1:455) Q
72DRG455 S ICDRG=$S(ICDCC:454,1:455) Q
73DRG462 S ICDRG=$S(ICDOR["O":461,1:462) Q
74DRG463 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
75DRG464 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
76DRG465 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
77DRG466 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
78DRG467 S ICDRG=$S(ICDOR["O":461,1:467) Q
79DRG471 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:"") Q
80DRG475 S ICDRG=$S(ICDOR["V":475,1:$S($D(ICDPDRG):$O(ICDPDRG(0)),1:468)) I ICDRG<468 D DODRG^ICDDRG0
81 Q
82DRG478 S ICDRG=$S(ICDOR["O"&ICDCC:478,1:479) Q
83DRG479 S ICDRG=$S(ICDOR["O"&ICDCC:478,1:479) Q
84DRG493 ;I (ICDI-1)=1,'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
85 S ICDRG=$S(ICDCC:493,1:494) Q
86DRG494 ;I (ICD-1),'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
87 S ICDRG=$S(ICDCC:493,1:494) Q
88DRG495 Q
89DRG496 S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
90DRG497 S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
91DRG498 S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
92DRG499 S ICDRG=$S(ICDCC:499,1:500) Q
93DRG500 S ICDRG=$S(ICDCC:499,1:500) Q
94DRG501 D
95 . I (ICDPD["k") D
96 .. I ICDCC S ICDRG=501
97 .. I 'ICDCC S ICDRG=502
98 . E S ICDRG=503
99 Q
100DRG502 D DRG501 Q
101DRG503 D DRG501 Q
102DRG514 ; Replaced with DRG535
103 N ICDE1,ICDE2
104 S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0)
105 S ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
106 S ICDRG=470
107 I $D(ICDOP(" 37.94")) I ICDE1+ICDE2=0 S ICDRG=515
108 I '$D(ICDOP(" 37.94")) I ICDE1!ICDE2 S ICDRG=515
109 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
110 I ICDRG=515 I ICDOR["HN" S ICDRG=514
111 Q
112DRG515 D DRG535 Q
113DRG516 I ICDOR["1" S ICDRG=518
114 I (ICDOR["1") I $D(ICDOP(" 36.06"))!($D(ICDOP(" 92.27"))) S ICDRG=517
115 I (ICDOR["1")&(ICDPD["AIC") S ICDRG=516
116 I (ICDOR["1")&(ICDPD["AIC")&$D(ICDOP(" 36.07")) S ICDRG=526
117 I (ICDOR["1")&(ICDPD'["AIC")&$D(ICDOP(" 36.07")) S ICDRG=527 ; ICD*18*5
118 Q
119DRG517 D DRG516 Q
120DRG518 D DRG516 Q
121DRG519 S ICDRG=$S(ICDOR["F":496,ICDCC:519,1:520) Q
122DRG520 D DRG519 Q
123DRG521 S ICDRG=$S(ICDCC:521,ICDOR["D"!(ICDOR["R"):522,1:523) Q
124DRG522 D DRG521 Q
125DRG523 D DRG521 Q
126DRG526 D DRG516 Q
127DRG527 D DRG516 Q
128DRG531 S ICDRG=$S(ICDCC:531,1:532) Q
129DRG532 D DRG531 Q
130DRG533 S ICDRG=$S(ICDCC:533,1:534) Q
131DRG534 D DRG533 Q
132DRG535 N ICDE1,ICDE2,ICDE3
133 S ICDE1=$S($D(ICDOP(" 37.95"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 00.54")))):1,1:0)
134 S ICDE2=$S($D(ICDOP(" 37.97"))&(($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
135 S ICDE3=$S($D(ICDOP(" 00.52"))&($D(ICDOP(" 00.54"))):1,1:0)
136 ;S ICDE4=$S($D(ICDOP(" 00.54"))&($D(ICDOP(" 37.95"))):1,1:0)
137 S ICDRG=470
138 I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3=0 S ICDRG=515
139 I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3 S ICDRG=515
140 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
141 I ICDRG=515 I ICDOR["HN" S ICDRG=$S(ICDPD["A":535,1:536)
142 I ICDRG=470 D DRG115^ICDTLB2A
143 Q
144DRG536 D DRG535 Q
145DRG537 S ICDRG=$S(ICDCC:537,1:538) Q
146DRG538 D DRG537 Q
147DRG539 I ICDPD["L"&(ICDMAJ'[3) D DRG401^ICDTLB5A Q:"401^402^403^404^405^470^473"[ICDRG
148 S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407) Q
149DRG540 D DRG539 Q
150DRG543 S ICDRG=$S((ICDPD["Q")&(ICDOR["Q"):543,ICDOR["Q"&$D(ICDOP(" 00.10")):543,1:ICDRG)
Note: See TracBrowser for help on using the repository browser.