ICDTBL3D.m

ICDTBL3D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010

 ;;18.0;DRG Grouper;**56,69**;Oct 20, 2000;Build 7

DRG300 ;

DRG301 S ICDRG=$S(ICDMCC=2:299,ICDMCC=1:300,1:301) Q

DRG302 ;

DRG303 S ICDRG=$S(ICDMCC=2:302,1:303) Q

DRG304 ;

DRG305 S ICDRG=$S(ICDMCC=2:304,1:305) Q

DRG306 ;

DRG307 S ICDRG=$S(ICDMCC=2:306,1:307) Q

DRG308 ;

DRG309 ;

DRG310 ;I (ICDDX(1)=2559!$D(ICDDXT("427.41"))),'ICDEXP S ICDMCC=2

 I (ICDDX(1)=2557&$D(ICDDXT("425.4"))) S ICDMCC=0

 I (ICDDX(1)=2558&$D(ICDDXT("425.4"))) S ICDMCC=0

 ;I ICDSD["V" S ICDMCC="0"

 S ICDRG=$S(ICDMCC=2:308,ICDMCC=1:309,1:310) Q

DRG311 S ICDRG=311 Q

DRG312 S ICDRG=312 Q

DRG313 S ICDRG=313 Q

DRG314 ;

DRG315 ;

DRG316 S ICDRG=$S(ICDMCC=2:314,ICDMCC=1:315,1:316) Q

DRG326 ;

DRG327 ;

DRG328 S ICDRG=$S(ICDMCC=2:326,ICDMCC=1:327,1:328) Q

DRG329 ;

DRG330 ;

DRG331 S ICDRG=$S(ICDMCC=2:329,ICDMCC=1:330,1:331) Q

DRG332 ;

DRG333 ;

DRG334 S ICDRG=$S(ICDMCC=2:332,ICDMCC=1:333,1:334) Q

DRG335 ;

DRG336 ;

DRG337 S ICDRG=$S(ICDMCC=2:335,ICDMCC=1:336,1:337) Q

DRG338 ;

DRG339 ;

DRG340 I " 246 9197 2954 "'[ICDDX(1) W !,"DRG340" D DRG343 Q

       S ICDRG=$S(ICDMCC=2:338,ICDMCC=1:339,1:340) Q

DRG341 ;

DRG342 ;

DRG343 I ICDOR="" D DRG374 Q

       I " 246 9197 2954 "[ICDDX(1) W !,"DRG343",ICDDX(1) D DRG340 Q

       I ICDOR["a" D DRG727^ICDTBL7D Q

       S ICDRG=$S(ICDMCC=2:341,ICDMCC=1:342,1:343) Q

DRG344 ;

DRG345 ;

DRG346 S ICDRG=$S(ICDMCC=2:344,ICDMCC=1:345,1:346) Q

DRG347 ;

DRG348 ;

DRG349 S ICDRG=$S(ICDMCC=2:347,ICDMCC=1:348,1:349) Q

DRG350 ;

DRG351 ;

DRG352 I ICDOR["J" S ICDRG=$S(ICDMCC=2:350,ICDMCC=1:351,1:352) Q

DRG353 ;

DRG354 ;

DRG355 S ICDRG=$S(ICDMCC=2:353,ICDMCC=1:354,1:355) Q

DRG356 ;

DRG357 ;

DRG358 S ICDRG=$S(ICDMCC=2:356,ICDMCC=1:357,1:358) Q

DRG368 ;

DRG369 ;

DRG370 S ICDRG=$S(ICDMCC=2:368,ICDMCC=1:369,1:370) Q

DRG371 ;

DRG372 ;

DRG373 S ICDRG=$S(ICDMCC=2:371,ICDMCC=1:372,1:373) Q

DRG374 ;

DRG375 ;

DRG376 S ICDRG=$S(ICDMCC=2:374,ICDMCC=1:375,1:376) Q

DRG377 ;

DRG378 ;

DRG379 S ICDRG=$S(ICDMCC=2:377,ICDMCC=1:378,1:379) Q

DRG380 ;

DRG381 ;

DRG382 S ICDRG=$S(ICDMCC=2:380,ICDMCC=1:381,1:382) Q

DRG383 ;

DRG384 S ICDRG=$S(ICDMCC=2:383,1:384) Q

DRG385 ;

DRG386 ;

DRG387 S ICDRG=$S(ICDMCC=2:385,ICDMCC=1:386,1:387) Q

DRG388 ;

DRG389 ;

DRG390 S ICDRG=$S(ICDMCC=2:388,ICDMCC=1:389,1:390) Q

DRG391 ;

DRG392 S ICDRG=$S(ICDMCC=2:391,1:392) Q

DRG393 ;

DRG394 ;

DRG395 I ICDOR["J" D DRG350 Q

    S ICDRG=$S(ICDMCC=2:393,ICDMCC=1:394,1:395) Q

 Q

ICDTBL3D  ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010

 +1       ;;18.0;DRG Grouper;**56,69**;Oct 20, 2000;Build 7

DRG300    ;

DRG301     SET ICDRG=$SELECT(ICDMCC=2:299,ICDMCC=1:300,1:301)

           QUIT 

DRG302    ;

DRG303     SET ICDRG=$SELECT(ICDMCC=2:302,1:303)

           QUIT 

DRG304    ;

DRG305     SET ICDRG=$SELECT(ICDMCC=2:304,1:305)

           QUIT 

DRG306    ;

DRG307     SET ICDRG=$SELECT(ICDMCC=2:306,1:307)

           QUIT 

DRG308    ;

DRG309    ;

DRG310    ;I (ICDDX(1)=2559!$D(ICDDXT("427.41"))),'ICDEXP S ICDMCC=2

 +1        IF (ICDDX(1)=2557&$DATA(ICDDXT("425.4")))

               SET ICDMCC=0

 +2        IF (ICDDX(1)=2558&$DATA(ICDDXT("425.4")))

               SET ICDMCC=0

 +3       ;I ICDSD["V" S ICDMCC="0"

 +4        SET ICDRG=$SELECT(ICDMCC=2:308,ICDMCC=1:309,1:310)

           QUIT 

DRG311     SET ICDRG=311

           QUIT 

DRG312     SET ICDRG=312

           QUIT 

DRG313     SET ICDRG=313

           QUIT 

DRG314    ;

DRG315    ;

DRG316     SET ICDRG=$SELECT(ICDMCC=2:314,ICDMCC=1:315,1:316)

           QUIT 

DRG326    ;

DRG327    ;

DRG328     SET ICDRG=$SELECT(ICDMCC=2:326,ICDMCC=1:327,1:328)

           QUIT 

DRG329    ;

DRG330    ;

DRG331     SET ICDRG=$SELECT(ICDMCC=2:329,ICDMCC=1:330,1:331)

           QUIT 

DRG332    ;

DRG333    ;

DRG334     SET ICDRG=$SELECT(ICDMCC=2:332,ICDMCC=1:333,1:334)

           QUIT 

DRG335    ;

DRG336    ;

DRG337     SET ICDRG=$SELECT(ICDMCC=2:335,ICDMCC=1:336,1:337)

           QUIT 

DRG338    ;

DRG339    ;

DRG340     IF " 246 9197 2954 "'[ICDDX(1)

               WRITE !,"DRG340"

               DO DRG343

               QUIT 

 +1        SET ICDRG=$SELECT(ICDMCC=2:338,ICDMCC=1:339,1:340)

           QUIT 

DRG341    ;

DRG342    ;

DRG343     IF ICDOR=""

               DO DRG374

               QUIT 

 +1        IF " 246 9197 2954 "[ICDDX(1)

               WRITE !,"DRG343",ICDDX(1)

               DO DRG340

               QUIT 

 +2        IF ICDOR["a"

               DO DRG727^ICDTBL7D

               QUIT 

 +3        SET ICDRG=$SELECT(ICDMCC=2:341,ICDMCC=1:342,1:343)

           QUIT 

DRG344    ;

DRG345    ;

DRG346     SET ICDRG=$SELECT(ICDMCC=2:344,ICDMCC=1:345,1:346)

           QUIT 

DRG347    ;

DRG348    ;

DRG349     SET ICDRG=$SELECT(ICDMCC=2:347,ICDMCC=1:348,1:349)

           QUIT 

DRG350    ;

DRG351    ;

DRG352     IF ICDOR["J"

               SET ICDRG=$SELECT(ICDMCC=2:350,ICDMCC=1:351,1:352)

               QUIT 

DRG353    ;

DRG354    ;

DRG355     SET ICDRG=$SELECT(ICDMCC=2:353,ICDMCC=1:354,1:355)

           QUIT 

DRG356    ;

DRG357    ;

DRG358     SET ICDRG=$SELECT(ICDMCC=2:356,ICDMCC=1:357,1:358)

           QUIT 

DRG368    ;

DRG369    ;

DRG370     SET ICDRG=$SELECT(ICDMCC=2:368,ICDMCC=1:369,1:370)

           QUIT 

DRG371    ;

DRG372    ;

DRG373     SET ICDRG=$SELECT(ICDMCC=2:371,ICDMCC=1:372,1:373)

           QUIT 

DRG374    ;

DRG375    ;

DRG376     SET ICDRG=$SELECT(ICDMCC=2:374,ICDMCC=1:375,1:376)

           QUIT 

DRG377    ;

DRG378    ;

DRG379     SET ICDRG=$SELECT(ICDMCC=2:377,ICDMCC=1:378,1:379)

           QUIT 

DRG380    ;

DRG381    ;

DRG382     SET ICDRG=$SELECT(ICDMCC=2:380,ICDMCC=1:381,1:382)

           QUIT 

DRG383    ;

DRG384     SET ICDRG=$SELECT(ICDMCC=2:383,1:384)

           QUIT 

DRG385    ;

DRG386    ;

DRG387     SET ICDRG=$SELECT(ICDMCC=2:385,ICDMCC=1:386,1:387)

           QUIT 

DRG388    ;

DRG389    ;

DRG390     SET ICDRG=$SELECT(ICDMCC=2:388,ICDMCC=1:389,1:390)

           QUIT 

DRG391    ;

DRG392     SET ICDRG=$SELECT(ICDMCC=2:391,1:392)

           QUIT 

DRG393    ;

DRG394    ;

DRG395     IF ICDOR["J"

               DO DRG350

               QUIT 

 +1        SET ICDRG=$SELECT(ICDMCC=2:393,ICDMCC=1:394,1:395)

           QUIT 

 +2        QUIT