ICDTBL3D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
;;18.0;DRG Grouper;**56,69,71**;Oct 20, 2000;Build 3
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 I ICDDX(1)=11611,$D(ICDDXT("427.5")),ICDMCC=2,ICDEXP=1 S ICDMCC=1
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 I ICDDX(1)=12671,$D(ICDDXT("785.59")),ICDEXP=1,ICDMCC=2 S ICDMCC=1
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 I $D(ICDDXT("799.1")),ICDEXP=1,ICDMCC=2 S ICDRG=392 Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTBL3D 2682 printed Dec 13, 2024@01:51:32 Page 2
ICDTBL3D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
+1 ;;18.0;DRG Grouper;**56,69,71**;Oct 20, 2000;Build 3
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 IF ICDDX(1)=11611
IF $DATA(ICDDXT("427.5"))
IF ICDMCC=2
IF ICDEXP=1
SET ICDMCC=1
+1 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 IF ICDDX(1)=12671
IF $DATA(ICDDXT("785.59"))
IF ICDEXP=1
IF ICDMCC=2
SET ICDMCC=1
+1 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 IF $DATA(ICDDXT("799.1"))
IF ICDEXP=1
IF ICDMCC=2
SET ICDRG=392
QUIT
+1 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
