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