- ICDTLB2A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 9/19/03 1:09pm ; 11/19/04 10:13am
- ;;18.0;DRG Grouper;**14,34**;Oct 20, 2000;Build 4
- DRG95 S ICDRG=$S(ICDCC:94,1:95) Q
- DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG97 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG98 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG99 S ICDRG=$S(ICDCC!($D(ICDSDRG(99))):99,1:100) Q
- DRG100 S ICDRG=$S(ICDCC:99,1:100) Q
- DRG101 S ICDRG=$S(ICDCC:101,1:102) Q
- DRG102 S ICDRG=$S(ICDCC:101,1:102) Q
- DRG104 ;valve procedure
- N ICDE1,ICDE2
- 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)
- 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
- S:ICDOR["H" ICDRG=$S(ICDOR["N"&ICDE1:104,ICDOR["N"&ICDE2:104,ICDOR["O":104,1:ICDRG)
- S:ICDOR'["H" ICDRG=$S(ICDOR["N"&ICDE1:105,ICDOR["N"&ICDE2:105,ICDOR["O":105,1:ICDRG)
- I ICDOR["P"&(ICDE1+ICDE2=0) S ICDRG=$S(ICDOR["H":104,1:105)
- Q
- DRG105 D DRG104 Q
- ; NOIS ANN-0801-41869 ignore 37.26 which has "HN1" for identifier
- DRG106 ;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
- S ICDRG=470
- I ICDOR["b"&(ICDOR["6") S ICDRG=109
- 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
- I ICDOR["b"&(ICDOR["6") I $D(ICDOP(" 37.21"))!($D(ICDOP(" 37.22")))!($D(ICDOP(" 37.23"))) S ICDRG=107
- 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
- I ICDRG'=106&(ICDRG'=107)&(ICDRG'=109) S ICDRG=470 D
- .;I ICDCC D DRG110 Q
- .;I ICDOR'["b" D DRG112 I +ICDRG>0&(+ICDRG<470) Q
- .;I ICDOR'["b" D DRG516^ICDTLB6A I +ICDRG>0 Q
- .I ICDCC D DRG110 Q
- .D DRG111
- Q
- DRG107 D DRG106 Q
- DRG108 S ICDRG=$S(ICDOR["Oo":108,$D(ICDOP(" 38.44"))&$D(ICDOP(" 38.45")):108,ICDCC:110,1:111) Q
- DRG109 D DRG106 Q
- DRG110 D DRG111 Q
- DRG111 S ICDRG=$S(ICDOR["Oo":108,ICDCC&(ICDOR[7):110,ICDOR[7:111,1:ICDRG)
- I "108^110^111"[ICDRG Q
- I $D(ICDJJ(478))&('$D(ICDJJ(110))&'($D(ICDJJ(111)))) D DRG478^ICDTLB6A
- D DRG113 I ICDRG=113 Q
- I ICDOR["p" D DRG115
- I ICDOR["1" D DRG516^ICDTLB6A
- Q
- DRG112 S ICDRG=$S(ICDOR["Oo":108,(ICDOR["1")&($D(ICDOP(" 36.06"))):116,ICDOR["1":112,1:470) I ICDRG=470 D
- .I ICDPD["A" D DRG115 Q
- .I ICDOR["p" D DRG117 Q
- .D DRG111
- Q
- DRG113 S ICDRG=$S($D(ICDJJ(113)):113,1:ICDRG) Q
- DRG115 D EN1^ICDDRG5 S ICDRG=$S($D(ICDOP(" 37.99"))&$D(ICDOP(" 37.98")):111,ICDPD["A"&(ICDCC3=1):115,ICDCC2:115,ICDCC3=1:116,ICDPD'["I"&(ICDCC3=0):127,1:"") Q
- DRG116 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3=1):115,ICDCC3=1:116,1:"") D:ICDOR["p" DRG118 K:ICDRG="" ICDODRG(HICDRG) Q
- DRG117 D EN1^ICDDRG5 Q:ICDOR'["7"&('ICDCC3) S ICDRG=$S(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:117) Q
- DRG118 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:118) Q
- DRG120 ;dx combo's for DRG120
- N ICDE1,ICDE2
- 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)
- S ICDRG=$S((ICDE1&(ICDOR["H")):104,(ICDE1&(ICDOR'["H")):105,(ICDE2&(ICDOR["H")):104,(ICDE2&(ICDOR'["H")):105,1:120)
- Q
- DRG121 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
- Q
- DRG122 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
- Q
- DRG123 S ICDRG=$S(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470) I ICDRG=470 S ICDRTC=5
- Q
- DRG124 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
- DRG125 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
- DRG130 S ICDRG=$S(ICDCC:130,1:131) Q
- DRG131 S ICDRG=$S(ICDCC!($D(ICDSDRG(130))):130,1:131) Q
- DRG132 S ICDRG=$S(ICDCC:132,1:133) Q
- DRG133 S ICDRG=$S(ICDCC:132,1:133) Q
- DRG135 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG136 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG137 S ICDRG=$S(AGE<18:137,ICDCC:135,1:136) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG138 S ICDRG=$S(ICDCC:138,1:139) Q
- DRG139 S ICDRG=$S(ICDCC:138,1:139) Q
- DRG140 S ICDRG=$S(ICDOR["H":124,ICDNOR["H":124,1:140) Q
- DRG141 S ICDRG=$S(ICDCC:141,1:142) Q
- DRG142 S ICDRG=$S(ICDCC:141,1:142) Q
- DRG144 S ICDRG=$S(ICDCC:144,1:145) Q
- DRG145 S ICDRG=$S(ICDCC:144,1:145) Q
- DRG146 S ICDRG=$S(ICDCC:146,1:147) Q
- DRG147 S ICDRG=$S(ICDCC:146,1:147) Q
- DRG148 S ICDRG=$S(ICDCC:148,1:149) Q
- DRG149 S ICDRG=$S(ICDCC:148,1:149) Q
- DRG150 S ICDRG=$S(ICDCC:150,1:151) Q
- DRG151 S ICDRG=$S(ICDCC:150,1:151) Q
- DRG152 S ICDRG=$S(ICDCC:152,1:153) Q
- DRG153 S ICDRG=$S(ICDCC:152,1:153) Q
- DRG154 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG155 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG156 S ICDRG=$S(AGE<18:156,ICDCC:154,1:155) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG157 S ICDRG=$S(ICDCC:157,1:158) Q
- DRG158 S ICDRG=$S(ICDCC:157,1:158) Q
- DRG159 S ICDRG=$S(AGE<18:163,ICDCC:159,1:160) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG160 S ICDRG=$S(AGE<18:163,ICDCC:159,1:160) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG161 S ICDRG=$S(AGE<18:163,ICDCC:161,ICDSD["J":161,1:162) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- DRG162 S ICDRG=$S(AGE<18:163,ICDCC:161,1:162) I AGE="" S ICDRG=470,ICDRTC=3
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTLB2A 5484 printed Feb 18, 2025@23:18:48 Page 2
- ICDTLB2A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 9/19/03 1:09pm ; 11/19/04 10:13am
- +1 ;;18.0;DRG Grouper;**14,34**;Oct 20, 2000;Build 4
- DRG95 SET ICDRG=$SELECT(ICDCC:94,1:95)
- QUIT
- DRG96 SET ICDRG=$SELECT(AGE<18:98,ICDCC:96,1:97)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG97 SET ICDRG=$SELECT(AGE<18:98,ICDCC:96,1:97)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG98 SET ICDRG=$SELECT(AGE<18:98,ICDCC:96,1:97)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG99 SET ICDRG=$SELECT(ICDCC!($DATA(ICDSDRG(99))):99,1:100)
- QUIT
- DRG100 SET ICDRG=$SELECT(ICDCC:99,1:100)
- QUIT
- DRG101 SET ICDRG=$SELECT(ICDCC:101,1:102)
- QUIT
- DRG102 SET ICDRG=$SELECT(ICDCC:101,1:102)
- QUIT
- DRG104 ;valve procedure
- +1 NEW ICDE1,ICDE2
- +2 SET ICDE1=$SELECT($DATA(ICDOP(" 37.95"))&($DATA(ICDOP(" 37.96"))):1,1:0)
- SET ICDE2=$SELECT($DATA(ICDOP(" 37.97"))&($DATA(ICDOP(" 37.98"))):1,1:0)
- +3 IF ICDOR'["P"
- IF 'ICDE1&'ICDE2&($DATA(ICDOP(" 37.95"))!$DATA(ICDOP(" 37.96"))!$DATA(ICDOP(" 37.97"))!$DATA(ICDOP(" 37.98")))
- SET ICDRG=116
- QUIT
- +4 if ICDOR["H"
- SET ICDRG=$SELECT(ICDOR["N"&ICDE1:104,ICDOR["N"&ICDE2:104,ICDOR["O":104,1:ICDRG)
- +5 if ICDOR'["H"
- SET ICDRG=$SELECT(ICDOR["N"&ICDE1:105,ICDOR["N"&ICDE2:105,ICDOR["O":105,1:ICDRG)
- +6 IF ICDOR["P"&(ICDE1+ICDE2=0)
- SET ICDRG=$SELECT(ICDOR["H":104,1:105)
- +7 QUIT
- DRG105 DO DRG104
- QUIT
- +1 ; NOIS ANN-0801-41869 ignore 37.26 which has "HN1" for identifier
- DRG106 ;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
- +1 SET ICDRG=470
- +2 IF ICDOR["b"&(ICDOR["6")
- SET ICDRG=109
- +3 IF ICDOR["b"&(ICDOR["6")
- IF $DATA(ICDOP(" 35.96"))!($DATA(ICDOP(" 36.01")))!($DATA(ICDOP(" 36.02")))!($DATA(ICDOP(" 36.05")))
- SET ICDRG=106
- QUIT
- +4 IF ICDOR["b"&(ICDOR["6")
- IF $DATA(ICDOP(" 37.21"))!($DATA(ICDOP(" 37.22")))!($DATA(ICDOP(" 37.23")))
- SET ICDRG=107
- +5 IF ICDOR["b"&(ICDOR["6")
- IF $DATA(ICDOP(" 88.52"))!($DATA(ICDOP(" 88.53")))!($DATA(ICDOP(" 88.54")))!($DATA(ICDOP(" 88.55")))!($DATA(ICDOP(" 88.56")))!($DATA(ICDOP(" 88.57")))!($DATA(ICDOP(" 88.58")))
- SET ICDRG=107
- +6 IF ICDRG'=106&(ICDRG'=107)&(ICDRG'=109)
- SET ICDRG=470
- Begin DoDot:1
- +7 ;I ICDCC D DRG110 Q
- +8 ;I ICDOR'["b" D DRG112 I +ICDRG>0&(+ICDRG<470) Q
- +9 ;I ICDOR'["b" D DRG516^ICDTLB6A I +ICDRG>0 Q
- +10 IF ICDCC
- DO DRG110
- QUIT
- +11 DO DRG111
- End DoDot:1
- +12 QUIT
- DRG107 DO DRG106
- QUIT
- DRG108 SET ICDRG=$SELECT(ICDOR["Oo":108,$DATA(ICDOP(" 38.44"))&$DATA(ICDOP(" 38.45")):108,ICDCC:110,1:111)
- QUIT
- DRG109 DO DRG106
- QUIT
- DRG110 DO DRG111
- QUIT
- DRG111 SET ICDRG=$SELECT(ICDOR["Oo":108,ICDCC&(ICDOR[7):110,ICDOR[7:111,1:ICDRG)
- +1 IF "108^110^111"[ICDRG
- QUIT
- +2 IF $DATA(ICDJJ(478))&('$DATA(ICDJJ(110))&'($DATA(ICDJJ(111))))
- DO DRG478^ICDTLB6A
- +3 DO DRG113
- IF ICDRG=113
- QUIT
- +4 IF ICDOR["p"
- DO DRG115
- +5 IF ICDOR["1"
- DO DRG516^ICDTLB6A
- +6 QUIT
- DRG112 SET ICDRG=$SELECT(ICDOR["Oo":108,(ICDOR["1")&($DATA(ICDOP(" 36.06"))):116,ICDOR["1":112,1:470)
- IF ICDRG=470
- Begin DoDot:1
- +1 IF ICDPD["A"
- DO DRG115
- QUIT
- +2 IF ICDOR["p"
- DO DRG117
- QUIT
- +3 DO DRG111
- End DoDot:1
- +4 QUIT
- DRG113 SET ICDRG=$SELECT($DATA(ICDJJ(113)):113,1:ICDRG)
- QUIT
- DRG115 DO EN1^ICDDRG5
- SET ICDRG=$SELECT($DATA(ICDOP(" 37.99"))&$DATA(ICDOP(" 37.98")):111,ICDPD["A"&(ICDCC3=1):115,ICDCC2:115,ICDCC3=1:116,ICDPD'["I"&(ICDCC3=0):127,1:"")
- QUIT
- DRG116 DO EN1^ICDDRG5
- SET ICDRG=$SELECT(ICDPD["A"&(ICDCC3=1):115,ICDCC3=1:116,1:"")
- if ICDOR["p"
- DO DRG118
- if ICDRG=""
- KILL ICDODRG(HICDRG)
- QUIT
- DRG117 DO EN1^ICDDRG5
- if ICDOR'["7"&('ICDCC3)
- QUIT
- SET ICDRG=$SELECT(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:117)
- QUIT
- DRG118 DO EN1^ICDDRG5
- SET ICDRG=$SELECT(ICDPD["A"&(ICDCC3):115,ICDCC3:116,1:118)
- QUIT
- DRG120 ;dx combo's for DRG120
- +1 NEW ICDE1,ICDE2
- +2 SET ICDE1=$SELECT($DATA(ICDOP(" 37.95"))&($DATA(ICDOP(" 37.96"))):1,1:0)
- SET ICDE2=$SELECT($DATA(ICDOP(" 37.97"))&($DATA(ICDOP(" 37.98"))):1,1:0)
- +3 SET ICDRG=$SELECT((ICDE1&(ICDOR["H")):104,(ICDE1&(ICDOR'["H")):105,(ICDE2&(ICDOR["H")):104,(ICDE2&(ICDOR'["H")):105,1:120)
- +4 QUIT
- DRG121 SET ICDRG=$SELECT(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470)
- IF ICDRG=470
- SET ICDRTC=5
- +1 QUIT
- DRG122 SET ICDRG=$SELECT(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470)
- IF ICDRG=470
- SET ICDRTC=5
- +1 QUIT
- DRG123 SET ICDRG=$SELECT(ICDSD["CV":121,ICDEXP=0:122,ICDEXP=1:123,1:470)
- IF ICDRG=470
- SET ICDRTC=5
- +1 QUIT
- DRG124 SET ICDRG=$SELECT(ICDPD["X"!(ICDSD["X"):124,1:125)
- QUIT
- DRG125 SET ICDRG=$SELECT(ICDPD["X"!(ICDSD["X"):124,1:125)
- QUIT
- DRG130 SET ICDRG=$SELECT(ICDCC:130,1:131)
- QUIT
- DRG131 SET ICDRG=$SELECT(ICDCC!($DATA(ICDSDRG(130))):130,1:131)
- QUIT
- DRG132 SET ICDRG=$SELECT(ICDCC:132,1:133)
- QUIT
- DRG133 SET ICDRG=$SELECT(ICDCC:132,1:133)
- QUIT
- DRG135 SET ICDRG=$SELECT(AGE<18:137,ICDCC:135,1:136)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG136 SET ICDRG=$SELECT(AGE<18:137,ICDCC:135,1:136)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG137 SET ICDRG=$SELECT(AGE<18:137,ICDCC:135,1:136)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG138 SET ICDRG=$SELECT(ICDCC:138,1:139)
- QUIT
- DRG139 SET ICDRG=$SELECT(ICDCC:138,1:139)
- QUIT
- DRG140 SET ICDRG=$SELECT(ICDOR["H":124,ICDNOR["H":124,1:140)
- QUIT
- DRG141 SET ICDRG=$SELECT(ICDCC:141,1:142)
- QUIT
- DRG142 SET ICDRG=$SELECT(ICDCC:141,1:142)
- QUIT
- DRG144 SET ICDRG=$SELECT(ICDCC:144,1:145)
- QUIT
- DRG145 SET ICDRG=$SELECT(ICDCC:144,1:145)
- QUIT
- DRG146 SET ICDRG=$SELECT(ICDCC:146,1:147)
- QUIT
- DRG147 SET ICDRG=$SELECT(ICDCC:146,1:147)
- QUIT
- DRG148 SET ICDRG=$SELECT(ICDCC:148,1:149)
- QUIT
- DRG149 SET ICDRG=$SELECT(ICDCC:148,1:149)
- QUIT
- DRG150 SET ICDRG=$SELECT(ICDCC:150,1:151)
- QUIT
- DRG151 SET ICDRG=$SELECT(ICDCC:150,1:151)
- QUIT
- DRG152 SET ICDRG=$SELECT(ICDCC:152,1:153)
- QUIT
- DRG153 SET ICDRG=$SELECT(ICDCC:152,1:153)
- QUIT
- DRG154 SET ICDRG=$SELECT(AGE<18:156,ICDCC:154,1:155)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG155 SET ICDRG=$SELECT(AGE<18:156,ICDCC:154,1:155)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG156 SET ICDRG=$SELECT(AGE<18:156,ICDCC:154,1:155)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG157 SET ICDRG=$SELECT(ICDCC:157,1:158)
- QUIT
- DRG158 SET ICDRG=$SELECT(ICDCC:157,1:158)
- QUIT
- DRG159 SET ICDRG=$SELECT(AGE<18:163,ICDCC:159,1:160)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG160 SET ICDRG=$SELECT(AGE<18:163,ICDCC:159,1:160)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG161 SET ICDRG=$SELECT(AGE<18:163,ICDCC:161,ICDSD["J":161,1:162)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT
- DRG162 SET ICDRG=$SELECT(AGE<18:163,ICDCC:161,1:162)
- IF AGE=""
- SET ICDRG=470
- SET ICDRTC=3
- +1 QUIT