ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am
;;18.0;DRG Grouper;**7**;Oct 20, 2000
;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
DRG335 S ICDRG=$S(ICDCC:334,1:335) Q
DRG336 S ICDRG=$S(ICDCC:336,1:337) Q
DRG337 S ICDRG=$S(ICDCC:336,1:337) Q
DRG338 I SEX="M" D Q
.S ICDRG=$S(ICDPD["M":338,AGE="":470,AGE>17:339,SEX="":470,1:340),ICDRTC=$S(ICDRG=470:3,SEX="":4,1:ICDRTC) Q
I SEX="F" D Q
.I ICDOR["O" D DRG354 Q
.I ICDOR["Ogz" D DRG363 Q
.I ICDOR=""!(ICDOR["N") D DRG366
Q
DRG339 D DRG338 Q
DRG340 D DRG338 Q
DRG342 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG343 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG344 S ICDRG=$S(ICDPD["M":344,1:345) Q
DRG345 S ICDRG=$S(ICDPD["M":344,1:345) Q
DRG346 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
Q
DRG347 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
Q
DRG348 S ICDRG=$S(ICDCC:348,1:349) Q
DRG349 S ICDRG=$S(ICDCC:348,1:349) Q
DRG350 S ICDRG=$S(SEX="M":350,1:368) I SEX="" S ICDRG=470,ICDRTC=4
Q
DRG351 S ICDRG=$S('$D(ICDODRG)&(ICDORNR>0):468,SEX="":470,SEX="F":369,1:351),ICDRTC=$S(ICDRG=470:4,1:ICDRTC) Q
DRG352 S ICDRG=$S(SEX="M":352,ICDPD["P":368,1:369) I SEX="" S ICDRG=470,ICDRTC=4
Q
DRG354 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) Q
DRG355 D DRG354 Q
DRG357 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) D:'ICDOPCT DRG368 Q
DRG358 D DRG357 Q
DRG359 D DRG357 Q
DRG363 S ICDRG=$S(ICDPD["M":363,1:364) Q
DRG364 S ICDRG=$S(ICDPD["M":363,1:364) Q
DRG366 S ICDRG=$S(ICDCC:366,1:367) Q
DRG367 S ICDRG=$S(ICDCC:366,1:367) Q
DRG368 S ICDRG=$S(SEX="F":368,1:470) I SEX="" S ICDRG=470,ICDRTC=4
Q
DRG370 S ICDRG=$S(ICDOR["c"&(ICDCC):370,ICDOR["c":371,ICDOR'["s"&(ICDOR'["g")&(ICDSD["v"!(ICDPD["v")):372,ICDOR'["s"&(ICDOR'["g"):373,ICDOR["s":374,ICDOR["g":375,1:470) Q
DRG371 S ICDRG=$S(ICDPD["D"&(ICDCC):370,ICDPD["D":371,1:469) I $D(ICDOR)<11!(ICDOR["n") D DRG372
Q
DRG372 S ICDRG=$S(ICDPD["v"!(ICDSD["v"):372,ICDOR["s":374,ICDOR["g":375,1:373) Q
DRG373 S ICDRG=$S(ICDPD["D"&(ICDPD["v"!(ICDPD["D"&(ICDSD["v"))):372,1:373) Q
DRG374 S ICDRG=$S($D(ICDPDRG(374)):374,1:"") Q
DRG375 S ICDRG=$S(ICDPD["D"!(ICDSD["D"):375,1:"") Q
DRG376 S ICDRG=$S(ICDOR["O":377,1:376) Q
DRG377 S ICDRG=$S(ICDOR["O":377,1:376) Q
DRG380 S ICDRG=$S(ICDOR["d":381,1:380) Q
DRG381 S ICDRG=$S('$D(ICDPDRG(381)):"",ICDOR["d":381,1:380) Q
DRG383 S ICDRG=$S(ICDPD["F"&(ICDSD["u"):383,ICDSD["u"!(ICDPD["v"):383,ICDPD["u":383,1:384) Q
DRG384 D DRG383 Q
DRG387 ;
S ICDRG=$S(ICDPD["E":386,ICDSD["E":386,ICDPD["Hp"&(ICDSD["J"):387,ICDPD["J"&(ICDSD["Hp"):387,ICDPD["p"!(ICDSD["p")&((ICDPD'["J")!(ICDSD'["J")):388,1:"") D:ICDRG="" DRG389 Q
DRG388 D DRG387 Q
DRG389 S ICDRG=$S(ICDPD["HR"&(ICDSD["J"):389,ICDPD["J"&(ICDSD["HR"):389,ICDSD["J":389,ICDPD["J":389,'$D(ICDODRG)&('$D(ICDSDRG)):391,1:390) D:ICDRG=391 DRG391 Q
DRG390 D DRG389 Q
DRG391 S ICDRG=$S(ICDPD["E"!(ICDSD["E"):386,ICDPD["J"&(ICDPD["p"):387,ICDSD["J"&(ICDSD["p"):387,ICDPD["p"&(ICDPD'["J"):388,ICDSD["p"&(ICDSD'["J"):388,ICDPD["J"!(ICDSD["J"):389,1:"") I ICDRG'="" Q
I ICDPD["R" D Q:ICDRG=391
.I '$D(ICDDX(2)) S ICDRG=391 Q
.;ALL SECONDARIES CONTAIN "R", DRG=>391
.N I
.F I=1:1 Q:'$D(ICDDX(I)) S ICDRG=$S($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["R":391,1:390) Q:ICDRG=390
I ICDSD["R"&('$D(ICDDX(3))) S ICDRG=391 Q
S ICDRG=390
Q
DRG392 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG393 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG395 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG396 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG398 S ICDRG=$S(ICDCC:398,1:399) Q
DRG399 S ICDRG=$S(ICDCC:398,1:399) Q
DRG400 I ICDPD["L"&(ICDMAJ'[3) D DRG401 Q:"401^402^403^404^405^470^473"[ICDRG
S ICDRG=$S(ICDPD["L":400,ICDCC:406,1:407) Q
DRG401 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
DRG402 D DRG401
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTLB5 4162 printed Dec 13, 2024@01:52:37 Page 2
ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am
+1 ;;18.0;DRG Grouper;**7**;Oct 20, 2000
+2 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
DRG334 SET ICDRG=$SELECT(ICDCC:334,1:335)
QUIT
DRG335 SET ICDRG=$SELECT(ICDCC:334,1:335)
QUIT
DRG336 SET ICDRG=$SELECT(ICDCC:336,1:337)
QUIT
DRG337 SET ICDRG=$SELECT(ICDCC:336,1:337)
QUIT
DRG338 IF SEX="M"
Begin DoDot:1
+1 SET ICDRG=$SELECT(ICDPD["M":338,AGE="":470,AGE>17:339,SEX="":470,1:340)
SET ICDRTC=$SELECT(ICDRG=470:3,SEX="":4,1:ICDRTC)
QUIT
End DoDot:1
QUIT
+2 IF SEX="F"
Begin DoDot:1
+3 IF ICDOR["O"
DO DRG354
QUIT
+4 IF ICDOR["Ogz"
DO DRG363
QUIT
+5 IF ICDOR=""!(ICDOR["N")
DO DRG366
End DoDot:1
QUIT
+6 QUIT
DRG339 DO DRG338
QUIT
DRG340 DO DRG338
QUIT
DRG342 SET ICDRG=$SELECT(AGE>17:342,1:343)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG343 SET ICDRG=$SELECT(AGE>17:342,1:343)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG344 SET ICDRG=$SELECT(ICDPD["M":344,1:345)
QUIT
DRG345 SET ICDRG=$SELECT(ICDPD["M":344,1:345)
QUIT
DRG346 SET ICDRG=$SELECT(ICDCC:346,1:347)
IF ICDMDC=13
SET ICDRG=$SELECT(ICDRG=346:366,1:367)
+1 QUIT
DRG347 SET ICDRG=$SELECT(ICDCC:346,1:347)
IF ICDMDC=13
SET ICDRG=$SELECT(ICDRG=346:366,1:367)
+1 QUIT
DRG348 SET ICDRG=$SELECT(ICDCC:348,1:349)
QUIT
DRG349 SET ICDRG=$SELECT(ICDCC:348,1:349)
QUIT
DRG350 SET ICDRG=$SELECT(SEX="M":350,1:368)
IF SEX=""
SET ICDRG=470
SET ICDRTC=4
+1 QUIT
DRG351 SET ICDRG=$SELECT('$DATA(ICDODRG)&(ICDORNR>0):468,SEX="":470,SEX="F":369,1:351)
SET ICDRTC=$SELECT(ICDRG=470:4,1:ICDRTC)
QUIT
DRG352 SET ICDRG=$SELECT(SEX="M":352,ICDPD["P":368,1:369)
IF SEX=""
SET ICDRG=470
SET ICDRTC=4
+1 QUIT
DRG354 SET ICDRG=$SELECT(ICDPD["M":$SELECT(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359)
QUIT
DRG355 DO DRG354
QUIT
DRG357 SET ICDRG=$SELECT(ICDPD["M":$SELECT(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359)
if 'ICDOPCT
DO DRG368
QUIT
DRG358 DO DRG357
QUIT
DRG359 DO DRG357
QUIT
DRG363 SET ICDRG=$SELECT(ICDPD["M":363,1:364)
QUIT
DRG364 SET ICDRG=$SELECT(ICDPD["M":363,1:364)
QUIT
DRG366 SET ICDRG=$SELECT(ICDCC:366,1:367)
QUIT
DRG367 SET ICDRG=$SELECT(ICDCC:366,1:367)
QUIT
DRG368 SET ICDRG=$SELECT(SEX="F":368,1:470)
IF SEX=""
SET ICDRG=470
SET ICDRTC=4
+1 QUIT
DRG370 SET ICDRG=$SELECT(ICDOR["c"&(ICDCC):370,ICDOR["c":371,ICDOR'["s"&(ICDOR'["g")&(ICDSD["v"!(ICDPD["v")):372,ICDOR'["s"&(ICDOR'["g"):373,ICDOR["s":374,ICDOR["g":375,1:470)
QUIT
DRG371 SET ICDRG=$SELECT(ICDPD["D"&(ICDCC):370,ICDPD["D":371,1:469)
IF $DATA(ICDOR)<11!(ICDOR["n")
DO DRG372
+1 QUIT
DRG372 SET ICDRG=$SELECT(ICDPD["v"!(ICDSD["v"):372,ICDOR["s":374,ICDOR["g":375,1:373)
QUIT
DRG373 SET ICDRG=$SELECT(ICDPD["D"&(ICDPD["v"!(ICDPD["D"&(ICDSD["v"))):372,1:373)
QUIT
DRG374 SET ICDRG=$SELECT($DATA(ICDPDRG(374)):374,1:"")
QUIT
DRG375 SET ICDRG=$SELECT(ICDPD["D"!(ICDSD["D"):375,1:"")
QUIT
DRG376 SET ICDRG=$SELECT(ICDOR["O":377,1:376)
QUIT
DRG377 SET ICDRG=$SELECT(ICDOR["O":377,1:376)
QUIT
DRG380 SET ICDRG=$SELECT(ICDOR["d":381,1:380)
QUIT
DRG381 SET ICDRG=$SELECT('$DATA(ICDPDRG(381)):"",ICDOR["d":381,1:380)
QUIT
DRG383 SET ICDRG=$SELECT(ICDPD["F"&(ICDSD["u"):383,ICDSD["u"!(ICDPD["v"):383,ICDPD["u":383,1:384)
QUIT
DRG384 DO DRG383
QUIT
DRG387 ;
+1 SET ICDRG=$SELECT(ICDPD["E":386,ICDSD["E":386,ICDPD["Hp"&(ICDSD["J"):387,ICDPD["J"&(ICDSD["Hp"):387,ICDPD["p"!(ICDSD["p")&((ICDPD'["J")!(ICDSD'["J")):388,1:"")
if ICDRG=""
DO DRG389
QUIT
DRG388 DO DRG387
QUIT
DRG389 SET ICDRG=$SELECT(ICDPD["HR"&(ICDSD["J"):389,ICDPD["J"&(ICDSD["HR"):389,ICDSD["J":389,ICDPD["J":389,'$DATA(ICDODRG)&('$DATA(ICDSDRG)):391,1:390)
if ICDRG=391
DO DRG391
QUIT
DRG390 DO DRG389
QUIT
DRG391 SET ICDRG=$SELECT(ICDPD["E"!(ICDSD["E"):386,ICDPD["J"&(ICDPD["p"):387,ICDSD["J"&(ICDSD["p"):387,ICDPD["p"&(ICDPD'["J"):388,ICDSD["p"&(ICDSD'["J"):388,ICDPD["J"!(ICDSD["J"):389,1:"")
IF ICDRG'=""
QUIT
+1 IF ICDPD["R"
Begin DoDot:1
+2 IF '$DATA(ICDDX(2))
SET ICDRG=391
QUIT
+3 ;ALL SECONDARIES CONTAIN "R", DRG=>391
+4 NEW I
+5 FOR I=1:1
if '$DATA(ICDDX(I))
QUIT
SET ICDRG=$SELECT($PIECE($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["R":391,1:390)
if ICDRG=390
QUIT
End DoDot:1
if ICDRG=391
QUIT
+6 IF ICDSD["R"&('$DATA(ICDDX(3)))
SET ICDRG=391
QUIT
+7 SET ICDRG=390
+8 QUIT
DRG392 SET ICDRG=$SELECT(AGE>17:392,1:393)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG393 SET ICDRG=$SELECT(AGE>17:392,1:393)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG395 SET ICDRG=$SELECT(AGE>17:395,1:396)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG396 SET ICDRG=$SELECT(AGE>17:395,1:396)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG398 SET ICDRG=$SELECT(ICDCC:398,1:399)
QUIT
DRG399 SET ICDRG=$SELECT(ICDCC:398,1:399)
QUIT
DRG400 IF ICDPD["L"&(ICDMAJ'[3)
DO DRG401
if "401^402^403^404^405^470^473"[ICDRG
QUIT
+1 SET ICDRG=$SELECT(ICDPD["L":400,ICDCC:406,1:407)
QUIT
DRG401 SET ICDRG=$SELECT(ICDPD["l":$SELECT(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$SELECT(ICDCC:401,1:402),ICDCC:403,1:404)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
+1 QUIT
DRG402 DO DRG401
+1 QUIT
