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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRG14 850 printed Dec 13, 2024@01:50:13 Page 2
ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm
+1 ;;18.0;DRG Grouper;**14,31**;Oct 20, 2000;Build 7
+2 ;
+3 if ICDPD'["D"
GOTO POST
IF ICDOR["c"
Begin DoDot:1
+4 IF ICDDATE>3070930.9
SET ICDRG=766
+5 IF '$TEST
SET ICDRG=$SELECT(ICDCC:370,1:371)
End DoDot:1
QUIT
NOV IF ICDOR["s"!(ICDOR["g")
Begin DoDot:1
+1 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDOR["s":767,1:768)
+2 IF '$TEST
SET ICDRG=$SELECT(ICDOR["s":374,1:375)
End DoDot:1
QUIT
+3 ;
+4 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDSD["n"!(ICDPD["n"):774,1:775)
QUIT
+5 IF '$TEST
SET ICDRG=$SELECT(ICDSD["n"!(ICDPD["n"):372,1:373)
QUIT
+6 ;
POST NEW DRGFY,ICDREF
+1 SET (DRGFY,ICDREF)=""
+2 IF ICDPD["d"
SET ICDRG=$SELECT(ICDOR["O":377,1:376)
QUIT
+3 SET ICDRG=$ORDER(ICDRG(0))
IF ICDRG'>0
SET ICDRG=469
QUIT
+4 SET DRGFY=$ORDER(^ICD(ICDRG,2,"B",+ICDDATE),-1)
+5 SET ICDREF=$ORDER(^ICD(ICDRG,2,"B",$SELECT($GET(DRGFY):DRGFY,1:3041001),ICDREF))
+6 SET ICDREF=$PIECE($GET(^ICD(ICDRG,2,+ICDREF,0)),U,3)
+7 IF ICDREF'=""
SET ICDREF="DRG"_ICDRG_"^"_ICDREF
DO @ICDREF
KILL ICDREF
+8 QUIT
