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

ICD1824B.m

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