- 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 Feb 18, 2025@23:18:58 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