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

ICDTBL6D.m

Go to the documentation of this file.
  1. ICDTBL6D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
  1. ;;18.0;DRG Grouper;**56,55,69,70,78**;Oct 20, 2000;Build 15
  1. DRG600 ;
  1. DRG601 S ICDRG=$S(ICDMCC>0:600,1:601) Q
  1. DRG602 ;
  1. DRG603 I ICDOR["x",ICDOR["O" D DRG983^ICDTBL9D Q
  1. S ICDRG=$S(ICDMCC=2:602,1:603) Q
  1. DRG604 ;
  1. DRG605 S ICDRG=$S(ICDMCC=2:604,1:605) Q
  1. DRG606 ;
  1. DRG607 S ICDRG=$S(ICDMCC=2:606,1:607) Q
  1. DRG614 ;
  1. DRG615 S ICDRG=$S(ICDMCC>0:614,1:615) Q
  1. DRG616 ;
  1. DRG617 ;
  1. DRG618 I ICDSD["z" S ICDRG=617 Q
  1. S ICDRG=$S(ICDMCC=2:616,ICDMCC=1:617,1:618) Q
  1. DRG619 ;
  1. DRG620 ;
  1. DRG621 I (ICDDX(1)=995!$D(ICDDXT("278.1"))) S ICDMCC=0
  1. I (ICDDX(1)=13154!$D(ICDDXT("278.00"))) S ICDMCC=0
  1. I (ICDDX(1)=13155!$D(ICDDXT("278.01"))) S ICDMCC=0
  1. S ICDRG=$S(ICDMCC=2:619,ICDMCC=1:620,1:621) Q
  1. DRG622 ;
  1. DRG623 ;
  1. DRG624 I ICDOR["A" D DRG617 Q
  1. S ICDRG=$S(ICDMCC=2:622,ICDMCC=1:623,1:624) Q
  1. DRG625 ;
  1. DRG626 ;
  1. DRG627 S ICDRG=$S(ICDMCC=2:625,ICDMCC=1:626,1:627) Q
  1. DRG628 ;
  1. DRG629 ;
  1. DRG630 S ICDRG=$S(ICDMCC=2:628,ICDMCC=1:629,1:630) Q
  1. DRG637 ;
  1. DRG638 ;
  1. DRG639 S ICDRG=$S(ICDMCC=2:637,ICDMCC=1:638,1:639) Q
  1. DRG640 ;
  1. DRG641 S ICDRG=$S(ICDMCC=2:640,1:641) Q
  1. DRG642 S ICDRG=642 Q
  1. DRG643 ;
  1. DRG644 ;
  1. DRG645 S ICDRG=$S(ICDMCC=2:643,ICDMCC=1:644,1:645) Q
  1. DRG652 S ICDRG=652 Q
  1. DRG653 ;
  1. DRG654 ;
  1. DRG655 S ICDRG=$S(ICDMCC=2:653,ICDMCC=1:654,1:655) Q
  1. DRG656 ;DRGs 656-661
  1. S ICDRG=999
  1. I ICDOR'["O" D DRG686 Q
  1. S ICDRG=$S(ICDPD["M"&(ICDMCC=2):656,ICDPD["M"&(ICDMCC=1):657,ICDPD["M":658,1:ICDRG)
  1. I "656^657^658"[ICDRG Q
  1. S ICDRG=$S(ICDRG'["M"&(ICDMCC=2):659,ICDPD'["M"&(ICDMCC=1):660,1:661)
  1. Q
  1. DRG657 D DRG656 Q
  1. DRG658 D DRG656 Q
  1. DRG659 D DRG656 Q
  1. DRG660 D DRG656 Q
  1. DRG661 D DRG656 Q
  1. DRG662 ;
  1. DRG663 ;
  1. DRG664 I ICDOR["f" S ICDRG=$S($D(ICDJJ(664)):664,1:ICDRG) Q
  1. S ICDRG=$S(ICDMCC=2:662,ICDMCC=1:663,1:664) Q
  1. DRG665 ;
  1. DRG666 ;
  1. DRG667 ;
  1. I $D(ICDODRG(662))!($D(ICDODRG(663))) D DRG662 Q
  1. I ICDOR["f"!(ICDOR'["y") D DRG662 Q
  1. S ICDRG=$S(ICDMCC=2:665,ICDMCC=1:666,1:667) Q
  1. DRG668 ;
  1. DRG669 ;
  1. DRG670 S ICDRG=$S(ICDMCC=2:668,ICDMCC=1:669,1:670) Q
  1. DRG671 ;
  1. DRG672 S ICDRG=$S(ICDMCC>0:671,1:672) Q
  1. DRG673 ;
  1. DRG674 ;
  1. DRG675 I ICDDX(1)=12434,$D(ICDDXT("585.6")),ICDOR["O",ICDMCC=0 S ICDMCC=2
  1. S ICDRG=$S(ICDMCC=2:673,ICDMCC=1:674,1:675) Q
  1. DRG682 ;
  1. DRG683 ;
  1. DRG684 I ICDDX(1)=12434,$D(ICDDXT("585.6")),ICDMCC=0 S ICDMCC=2
  1. S ICDRG=$S(ICDMCC=2:682,ICDMCC=1:683,1:684) Q
  1. DRG685 S ICDRG=685 Q
  1. DRG686 ;
  1. DRG687 ;
  1. DRG688 S ICDRG=$S(ICDMCC=2:686,ICDMCC=1:687,1:688) Q
  1. DRG689 ;
  1. DRG690 S ICDRG=$S(ICDMCC=2:689,1:690) Q
  1. DRG691 ;DRGs 691-694
  1. S ICDRG=999
  1. S ICDRG=$S('$D(ICDPDRG(691)):"",$D(ICDOP(" 98.51"))&(ICDMCC>0):691,$D(ICDOP(" 98.51")):692,1:ICDRG)
  1. I "691^692"[ICDRG Q
  1. S ICDRG=$S('$D(ICDPDRG(691)):"",ICDMCC=2:693,1:694)
  1. Q
  1. DRG692 D DRG691 Q
  1. DRG693 D DRG691 Q
  1. DRG694 D DRG691 Q
  1. DRG695 ;
  1. DRG696 S ICDRG=$S(ICDMCC=2:695,1:696) Q
  1. DRG697 S ICDRG=697 Q
  1. DRG698 ;
  1. DRG699 S ICDRG=$S(ICDMCC=2:698,ICDMCC=1:699,1:700) Q
  1. Q