ICD1893O ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
;;18.0;DRG Grouper;**93**;Oct 20, 2000;Build 6
;
; Inactivating DRG(s) - will add an entry for fiscal year 2018
; DRG is being inactivated with an inactive status.
Q
;
;
INACTDRG ;
N ICDLINE,ICDX,ICDDRG,ICDDESC,DA,DIE,DR,ICDMDC,ICDSURG,ICDFDA
D BMES^XPDUTL(">>> Inactivating DRG(s) for FY 2018...")
F ICDLINE=1:1 S ICDX=$T(INAC+ICDLINE) S ICDDRG=$P(ICDX,";;",2) Q:ICDDRG="EXIT" D
.S ICDDESC="NO LONGER VALID"
.S DA(ICDLINE)=$P(ICDDRG,U)
.S DA=1
.S DIE="^ICD("_DA(ICDLINE)_",1,"
.S DR=".01///^S X=ICDDESC"
.D ^DIE
.; check if already done in case patch being re-installed
.Q:$D(^ICD($P(ICDDRG,U),66,"B",3171001))
.; add entry to 80.266
.S ICDMDC=$P(ICDDRG,U,2)
.S ICDSURG=$P(ICDDRG,U,3)
.S ICDDRG=$P(ICDDRG,U)
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.266,"+2,?1,",.01)=3171001
.S ICDFDA(80.266,"+2,?1,",.03)=0
.S ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
.S ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
.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)=3171001
.D UPDATE^DIE("","ICDFDA") K ICDFDA
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.2681,"?2,?1,",.01)=3171001
.S ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
.D UPDATE^DIE("","ICDFDA") K ICDFDA
;
;
INAC ;DRG^MDC^SURG (1=surg, 0=med)
;;984^99^1
;;985^99^1
;;986^99^1
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1893O 1437 printed Nov 22, 2024@16:59:47 Page 2
ICD1893O ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
+1 ;;18.0;DRG Grouper;**93**;Oct 20, 2000;Build 6
+2 ;
+3 ; Inactivating DRG(s) - will add an entry for fiscal year 2018
+4 ; DRG is being inactivated with an inactive status.
+5 QUIT
+6 ;
+7 ;
INACTDRG ;
+1 NEW ICDLINE,ICDX,ICDDRG,ICDDESC,DA,DIE,DR,ICDMDC,ICDSURG,ICDFDA
+2 DO BMES^XPDUTL(">>> Inactivating DRG(s) for FY 2018...")
+3 FOR ICDLINE=1:1
SET ICDX=$TEXT(INAC+ICDLINE)
SET ICDDRG=$PIECE(ICDX,";;",2)
if ICDDRG="EXIT"
QUIT
Begin DoDot:1
+4 SET ICDDESC="NO LONGER VALID"
+5 SET DA(ICDLINE)=$PIECE(ICDDRG,U)
+6 SET DA=1
+7 SET DIE="^ICD("_DA(ICDLINE)_",1,"
+8 SET DR=".01///^S X=ICDDESC"
+9 DO ^DIE
+10 ; check if already done in case patch being re-installed
+11 if $DATA(^ICD($PIECE(ICDDRG,U),66,"B",3171001))
QUIT
+12 ; add entry to 80.266
+13 SET ICDMDC=$PIECE(ICDDRG,U,2)
+14 SET ICDSURG=$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)=3171001
+18 SET ICDFDA(80.266,"+2,?1,",.03)=0
+19 SET ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
+20 SET ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
+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)=3171001
+25 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+26 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+27 SET ICDFDA(80.2681,"?2,?1,",.01)=3171001
+28 SET ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
+29 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+30 ;
+31 ;
INAC ;DRG^MDC^SURG (1=surg, 0=med)
+1 ;;984^99^1
+2 ;;985^99^1
+3 ;;986^99^1
+4 ;;EXIT
