ICDTLB3C ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2007; 10/23/00 11:48am ; 6/28/05 4:03pm
;;18.0;DRG Grouper;**24,27,33**;Oct 20, 2000;Build 8
DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
DRG166 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
DRG167 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
DRG168 S ICDRG=$S(ICDCC:168,1:169) Q
DRG169 S ICDRG=$S(ICDCC:168,1:169) Q
DRG170 S ICDRG=$S(ICDCC:170,1:171) Q
DRG171 S ICDRG=$S(ICDCC:170,1:171) Q
DRG172 S ICDRG=$S(ICDCC:172,1:173) Q
DRG173 S ICDRG=$S(ICDCC:172,1:173) Q
DRG174 S ICDRG=$S(ICDCC:174,1:175) Q
DRG175 S ICDRG=$S(ICDCC:174,1:175) Q
DRG177 S ICDRG=$S(ICDCC:177,1:178) Q
DRG178 S ICDRG=$S(ICDCC:177,1:178) Q
DRG180 S ICDRG=$S(ICDCC:180,1:181) Q
DRG181 S ICDRG=$S(ICDCC:180,1:181) Q
DRG182 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG183 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG184 S ICDRG=$S(AGE<18:184,ICDCC:182,1:183) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG185 S ICDRG=$S(ICDOR["e":187,AGE="":470,AGE<18:186,1:185),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG186 S ICDRG=$S(ICDOR["e":187,AGE="":470,AGE<18:186,1:185),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG187 S ICDRG=$S($D(ICDPDRG(187)):187,$D(ICDPDRG):ICDPDRG,1:"")
I ICDRG?.N&(+ICDRG>0) Q
I +ICDRG=0 S ICDRG=470 Q
S ICDREF=$$RTABLE^ICDREF(+ICDRG,+ICDDATE)
I ICDRG["^"&(ICDREF'="") X "D DRG"_+ICDRG_"^"_ICDREF Q
S ICDRG=+ICDPDRG
Q
DRG188 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG189 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG190 S ICDRG=$S(AGE<18:190,ICDCC:188,1:189) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG191 S ICDRG=$S(ICDCC:191,1:192) Q
DRG192 S ICDRG=$S(ICDCC:191,1:192) Q
DRG193 ;
; ICD*18*27
;I ICDOR["T"&(ICDOR'["3"&(ICDOR'["h")) D Q:"195^196^197^198"[ICDRG
;.I ICDOR["E" S ICDRG=$S(ICDCC:195,1:196) Q
;.I ICDOR'["E" S ICDRG=$S(ICDCC:197,1:198)
;I ICDOR["3"!(ICDOR["E") S ICDRG=$S(ICDCC:193,1:194) Q
I ICDOR["3" S ICDRG=$S(ICDCC:193,1:194) Q
I ICDOR["E" I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDCC:195,1:196) Q
I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22")) S ICDRG=$S(ICDCC:197,1:198) Q
I $D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDCC:493,1:494) Q
; end of ICD*18*27
I ICDPD["M"&(ICDOR["h") S ICDRG=199 Q
I ICDPD'["M"&(ICDOR["h") S ICDRG=200 Q
I ICDPD["M"&(ICDOR'["h") S ICDRG=203 Q
S ICDRG=204
Q
DRG194 D DRG193 Q
DRG195 ;G:ICDOR["TT" DRG493^ICDTLB6C
D DRG193 Q
DRG196 D DRG193 Q
DRG197 ;S ICDRG=$S(ICDCC:197,1:198) Q
D DRG193 Q
DRG198 ;S ICDRG=$S(ICDCC:197,1:198) Q
D DRG193 Q
DRG199 D DRG193 Q
DRG200 D DRG193 Q
DRG205 S ICDRG=$S(ICDCC:205,1:206) Q
DRG206 S ICDRG=$S(ICDCC:205,1:206) Q
DRG207 S ICDRG=$S(ICDCC:207,1:208) Q
DRG208 S ICDRG=$S(ICDCC:207,1:208) Q
DRG209 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:209) Q
DRG210 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG211 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG212 S ICDRG=$S(AGE<18:212,ICDCC:210,1:211) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG214 Q
DRG215 Q
DRG217 S ICDDRG=217 Q
DRG218 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG219 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG220 S ICDRG=$S(AGE<18:220,ICDCC:218,1:219) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG221 Q
DRG222 Q
DRG224 S ICDRG=$S(ICDCC:223,1:224) Q
DRG226 S ICDRG=$S(ICDCC:226,1:227) Q
DRG227 S ICDRG=$S(ICDCC:226,1:227) Q
DRG228 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
DRG229 S ICDRG=$S(ICDOR["O2":228,ICDCC:228,1:229) Q
DRG232 S ICDRG=232 Q
DRG233 S ICDRG=$S(ICDCC:233,1:234) Q
DRG234 S ICDRG=$S(ICDCC:233,1:234) Q
DRG240 S ICDRG=$S(ICDCC:240,1:241) Q
DRG241 S ICDRG=$S(ICDCC:240,1:241) Q
DRG244 S ICDRG=$S(ICDCC:244,1:245) Q
DRG245 S ICDRG=$S(ICDCC:244,1:245) Q
DRG250 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG251 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG252 S ICDRG=$S(AGE<18:252,ICDCC:250,1:251) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG253 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG254 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG255 S ICDRG=$S(AGE<18:255,ICDCC:253,1:254) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG256 S ICDRG=256 Q
DRG257 I ICDOR'=""&(ICDOR["M") D
.S ICDRG=$S(ICDPD["r"&(ICDCC):257,ICDSD["r"&(ICDCC):257,ICDPD["r":258,ICDSD["r":258,1:"")
S:ICDRG="" ICDRG=261
Q
DRG258 D DRG257 Q
DRG259 I ICDOR'=""&(ICDOR["m") D
.S ICDRG=$S(ICDPD["r"&(ICDCC):259,ICDSD["r"&(ICDCC):259,ICDPD["r":260,ICDSD["r":260,ICDOR["L":262,1:"")
.I $D(ICDOP("85.12 "))!$D(ICDOP("85.20 "))!$D(ICDOP("85.21 ")) S ICDRG=262
S:ICDRG="" ICDRG=261
Q
DRG260 D DRG259 Q
DRG262 D DRG259 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTLB3C 5038 printed Nov 22, 2024@17:02:42 Page 2
ICDTLB3C ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2007; 10/23/00 11:48am ; 6/28/05 4:03pm
+1 ;;18.0;DRG Grouper;**24,27,33**;Oct 20, 2000;Build 8
DRG164 SET ICDRG=$SELECT(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167)
QUIT
DRG165 SET ICDRG=$SELECT(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167)
QUIT
DRG166 SET ICDRG=$SELECT(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167)
QUIT
DRG167 SET ICDRG=$SELECT(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167)
QUIT
DRG168 SET ICDRG=$SELECT(ICDCC:168,1:169)
QUIT
DRG169 SET ICDRG=$SELECT(ICDCC:168,1:169)
QUIT
DRG170 SET ICDRG=$SELECT(ICDCC:170,1:171)
QUIT
DRG171 SET ICDRG=$SELECT(ICDCC:170,1:171)
QUIT
DRG172 SET ICDRG=$SELECT(ICDCC:172,1:173)
QUIT
DRG173 SET ICDRG=$SELECT(ICDCC:172,1:173)
QUIT
DRG174 SET ICDRG=$SELECT(ICDCC:174,1:175)
QUIT
DRG175 SET ICDRG=$SELECT(ICDCC:174,1:175)
QUIT
DRG177 SET ICDRG=$SELECT(ICDCC:177,1:178)
QUIT
DRG178 SET ICDRG=$SELECT(ICDCC:177,1:178)
QUIT
DRG180 SET ICDRG=$SELECT(ICDCC:180,1:181)
QUIT
DRG181 SET ICDRG=$SELECT(ICDCC:180,1:181)
QUIT
DRG182 SET ICDRG=$SELECT(AGE<18:184,ICDCC:182,1:183)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG183 SET ICDRG=$SELECT(AGE<18:184,ICDCC:182,1:183)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG184 SET ICDRG=$SELECT(AGE<18:184,ICDCC:182,1:183)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG185 SET ICDRG=$SELECT(ICDOR["e":187,AGE="":470,AGE<18:186,1:185)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG186 SET ICDRG=$SELECT(ICDOR["e":187,AGE="":470,AGE<18:186,1:185)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG187 SET ICDRG=$SELECT($DATA(ICDPDRG(187)):187,$DATA(ICDPDRG):ICDPDRG,1:"")
+1 IF ICDRG?.N&(+ICDRG>0)
QUIT
+2 IF +ICDRG=0
SET ICDRG=470
QUIT
+3 SET ICDREF=$$RTABLE^ICDREF(+ICDRG,+ICDDATE)
+4 IF ICDRG["^"&(ICDREF'="")
XECUTE "D DRG"_+ICDRG_"^"_ICDREF
QUIT
+5 SET ICDRG=+ICDPDRG
+6 QUIT
DRG188 SET ICDRG=$SELECT(AGE<18:190,ICDCC:188,1:189)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG189 SET ICDRG=$SELECT(AGE<18:190,ICDCC:188,1:189)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG190 SET ICDRG=$SELECT(AGE<18:190,ICDCC:188,1:189)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG191 SET ICDRG=$SELECT(ICDCC:191,1:192)
QUIT
DRG192 SET ICDRG=$SELECT(ICDCC:191,1:192)
QUIT
DRG193 ;
+1 ; ICD*18*27
+2 ;I ICDOR["T"&(ICDOR'["3"&(ICDOR'["h")) D Q:"195^196^197^198"[ICDRG
+3 ;.I ICDOR["E" S ICDRG=$S(ICDCC:195,1:196) Q
+4 ;.I ICDOR'["E" S ICDRG=$S(ICDCC:197,1:198)
+5 ;I ICDOR["3"!(ICDOR["E") S ICDRG=$S(ICDCC:193,1:194) Q
+6 IF ICDOR["3"
SET ICDRG=$SELECT(ICDCC:193,1:194)
QUIT
+7 IF ICDOR["E"
IF $DATA(ICDOP(" 51.21"))!$DATA(ICDOP(" 51.22"))!$DATA(ICDOP(" 51.23"))!$DATA(ICDOP(" 51.24"))
SET ICDRG=$SELECT(ICDCC:195,1:196)
QUIT
+8 IF $DATA(ICDOP(" 51.21"))!$DATA(ICDOP(" 51.22"))
SET ICDRG=$SELECT(ICDCC:197,1:198)
QUIT
+9 IF $DATA(ICDOP(" 51.23"))!$DATA(ICDOP(" 51.24"))
SET ICDRG=$SELECT(ICDCC:493,1:494)
QUIT
+10 ; end of ICD*18*27
+11 IF ICDPD["M"&(ICDOR["h")
SET ICDRG=199
QUIT
+12 IF ICDPD'["M"&(ICDOR["h")
SET ICDRG=200
QUIT
+13 IF ICDPD["M"&(ICDOR'["h")
SET ICDRG=203
QUIT
+14 SET ICDRG=204
+15 QUIT
DRG194 DO DRG193
QUIT
DRG195 ;G:ICDOR["TT" DRG493^ICDTLB6C
+1 DO DRG193
QUIT
DRG196 DO DRG193
QUIT
DRG197 ;S ICDRG=$S(ICDCC:197,1:198) Q
+1 DO DRG193
QUIT
DRG198 ;S ICDRG=$S(ICDCC:197,1:198) Q
+1 DO DRG193
QUIT
DRG199 DO DRG193
QUIT
DRG200 DO DRG193
QUIT
DRG205 SET ICDRG=$SELECT(ICDCC:205,1:206)
QUIT
DRG206 SET ICDRG=$SELECT(ICDCC:205,1:206)
QUIT
DRG207 SET ICDRG=$SELECT(ICDCC:207,1:208)
QUIT
DRG208 SET ICDRG=$SELECT(ICDCC:207,1:208)
QUIT
DRG209 SET ICDRG=$SELECT($FIND($PIECE(ICDOR,"M",2,99),"M"):471,1:209)
QUIT
DRG210 SET ICDRG=$SELECT(AGE<18:212,ICDCC:210,1:211)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG211 SET ICDRG=$SELECT(AGE<18:212,ICDCC:210,1:211)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG212 SET ICDRG=$SELECT(AGE<18:212,ICDCC:210,1:211)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG214 QUIT
DRG215 QUIT
DRG217 SET ICDDRG=217
QUIT
DRG218 SET ICDRG=$SELECT(AGE<18:220,ICDCC:218,1:219)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG219 SET ICDRG=$SELECT(AGE<18:220,ICDCC:218,1:219)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG220 SET ICDRG=$SELECT(AGE<18:220,ICDCC:218,1:219)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG221 QUIT
DRG222 QUIT
DRG224 SET ICDRG=$SELECT(ICDCC:223,1:224)
QUIT
DRG226 SET ICDRG=$SELECT(ICDCC:226,1:227)
QUIT
DRG227 SET ICDRG=$SELECT(ICDCC:226,1:227)
QUIT
DRG228 SET ICDRG=$SELECT(ICDOR["O2":228,ICDCC:228,1:229)
QUIT
DRG229 SET ICDRG=$SELECT(ICDOR["O2":228,ICDCC:228,1:229)
QUIT
DRG232 SET ICDRG=232
QUIT
DRG233 SET ICDRG=$SELECT(ICDCC:233,1:234)
QUIT
DRG234 SET ICDRG=$SELECT(ICDCC:233,1:234)
QUIT
DRG240 SET ICDRG=$SELECT(ICDCC:240,1:241)
QUIT
DRG241 SET ICDRG=$SELECT(ICDCC:240,1:241)
QUIT
DRG244 SET ICDRG=$SELECT(ICDCC:244,1:245)
QUIT
DRG245 SET ICDRG=$SELECT(ICDCC:244,1:245)
QUIT
DRG250 SET ICDRG=$SELECT(AGE<18:252,ICDCC:250,1:251)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG251 SET ICDRG=$SELECT(AGE<18:252,ICDCC:250,1:251)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG252 SET ICDRG=$SELECT(AGE<18:252,ICDCC:250,1:251)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG253 SET ICDRG=$SELECT(AGE<18:255,ICDCC:253,1:254)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG254 SET ICDRG=$SELECT(AGE<18:255,ICDCC:253,1:254)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG255 SET ICDRG=$SELECT(AGE<18:255,ICDCC:253,1:254)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG256 SET ICDRG=256
QUIT
DRG257 IF ICDOR'=""&(ICDOR["M")
Begin DoDot:1
+1 SET ICDRG=$SELECT(ICDPD["r"&(ICDCC):257,ICDSD["r"&(ICDCC):257,ICDPD["r":258,ICDSD["r":258,1:"")
End DoDot:1
+2 if ICDRG=""
SET ICDRG=261
+3 QUIT
DRG258 DO DRG257
QUIT
DRG259 IF ICDOR'=""&(ICDOR["m")
Begin DoDot:1
+1 SET ICDRG=$SELECT(ICDPD["r"&(ICDCC):259,ICDSD["r"&(ICDCC):259,ICDPD["r":260,ICDSD["r":260,ICDOR["L":262,1:"")
+2 IF $DATA(ICDOP("85.12 "))!$DATA(ICDOP("85.20 "))!$DATA(ICDOP("85.21 "))
SET ICDRG=262
End DoDot:1
+3 if ICDRG=""
SET ICDRG=261
+4 QUIT
DRG260 DO DRG259
QUIT
DRG262 DO DRG259
QUIT
