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

ICDTBL4D.m

Go to the documentation of this file.
  1. ICDTBL4D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
  1. ;;18.0;DRG Grouper;**56,55,62,70**;Oct 20, 2000;Build 6
  1. DRG405 ;
  1. DRG406 ;
  1. DRG407 S ICDRG=$S(ICDMCC=2:405,ICDMCC=1:406,1:407) Q
  1. DRG408 ;
  1. ;I ICDOR["E"!(ICDOR["T") I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:411,ICDMCC=1:412,1:413) Q
  1. I $D(ICDOP(" 51.41")) I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:411,ICDMCC=1:412,1:413) Q
  1. I $D(ICDOP(" 51.42")) I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:411,ICDMCC=1:412,1:413) Q
  1. I $D(ICDOP(" 51.51")) I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22"))!$D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:411,ICDMCC=1:412,1:413) Q
  1. I ICDOR["3" S ICDRG=$S(ICDMCC=2:408,ICDMCC=1:409,1:410) Q
  1. I $D(ICDOP(" 51.21"))!$D(ICDOP(" 51.22")) S ICDRG=$S(ICDMCC=2:414,ICDMCC=1:415,1:416) Q
  1. I $D(ICDOP(" 51.23"))!$D(ICDOP(" 51.24")) S ICDRG=$S(ICDMCC=2:417,ICDMCC=1:418,1:419) Q
  1. I ICDOR["h" S ICDRG=$S(ICDMCC=2:420,ICDMCC=1:421,1:422) Q
  1. I ICDPD["M"&(ICDOR'["h") S ICDRG=$S(ICDMCC=2:435,ICDMCC=1:436,1:437) Q
  1. I ICDSD'="" S ICDRG=$S(ICDMCC=2:438,ICDMCC=1:439,1:440) Q
  1. I ICDOR["O" S ICDRG=$S(ICDMCC=2:438,ICDMCC=1:439,1:440) Q
  1. S ICDRG=$S(ICDMCC=2:438,ICDMCC=1:439,1:440) Q
  1. ;S ICDRG=$S(ICDMCC=2&(ICDOR["O"):438,ICDMCC=1&(ICDOR["O"):439,1:440) Q
  1. Q
  1. DRG409 ;
  1. DRG410 D DRG408 Q
  1. DRG411 ;
  1. DRG412 ;
  1. DRG413 D DRG408 Q
  1. DRG414 ;
  1. DRG415 ;
  1. DRG416 D DRG408 Q
  1. DRG417 ;
  1. DRG418 ;
  1. DRG419 D DRG408 Q
  1. DRG420 ;
  1. DRG421 ;
  1. DRG422 D DRG408 Q
  1. DRG423 ;
  1. DRG424 ;
  1. DRG425 S ICDRG=$S(ICDMCC=2:423,ICDMCC=1:424,1:425) Q
  1. DRG432 ;
  1. DRG433 ;
  1. DRG434 S ICDRG=$S(ICDMCC=2:432,ICDMCC=1:433,1:434) Q
  1. DRG435 ;
  1. DRG436 ;
  1. DRG437 D DRG408 Q
  1. DRG438 ;
  1. DRG439 ;
  1. DRG440 D DRG408 Q
  1. DRG441 ;
  1. DRG442 ;
  1. DRG443 S ICDRG=$S(ICDMCC=2:441,ICDMCC=1:442,1:443) Q
  1. DRG444 ;
  1. DRG445 ;
  1. DRG446 S ICDRG=$S(ICDMCC=2:444,ICDMCC=1:445,1:446) Q
  1. DRG453 ;
  1. DRG454 ;
  1. DRG455 ;
  1. N CNTA,CNTP S CNTA=0,CNTP=0
  1. I $D(ICDOP(" 81.02")) S CNTA=1
  1. I $D(ICDOP(" 81.04")) S CNTA=1
  1. I $D(ICDOP(" 81.06")) S CNTA=1
  1. I $D(ICDOP(" 81.32")) S CNTA=1
  1. I $D(ICDOP(" 81.36")) S CNTA=1
  1. I $D(ICDOP(" 81.03")) S CNTP=1
  1. I $D(ICDOP(" 81.05")) S CNTP=1
  1. I $D(ICDOP(" 81.07")) S CNTP=1
  1. I $D(ICDOP(" 81.08")) S CNTP=1
  1. I $D(ICDOP(" 81.33")) S CNTP=1
  1. I $D(ICDOP(" 81.35")) S CNTP=1
  1. I $D(ICDOP(" 81.37")) S CNTP=1
  1. I $D(ICDOP(" 81.38")) S CNTP=1
  1. I CNTA=1,CNTP=1 D
  1. . S ICDRG=$S(ICDMCC=2:453,ICDMCC=1:454,1:455) Q
  1. E S ICDRG=""
  1. Q
  1. DRG456 ;
  1. DRG457 ;
  1. DRG458 ;
  1. I ICDOR="" D DRG541^ICDTBL5D Q
  1. I ICDPD["k" D DRG541^ICDTBL5D Q
  1. I ICDPD["6",$D(ICDOP(" 81.64")) S ICDRG=$S(ICDMCC=2:456,ICDMCC=1:457,1:458) Q
  1. I ICDSD["6",$D(ICDOP(" 81.64")) S ICDRG=$S(ICDMCC=2:456,ICDMCC=1:457,1:458) Q
  1. I ICDPD["6" S ICDRG=$S(ICDMCC=2:456,ICDMCC=1:457,1:458) Q
  1. DRG459 ;
  1. DRG460 S ICDRG=$S(ICDMCC=2:459,1:460) Q
  1. DRG461 ;
  1. DRG462 ;
  1. N ICDCT S ICDCT=""
  1. N CNT S CNT=0
  1. F S ICDCT=$O(ICDSURG(ICDCT)) Q:ICDCT="" D
  1. .I $P(ICDSURG(ICDCT),"^")="00.70"!($P(ICDSURG(ICDCT),"^")["00.70") S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="00.80"!($P(ICDSURG(ICDCT),"^")["00.80") S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="00.85"!($P(ICDSURG(ICDCT),"^")["00.85") S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="00.86"!($P(ICDSURG(ICDCT),"^")["00.86") S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="00.87"!($P(ICDSURG(ICDCT),"^")["00.87") S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="81.51" S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="81.52" S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="81.54" S CNT=CNT+1 Q
  1. .I $P(ICDSURG(ICDCT),"^")="81.56" S CNT=CNT+1 Q
  1. I CNT>1 S ICDRG=$S(ICDMCC=2:461,1:462) Q
  1. I $D(ICDOP(" 00.70"))!$D(ICDOP(" 00.80")) D DRG466 Q
  1. E D DRG469 Q
  1. DRG463 ;
  1. DRG464 ;
  1. DRG465 S ICDRG=$S(ICDMCC=2:463,ICDMCC=1:464,1:465) Q
  1. DRG466 ;
  1. DRG467 ;
  1. DRG468 S ICDRG=$S(ICDMCC=2:466,ICDMCC=1:467,1:468) Q
  1. DRG469 ;
  1. DRG470 I ICDEXP=1 S ICDMCC=1
  1. S ICDRG=$S(ICDMCC=2:469,1:470) Q
  1. DRG471 ;
  1. DRG472 ;
  1. DRG473 S ICDRG=$S(ICDMCC=2:471,ICDMCC=1:472,1:473) Q
  1. DRG474 ;
  1. DRG475 ;
  1. DRG476 S ICDRG=$S(ICDMCC=2:474,ICDMCC=1:475,1:476) Q
  1. DRG477 ;
  1. DRG478 ;
  1. DRG479 S ICDRG=$S(ICDMCC=2:477,ICDMCC=1:478,1:479) Q
  1. DRG480 ;
  1. DRG481 ;
  1. DRG482 S ICDRG=$S(ICDMCC=2:480,ICDMCC=1:481,1:482) Q
  1. DRG483 ;
  1. DRG484 S ICDRG=$S(ICDMCC>0:483,1:484) Q
  1. DRG485 ;
  1. DRG486 ;
  1. DRG487 I ICDPD["k" S ICDRG=$S(ICDMCC=2:485,ICDMCC=1:486,1:487) Q
  1. E S ICDRG=""
  1. DRG488 ;
  1. DRG489 S ICDRG=$S(ICDMCC>0:488,1:489) Q
  1. DRG490 ;
  1. DRG491 ;
  1. I ICDPD["6" D
  1. .N ICDXFLG
  1. .S ICDXFLG=0
  1. .I '$D(ICDOP(" 03.02"))!('$D(ICDOP(" 03.09"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.1")) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.32"))!('$D(ICDOP(" 03.39"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.4")) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.53"))!('$D(ICDOP(" 03.59"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.6")) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.93"))!('$D(ICDOP(" 03.94"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 03.97"))!('$D(ICDOP(" 03.98")))!('$D(ICDOP(" 03.99"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 80.50"))!('$D(ICDOP(" 80.53")))!('$D(ICDOP(" 80.54")))!('$D(ICDOP(" 80.59"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 84.59")) S ICDXFLG=1
  1. .I '$D(ICDOP(" 84.60"))!('$D(ICDOP(" 84.61")))!('$D(ICDOP(" 84.62")))!('$D(ICDOP(" 84.63")))!('$D(ICDOP(" 84.64"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 84.65"))!('$D(ICDOP(" 84.66")))!('$D(ICDOP(" 84.67")))!('$D(ICDOP(" 84.68")))!('$D(ICDOP(" 84.69"))) S ICDXFLG=1
  1. .I '$D(ICDOP(" 84.80"))!('$D(ICDOP(" 84.82")))!('$D(ICDOP(" 84.84"))) S ICDXFLG=1
  1. I $G(ICDXFLG)=0 D DRG456 Q
  1. I ICDOR["F" D DRG456 Q
  1. S ICDRG=$S(ICDMCC>0:490,1:491) D Q
  1. . I $D(ICDOP(" 84.59")) S ICDRG=490
  1. . I $D(ICDOP(" 84.62")) S ICDRG=490
  1. . I $D(ICDOP(" 84.65")) S ICDRG=490
  1. . I $D(ICDOP(" 84.80")) S ICDRG=490
  1. . I $D(ICDOP(" 84.82")) S ICDRG=490
  1. . I $D(ICDOP(" 84.84")) S ICDRG=490
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.94")) S ICDRG=490
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.95")) S ICDRG=490
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.97")) S ICDRG=490
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.98")) S ICDRG=490
  1. DRG492 ;
  1. DRG493 ;
  1. DRG494 S ICDRG=$S(ICDMCC=2:492,ICDMCC=1:493,1:494) Q
  1. DRG495 ;
  1. DRG496 ;
  1. DRG497 N ICDOPRFLG
  1. S ICDOPRFLG=0
  1. I $D(ICDOP(" 80.05")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 80.06")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.22")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.60")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.63")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.65")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.66")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.67")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.69")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.70")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.71")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.72")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.74")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.75")) S ICDOPRFLG=1
  1. I $D(ICDOP(" 86.93")) S ICDOPRFLG=1
  1. I $G(ICDOPRFLG)=1 D DRG465 Q
  1. S ICDRG=$S(ICDMCC=2:495,ICDMCC=1:496,1:497) Q
  1. DRG498 ;
  1. DRG499 S ICDRG=$S(ICDMCC>0:498,1:499) Q
  1. Q