source: WorldVistAEHR/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB2.m@ 700

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

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1ICDTLB2 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/19/03 1:09pm
2 ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000;Build 1
3DRG95 S ICDRG=$S(ICDCC:94,1:95) Q
4DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
5 Q
6DRG97 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
7 Q
8DRG98 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
9 Q
10DRG99 S ICDRG=$S(ICDCC!($D(ICDSDRG(99))):99,1:100) Q
11DRG100 S ICDRG=$S(ICDCC:99,1:100) Q
12DRG101 S ICDRG=$S(ICDCC:101,1:102) Q
13DRG102 S ICDRG=$S(ICDCC:101,1:102) Q
14DRG104 ;valve procedure
15 N ICDE1,ICDE2
16 S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0),ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
17 I ICDOR'["P",'ICDE1&'ICDE2&($D(ICDOP(" 37.95"))!$D(ICDOP(" 37.96"))!$D(ICDOP(" 37.97"))!$D(ICDOP(" 37.98"))) S ICDRG=116 Q
18 S:ICDOR["H" ICDRG=$S(ICDOR["N"&ICDE1:104,ICDOR["N"&ICDE2:104,ICDOR["O":104,1:ICDRG)
19 S:ICDOR'["H" ICDRG=$S(ICDOR["N"&ICDE1:105,ICDOR["N"&ICDE2:105,ICDOR["O":105,1:ICDRG)
20 I ICDOR["P"&(ICDE1+ICDE2=0) S ICDRG=$S(ICDOR["H":104,1:105)
21 Q
22DRG105 D DRG104 Q
23 ; NOIS ANN-0801-41869 ignore 37.26 which has "HN1" for identifier
24DRG106 ;S ICDRG=$S(ICDOR["b"&(ICDOR["6")&(ICDOR["1"):106,ICDOR["6"&(ICDOR'["1")&(ICDOR["H"):107,ICDOR["6"&(ICDOR'["1")&(ICDOR'["H"):109,1:470) I "106^107^109"'[ICDRG D
25 S ICDRG=470
26 I ICDOR["b"&(ICDOR["6") S ICDRG=109
27 I ICDOR["b"&(ICDOR["6") I $D(ICDOP(" 35.96"))!($D(ICDOP(" 36.01")))!($D(ICDOP(" 36.02")))!($D(ICDOP(" 36.05"))) S ICDRG=106 Q
28 I ICDOR["b"&(ICDOR["6") I $D(ICDOP(" 37.21"))!($D(ICDOP(" 37.22")))!($D(ICDOP(" 37.23"))) S ICDRG=107
29 I ICDOR["b"&(ICDOR["6") I $D(ICDOP(" 88.52"))!($D(ICDOP(" 88.53")))!($D(ICDOP(" 88.54")))!($D(ICDOP(" 88.55")))!($D(ICDOP(" 88.56")))!($D(ICDOP(" 88.57")))!($D(ICDOP(" 88.58"))) S ICDRG=107
30 I ICDRG'=106&(ICDRG'=107)&(ICDRG'=109) S ICDRG=470 D
31 .;I ICDCC D DRG110 Q
32 .;I ICDOR'["b" D DRG112 I +ICDRG>0&(+ICDRG<470) Q
33 .;I ICDOR'["b" D DRG516^ICDTLB6 I +ICDRG>0 Q
34 .I ICDCC D DRG110 Q
35 .D DRG111
36 Q
37DRG107 D DRG106 Q
38DRG108 S ICDRG=$S(ICDOR["Oo":108,$D(ICDOP(" 38.44"))&$D(ICDOP(" 38.45")):108,ICDCC:110,1:111) Q
39DRG109 D DRG106 Q
40DRG110 D DRG111 Q
41DRG111 S ICDRG=$S(ICDOR["Oo":108,ICDCC&(ICDOR[7):110,ICDOR[7:111,1:ICDRG)
42 I "108^110^111"[ICDRG Q
43 I $D(ICDJJ(478))&('$D(ICDJJ(110))&'($D(ICDJJ(111)))) D DRG478^ICDTLB6
44 D DRG113 I ICDRG=113 Q
45 I ICDOR["p" D DRG115
46 I ICDOR["1" D DRG516^ICDTLB6
47 Q
48DRG112 S ICDRG=$S(ICDOR["Oo":108,(ICDOR["1")&($D(ICDOP(" 36.06"))):116,ICDOR["1":112,1:470) I ICDRG=470 D
49 .I ICDPD["A" D DRG115 Q
50 .I ICDOR["p" D DRG117 Q
51 .D DRG111
52 Q
53DRG113 S ICDRG=$S($D(ICDJJ(113)):113,1:ICDRG) Q
54DRG115 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3=1):115,ICDCC2:115,ICDCC3=1:116,ICDPD'["I"&(ICDCC3=0):127,1:"") Q
55DRG116 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3=1):115,ICDCC3=1:116,1:"") D:ICDOR["p" DRG117 K:ICDRG="" ICDODRG(HICDRG) Q
56DRG117 D EN1^ICDDRG5 Q:ICDOR'["7"&('ICDCC3) S ICDRG=$S(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:117) Q
57DRG118 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:118) Q
58DRG120 ;dx combo's for DRG120
59 N ICDE1,ICDE2
60 S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0),ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
61 S ICDRG=$S((ICDE1&(ICDOR["H")):104,(ICDE1&(ICDOR'["H")):105,(ICDE2&(ICDOR["H")):104,(ICDE2&(ICDOR'["H")):105,1:120)
62 Q
63DRG121 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
64 Q
65DRG122 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
66 Q
67DRG123 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
68 Q
69DRG124 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
70DRG125 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
71DRG130 S ICDRG=$S(ICDCC:130,1:131) Q
72DRG131 S ICDRG=$S(ICDCC!($D(ICDSDRG(130))):130,1:131) Q
73DRG132 S ICDRG=$S(ICDCC:132,1:133) Q
74DRG133 S ICDRG=$S(ICDCC:132,1:133) Q
75DRG135 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
76 Q
77DRG136 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
78 Q
79DRG137 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
80 Q
81DRG138 S ICDRG=$S(ICDCC:138,1:139) Q
82DRG139 S ICDRG=$S(ICDCC:138,1:139) Q
83DRG140 S ICDRG=$S(ICDOR["H":124,ICDNOR["H":124,1:140) Q
84DRG141 S ICDRG=$S(ICDCC:141,1:142) Q
85DRG142 S ICDRG=$S(ICDCC:141,1:142) Q
86DRG144 S ICDRG=$S(ICDCC:144,1:145) Q
87DRG145 S ICDRG=$S(ICDCC:144,1:145) Q
88DRG146 S ICDRG=$S(ICDCC:146,1:147) Q
89DRG147 S ICDRG=$S(ICDCC:146,1:147) Q
90DRG148 S ICDRG=$S(ICDCC:148,1:149) Q
91DRG149 S ICDRG=$S(ICDCC:148,1:149) Q
92DRG150 S ICDRG=$S(ICDCC:150,1:151) Q
93DRG151 S ICDRG=$S(ICDCC:150,1:151) Q
94DRG152 S ICDRG=$S(ICDCC:152,1:153) Q
95DRG153 S ICDRG=$S(ICDCC:152,1:153) Q
96DRG154 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
97 Q
98DRG155 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
99 Q
100DRG156 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
101 Q
102DRG157 S ICDRG=$S(ICDCC:157,1:158) Q
103DRG158 S ICDRG=$S(ICDCC:157,1:158) Q
104DRG159 S ICDRG=$S(AGE<18:163,ICDCC:159,1:160) I AGE="" S ICDRG=470,ICDRTC=3
105 Q
106DRG160 S ICDRG=$S(AGE<18:163,ICDCC:159,1:160) I AGE="" S ICDRG=470,ICDRTC=3
107 Q
108DRG161 S ICDRG=$S(AGE<18:163,ICDCC:161,ICDSD["J":161,1:162) I AGE="" S ICDRG=470,ICDRTC=3
109 Q
110DRG162 S ICDRG=$S(AGE<18:163,ICDCC:161,1:162) I AGE="" S ICDRG=470,ICDRTC=3
111 Q
Note: See TracBrowser for help on using the repository browser.