ICD1824B ;ALB/ESD/JAT - FY 2007 UPDATE; 6/22/01 2:43pm ; 6/29/05 3:30pm
;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 7
; - UPD01: Update weights & ALOS for FY 2007 for all DRGs
; - UPD02: update 80.272 multiple with new table routines for FY 2007 for most DRGs
; - INACTDRG: inactivate certain DRGs
; - DRGTITLE: update title of certain DRGs
Q
;
UPDTDRG ;
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
N ICDREF,ICDDRG,ICDFDA,IEN
;D UPD01 - (waiting on CMS - must update each entry in ICD1824X,Y,Z
D UPD02
Q
;
;
UPD01 ;- Load FY 2007 weights & ALOS into DRG file (#80.2)
S FYR=3070000
D BMES^XPDUTL(">>> Adding FY 2007 Weights & ALOS to all DRGs...")
; check if already done in case patch being re-installed
Q:$D(^ICD(579,"FY",3070000,0))
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1824X),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1824Y),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1824Z),";;",2,99) Q:$E(WT,1,4)="EXIT" D SETVAR,FY,MORE
S ^ICD("AFY",3070000)=""
D MES^XPDUTL(">>> ...completed.")
D MES^XPDUTL("")
Q
;
;
FY ;- Set FY multiple with FYR stats
; check if already done in case patch being re-installed
I $D(^ICD(DRG,"FY",FYR,0)) Q
S $P(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",9)=ICDLOS
I '$D(^ICD(DRG,"FY",0)) S ^ICD(DRG,"FY",0)="^80.22D^"_FYR_"^1" Q
S ICDCNT="" F J=0:1 S ICDCNT=$O(^ICD(DRG,"FY",ICDCNT)) Q:ICDCNT=""
S $P(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J
Q
;
;
SETVAR ;- Set variables
S DRG=$P(WT,U),ICDLOW=1,ICDHIGH=99,ICDWWU=$P(WT,U,2),ICDLOS=$P(WT,U,3)
DRG S ICDLOW=$P(^ICD(DRG,"FY",3060000,0),U,3),ICDHIGH=$P(^ICD(DRG,"FY",3060000,0),U,4)
Q
;
;
MORE ;- Set zero node with FY 2007 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
Q
;
UPD02 ; create new entries for FY 2007 versioning
S DRG=0
F S DRG=$O(^ICD(DRG)) Q:'DRG D
.; check if already done in case patch being re-installed
.Q:$D(^ICD(DRG,2,"B",3061001))
.;one-time code because not done in FY2006
.I DRG<57&($D(^ICD(DRG,2,"B",3041001))) D
..S ICDREF="ICDTLB1B"
..S ICDFDA(80.2,"?1,",.01)="`"_DRG
..S ICDFDA(80.271,"+2,?1,",.01)=3051001
..S ICDFDA(80.271,"+2,?1,",1)=ICDREF
..D UPDATE^DIE("","ICDFDA") K ICDFDA
.;end of one-time code
.; it's also already done if DRG new this year
.Q:DRG>559&($D(^ICD(DRG,2)))
.S (ICDDRG,ICDREF)=""
.S ICDDRG=$P($G(^ICD(DRG,0)),U,1)
.;"A"= FY 2005 "B"=FY 2006 "C"=FY 2007, etc.
.S IEN=0,IEN=$O(^ICD(DRG,2,"B",3051001,IEN))
.I IEN S ICDREF=$P(^ICD(DRG,2,IEN,0),U,3),ICDREF=$E(ICDREF,1,7)_"C"
.;Create FY 2007 reference table entries used for FY 2007
.I ICDDRG'="",ICDREF'="" D
..S ICDFDA(80.2,"?1,",.01)="`"_DRG
..S ICDFDA(80.271,"+2,?1,",.01)=3061001
..S ICDFDA(80.271,"+2,?1,",1)=ICDREF
..D UPDATE^DIE("","ICDFDA")
Q
;
INACTDRG ;
N LINE,X,ICDDRG,DESC,DA,DIE,DR,MDC,SURG,ICDFDA
D BMES^XPDUTL(">>> Inactivating 8 DRGs...")
F LINE=1:1 S X=$T(INAC+LINE) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT" D
.S DESC="NO LONGER VALID"
.S DA(1)=$P(ICDDRG,U)
.S DA=1
.S DIE="^ICD("_DA(1)_",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",3061001))
.; 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)=3061001
.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)=3061001
.D UPDATE^DIE("","ICDFDA") K ICDFDA
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.268,"?2,?1,",.01)=3061001
.S ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
.D UPDATE^DIE("","ICDFDA") K ICDFDA
Q
;
INAC ;
;;20^1^
;;24^1^
;;25^1^
;;475^4^1
;;148^6^1
;;154^6^1
;;415^18^1
;;416^18^1
;;EXIT
DRGTITLE ; modify titles of DRGs
N LINE,X,ICDDRG,DESC,DA,DIE,DR,ICDFDA
F LINE=1:1 S X=$T(TITLE+LINE) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT" D
.S DESC=$P(ICDDRG,U,2)
.S DA(1)=$P(ICDDRG,U)
.S DA=1
.S DIE="^ICD("_DA(1)_",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),68,"B",3061001))
.; add entry to 80.268 and 80.2681
.S ICDDRG=$P(ICDDRG,U)
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.268,"+2,?1,",.01)=3061001
.D UPDATE^DIE("","ICDFDA") K ICDFDA
.S ICDFDA(80.2,"?1,",.01)=ICDDRG
.S ICDFDA(80.268,"?2,?1,",.01)=3061001
.S ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
.D UPDATE^DIE("","ICDFDA") K ICDFDA
Q
TITLE ;
;;303^KIDNEY AND URETER PROCEDURES FOR NEOPLASM
;;304^KIDNEY AND URETER PROCEDURES FOR NON-NEOPLASM WITH CC
;;305^KIDNEY AND URETER PROCEDURES FOR NON-NEOPLASM WITHOUT CC
;;543^CRANIOTOMY W/MAJOR DEVICE IMPLANT OR ACUTE COMPLEX CNS PDX
;;EXIT
ICD1824B ;ALB/ESD/JAT - FY 2007 UPDATE; 6/22/01 2:43pm ; 6/29/05 3:30pm
+1 ;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 7
+2 ; - UPD01: Update weights & ALOS for FY 2007 for all DRGs
+3 ; - UPD02: update 80.272 multiple with new table routines for FY 2007 for most DRGs
+4 ; - INACTDRG: inactivate certain DRGs
+5 ; - DRGTITLE: update title of certain DRGs
+6 QUIT
+7 ;
UPDTDRG ;
+1 NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
+2 NEW ICDREF,ICDDRG,ICDFDA,IEN
+3 ;D UPD01 - (waiting on CMS - must update each entry in ICD1824X,Y,Z
+4 DO UPD02
+5 QUIT
+6 ;
+7 ;
UPD01 ;- Load FY 2007 weights & ALOS into DRG file (#80.2)
+1 SET FYR=3070000
+2 DO BMES^XPDUTL(">>> Adding FY 2007 Weights & ALOS to all DRGs...")
+3 ; check if already done in case patch being re-installed
+4 IF $DATA(^ICD(579,"FY",3070000,0))
QUIT
+5 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1824X),";;",2,99)
IF I>200
QUIT
DO SETVAR
DO FY
DO MORE
+6 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1824Y),";;",2,99)
IF I>200
QUIT
DO SETVAR
DO FY
DO MORE
+7 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1824Z),";;",2,99)
IF $EXTRACT(WT,1,4)="EXIT"
QUIT
DO SETVAR
DO FY
DO MORE
+8 SET ^ICD("AFY",3070000)=""
+9 DO MES^XPDUTL(">>> ...completed.")
+10 DO MES^XPDUTL("")
+11 QUIT
+12 ;
+13 ;
FY ;- Set FY multiple with FYR stats
+1 ; check if already done in case patch being re-installed
+2 IF $DATA(^ICD(DRG,"FY",FYR,0))
QUIT
+3 SET $PIECE(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",9)=ICDLOS
+4 IF '$DATA(^ICD(DRG,"FY",0))
SET ^ICD(DRG,"FY",0)="^80.22D^"_FYR_"^1"
QUIT
+5 SET ICDCNT=""
FOR J=0:1
SET ICDCNT=$ORDER(^ICD(DRG,"FY",ICDCNT))
IF ICDCNT=""
QUIT
+6 SET $PIECE(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J
+7 QUIT
+8 ;
+9 ;
SETVAR ;- Set variables
+1 SET DRG=$PIECE(WT,U)
SET ICDLOW=1
SET ICDHIGH=99
SET ICDWWU=$PIECE(WT,U,2)
SET ICDLOS=$PIECE(WT,U,3)
DRG SET ICDLOW=$PIECE(^ICD(DRG,"FY",3060000,0),U,3)
SET ICDHIGH=$PIECE(^ICD(DRG,"FY",3060000,0),U,4)
+1 QUIT
+2 ;
+3 ;
MORE ;- Set zero node with FY 2007 stats
+1 SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",8)=ICDLOS
+2 QUIT
+3 ;
UPD02 ; create new entries for FY 2007 versioning
+1 SET DRG=0
+2 FOR
SET DRG=$ORDER(^ICD(DRG))
IF 'DRG
QUIT
Begin DoDot:1
+3 ; check if already done in case patch being re-installed
+4 IF $DATA(^ICD(DRG,2,"B",3061001))
QUIT
+5 ;one-time code because not done in FY2006
+6 IF DRG<57&($DATA(^ICD(DRG,2,"B",3041001)))
Begin DoDot:2
+7 SET ICDREF="ICDTLB1B"
+8 SET ICDFDA(80.2,"?1,",.01)="`"_DRG
+9 SET ICDFDA(80.271,"+2,?1,",.01)=3051001
+10 SET ICDFDA(80.271,"+2,?1,",1)=ICDREF
+11 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:2
+12 ;end of one-time code
+13 ; it's also already done if DRG new this year
+14 IF DRG>559&($DATA(^ICD(DRG,2)))
QUIT
+15 SET (ICDDRG,ICDREF)=""
+16 SET ICDDRG=$PIECE($GET(^ICD(DRG,0)),U,1)
+17 ;"A"= FY 2005 "B"=FY 2006 "C"=FY 2007, etc.
+18 SET IEN=0
SET IEN=$ORDER(^ICD(DRG,2,"B",3051001,IEN))
+19 IF IEN
SET ICDREF=$PIECE(^ICD(DRG,2,IEN,0),U,3)
SET ICDREF=$EXTRACT(ICDREF,1,7)_"C"
+20 ;Create FY 2007 reference table entries used for FY 2007
+21 IF ICDDRG'=""
IF ICDREF'=""
Begin DoDot:2
+22 SET ICDFDA(80.2,"?1,",.01)="`"_DRG
+23 SET ICDFDA(80.271,"+2,?1,",.01)=3061001
+24 SET ICDFDA(80.271,"+2,?1,",1)=ICDREF
+25 DO UPDATE^DIE("","ICDFDA")
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
INACTDRG ;
+1 NEW LINE,X,ICDDRG,DESC,DA,DIE,DR,MDC,SURG,ICDFDA
+2 DO BMES^XPDUTL(">>> Inactivating 8 DRGs...")
+3 FOR LINE=1:1
SET X=$TEXT(INAC+LINE)
SET ICDDRG=$PIECE(X,";;",2)
IF ICDDRG="EXIT"
QUIT
Begin DoDot:1
+4 SET DESC="NO LONGER VALID"
+5 SET DA(1)=$PIECE(ICDDRG,U)
+6 SET DA=1
+7 SET DIE="^ICD("_DA(1)_",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",3061001))
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)=3061001
+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)=3061001
+25 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+26 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+27 SET ICDFDA(80.268,"?2,?1,",.01)=3061001
+28 SET ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
+29 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+30 QUIT
+31 ;
INAC ;
+1 ;;20^1^
+2 ;;24^1^
+3 ;;25^1^
+4 ;;475^4^1
+5 ;;148^6^1
+6 ;;154^6^1
+7 ;;415^18^1
+8 ;;416^18^1
+9 ;;EXIT
DRGTITLE ; modify titles of DRGs
+1 NEW LINE,X,ICDDRG,DESC,DA,DIE,DR,ICDFDA
+2 FOR LINE=1:1
SET X=$TEXT(TITLE+LINE)
SET ICDDRG=$PIECE(X,";;",2)
IF ICDDRG="EXIT"
QUIT
Begin DoDot:1
+3 SET DESC=$PIECE(ICDDRG,U,2)
+4 SET DA(1)=$PIECE(ICDDRG,U)
+5 SET DA=1
+6 SET DIE="^ICD("_DA(1)_",1,"
+7 SET DR=".01///^S X=DESC"
+8 DO ^DIE
+9 ; check if already done in case patch being re-installed
+10 IF $DATA(^ICD($PIECE(ICDDRG,U),68,"B",3061001))
QUIT
+11 ; add entry to 80.268 and 80.2681
+12 SET ICDDRG=$PIECE(ICDDRG,U)
+13 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+14 SET ICDFDA(80.268,"+2,?1,",.01)=3061001
+15 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+16 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+17 SET ICDFDA(80.268,"?2,?1,",.01)=3061001
+18 SET ICDFDA(80.2681,"+3,?2,?1,",.01)=DESC
+19 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+20 QUIT
TITLE ;
+1 ;;303^KIDNEY AND URETER PROCEDURES FOR NEOPLASM
+2 ;;304^KIDNEY AND URETER PROCEDURES FOR NON-NEOPLASM WITH CC
+3 ;;305^KIDNEY AND URETER PROCEDURES FOR NON-NEOPLASM WITHOUT CC
+4 ;;543^CRANIOTOMY W/MAJOR DEVICE IMPLANT OR ACUTE COMPLEX CNS PDX
+5 ;;EXIT
