ICD1882O ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
;;18.0;DRG Grouper;**82**;Oct 20, 2000;Build 21
;
; Inactivating DRG(s) - will add an entry for fiscal year
; DRG is being inactivated with an inactive status.
Q
;
;
INACTDRG ;
N LINE,ICDX,ICDDRG,DESC,DA,DIE,DR,MDC,SURG,ICDFDA
D BMES^XPDUTL(">>> Inactivating DRG(s)...")
F LINE=1:1 S ICDX=$T(INAC+LINE) S ICDDRG=$P(ICDX,";;",2) Q:ICDDRG="EXIT" D
.S DESC="NO LONGER VALID"
.S DA(LINE)=$P(ICDDRG,U)
.S DA=1
.S DIE="^ICD("_DA(LINE)_",1,"
.S DR=".01///^S X=DESC"
.D ^DIE
.; check if already done in case patch being re-installed
.Q:$D(^ICD($P(ICDDRG,U),66,"B",3151001))
.; add entry to 80.266
.S MDC=$P(ICDDRG,U,2)
.S SURG=$P(ICDDRG,U,3)
.S ICDDRG=$P(ICDDRG,U)
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.266,"+2,?1,",.01)=3151001
.S ICDFDA(80.266,"+2,?1,",.03)=0
.S ICDFDA(80.266,"+2,?1,",.05)=MDC
.S ICDFDA(80.266,"+2,?1,",.06)=SURG
.D UPDATE^DIE("","ICDFDA") K ICDFDA
.; add entry to 80.268 and 80.2681
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.268,"+2,?1,",.01)=3151001
.D UPDATE^DIE("","ICDFDA") K ICDFDA
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.2681,"?2,?1,",.01)=3151001
.S ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
.D UPDATE^DIE("","ICDFDA") K ICDFDA
;
;
INAC ;DRG^MDC^SURG (1=surg, 0=med)
;;237^8^1
;;238^8^1
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1882O 1361 printed Nov 22, 2024@16:59:29 Page 2
ICD1882O ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
+1 ;;18.0;DRG Grouper;**82**;Oct 20, 2000;Build 21
+2 ;
+3 ; Inactivating DRG(s) - will add an entry for fiscal year
+4 ; DRG is being inactivated with an inactive status.
+5 QUIT
+6 ;
+7 ;
INACTDRG ;
+1 NEW LINE,ICDX,ICDDRG,DESC,DA,DIE,DR,MDC,SURG,ICDFDA
+2 DO BMES^XPDUTL(">>> Inactivating DRG(s)...")
+3 FOR LINE=1:1
SET ICDX=$TEXT(INAC+LINE)
SET ICDDRG=$PIECE(ICDX,";;",2)
if ICDDRG="EXIT"
QUIT
Begin DoDot:1
+4 SET DESC="NO LONGER VALID"
+5 SET DA(LINE)=$PIECE(ICDDRG,U)
+6 SET DA=1
+7 SET DIE="^ICD("_DA(LINE)_",1,"
+8 SET DR=".01///^S X=DESC"
+9 DO ^DIE
+10 ; check if already done in case patch being re-installed
+11 if $DATA(^ICD($PIECE(ICDDRG,U),66,"B",3151001))
QUIT
+12 ; add entry to 80.266
+13 SET MDC=$PIECE(ICDDRG,U,2)
+14 SET SURG=$PIECE(ICDDRG,U,3)
+15 SET ICDDRG=$PIECE(ICDDRG,U)
+16 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+17 SET ICDFDA(80.266,"+2,?1,",.01)=3151001
+18 SET ICDFDA(80.266,"+2,?1,",.03)=0
+19 SET ICDFDA(80.266,"+2,?1,",.05)=MDC
+20 SET ICDFDA(80.266,"+2,?1,",.06)=SURG
+21 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+22 ; add entry to 80.268 and 80.2681
+23 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+24 SET ICDFDA(80.268,"+2,?1,",.01)=3151001
+25 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+26 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+27 SET ICDFDA(80.2681,"?2,?1,",.01)=3151001
+28 SET ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
+29 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+30 ;
+31 ;
INAC ;DRG^MDC^SURG (1=surg, 0=med)
+1 ;;237^8^1
+2 ;;238^8^1
+3 ;;EXIT
