Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDTLB5

ICDTLB5.m

Go to the documentation of this file.
  1. ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am
  1. ;;18.0;DRG Grouper;**7**;Oct 20, 2000
  1. ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
  1. DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
  1. DRG335 S ICDRG=$S(ICDCC:334,1:335) Q
  1. DRG336 S ICDRG=$S(ICDCC:336,1:337) Q
  1. DRG337 S ICDRG=$S(ICDCC:336,1:337) Q
  1. DRG338 I SEX="M" D Q
  1. .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
  1. I SEX="F" D Q
  1. .I ICDOR["O" D DRG354 Q
  1. .I ICDOR["Ogz" D DRG363 Q
  1. .I ICDOR=""!(ICDOR["N") D DRG366
  1. Q
  1. DRG339 D DRG338 Q
  1. DRG340 D DRG338 Q
  1. DRG342 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG343 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG344 S ICDRG=$S(ICDPD["M":344,1:345) Q
  1. DRG345 S ICDRG=$S(ICDPD["M":344,1:345) Q
  1. DRG346 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
  1. Q
  1. DRG347 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
  1. Q
  1. DRG348 S ICDRG=$S(ICDCC:348,1:349) Q
  1. DRG349 S ICDRG=$S(ICDCC:348,1:349) Q
  1. DRG350 S ICDRG=$S(SEX="M":350,1:368) I SEX="" S ICDRG=470,ICDRTC=4
  1. Q
  1. DRG351 S ICDRG=$S('$D(ICDODRG)&(ICDORNR>0):468,SEX="":470,SEX="F":369,1:351),ICDRTC=$S(ICDRG=470:4,1:ICDRTC) Q
  1. DRG352 S ICDRG=$S(SEX="M":352,ICDPD["P":368,1:369) I SEX="" S ICDRG=470,ICDRTC=4
  1. Q
  1. DRG354 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) Q
  1. DRG355 D DRG354 Q
  1. DRG357 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) D:'ICDOPCT DRG368 Q
  1. DRG358 D DRG357 Q
  1. DRG359 D DRG357 Q
  1. DRG363 S ICDRG=$S(ICDPD["M":363,1:364) Q
  1. DRG364 S ICDRG=$S(ICDPD["M":363,1:364) Q
  1. DRG366 S ICDRG=$S(ICDCC:366,1:367) Q
  1. DRG367 S ICDRG=$S(ICDCC:366,1:367) Q
  1. DRG368 S ICDRG=$S(SEX="F":368,1:470) I SEX="" S ICDRG=470,ICDRTC=4
  1. Q
  1. 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
  1. DRG371 S ICDRG=$S(ICDPD["D"&(ICDCC):370,ICDPD["D":371,1:469) I $D(ICDOR)<11!(ICDOR["n") D DRG372
  1. Q
  1. DRG372 S ICDRG=$S(ICDPD["v"!(ICDSD["v"):372,ICDOR["s":374,ICDOR["g":375,1:373) Q
  1. DRG373 S ICDRG=$S(ICDPD["D"&(ICDPD["v"!(ICDPD["D"&(ICDSD["v"))):372,1:373) Q
  1. DRG374 S ICDRG=$S($D(ICDPDRG(374)):374,1:"") Q
  1. DRG375 S ICDRG=$S(ICDPD["D"!(ICDSD["D"):375,1:"") Q
  1. DRG376 S ICDRG=$S(ICDOR["O":377,1:376) Q
  1. DRG377 S ICDRG=$S(ICDOR["O":377,1:376) Q
  1. DRG380 S ICDRG=$S(ICDOR["d":381,1:380) Q
  1. DRG381 S ICDRG=$S('$D(ICDPDRG(381)):"",ICDOR["d":381,1:380) Q
  1. DRG383 S ICDRG=$S(ICDPD["F"&(ICDSD["u"):383,ICDSD["u"!(ICDPD["v"):383,ICDPD["u":383,1:384) Q
  1. DRG384 D DRG383 Q
  1. DRG387 ;
  1. 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
  1. DRG388 D DRG387 Q
  1. 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
  1. DRG390 D DRG389 Q
  1. 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
  1. I ICDPD["R" D Q:ICDRG=391
  1. .I '$D(ICDDX(2)) S ICDRG=391 Q
  1. .;ALL SECONDARIES CONTAIN "R", DRG=>391
  1. .N I
  1. .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
  1. I ICDSD["R"&('$D(ICDDX(3))) S ICDRG=391 Q
  1. S ICDRG=390
  1. Q
  1. DRG392 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG393 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG395 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG396 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
  1. Q
  1. DRG398 S ICDRG=$S(ICDCC:398,1:399) Q
  1. DRG399 S ICDRG=$S(ICDCC:398,1:399) Q
  1. DRG400 I ICDPD["L"&(ICDMAJ'[3) D DRG401 Q:"401^402^403^404^405^470^473"[ICDRG
  1. S ICDRG=$S(ICDPD["L":400,ICDCC:406,1:407) Q
  1. 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)
  1. Q
  1. DRG402 D DRG401
  1. Q