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

ICDDRG14.m

Go to the documentation of this file.
ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm
 ;;18.0;DRG Grouper;**14,31**;Oct 20, 2000;Build 7
 ;
 G POST:ICDPD'["D" I ICDOR["c" D  Q
 . I ICDDATE>3070930.9 S ICDRG=766
 . E  S ICDRG=$S(ICDCC:370,1:371)
NOV I ICDOR["s"!(ICDOR["g") D  Q
 . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["s":767,1:768)
 . E  S ICDRG=$S(ICDOR["s":374,1:375)
 ;
 I ICDDATE>3070930.9 S ICDRG=$S(ICDSD["n"!(ICDPD["n"):774,1:775) Q
 E  S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q
 ;
POST N DRGFY,ICDREF
 S (DRGFY,ICDREF)=""
 I ICDPD["d" S ICDRG=$S(ICDOR["O":377,1:376) Q
 S ICDRG=$O(ICDRG(0)) I ICDRG'>0 S ICDRG=469 Q
 S DRGFY=$O(^ICD(ICDRG,2,"B",+ICDDATE),-1)
 S ICDREF=$O(^ICD(ICDRG,2,"B",$S($G(DRGFY):DRGFY,1:3041001),ICDREF))
 S ICDREF=$P($G(^ICD(ICDRG,2,+ICDREF,0)),U,3)
 I ICDREF'="" S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDREF K ICDREF
 Q