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

ICD15PT.m

Go to the documentation of this file. 
  1. ICD15PT ;ABR/ALB - POST-INIT FOR DRG 15 ; 5 JAN 1998
  1.  ;;15.0;DRG Grouper;;Feb 23, 1998
  1.  ;
  1.  ;  This routine updates the FY entries in the DRG file (#80.2) to
  1.  ;  make them Y2K compatible.  All 2-digit FYs have been changed to the 
  1.  ;  FileMan 3-digit entry (e.g. '91' becomes '291')
  1.  ;
  1.  ;  The Break-even nodes were similarly corrected, with the 3-digit
  1.  ;  FY preceding the 1-4 quarter indicator.
  1.  ;  E.g. - '871' becomes '2871' for 1st quarter, 1987.
  1.  ;
  1.  ;  Reference routines are added for the new DRGs that were added
  1.  ;  to the DRG file as part of patch ICD*14*2 - DRGs 496-503.
  1.  ;
  1.  ;  BEGST adds the 1995 and 1996
  1.  ;  Weights & Trims to the DRG file.
  1.  ;
  1.  ;  This routine may be re-run.
  1.  ;
  1. EN ; POST-INSTALL ENTRY POINT
  1.  D DRGREF
  1.  D DRGFIELD ; delete starred field 8 from DRG file
  1.  D FYUPD
  1.  D BEGWT
  1.  D BMES^XPDUTL("*** Please restore your ICD9 and ICD0 global files from ***")
  1.  D MES^XPDUTL("*** ICD9_15.GBL and ICD0_15.GBL at this time.   ***")
  1.  Q
  1. DRGREF ; add routine reference to new DRGs
  1.  N DRG
  1.  F DRG=496:1:503 S ^ICD(DRG,"MC1")="ICDTLB6"
  1.  Q
  1. DRGFIELD ; delete starred field from DRG file
  1.  N DIK,DA,I
  1.  D BMES^XPDUTL(">>> Deleting obsolete MUMPS CODE field from DRG file.")
  1.  S DIK="^DD(80.2,",DA=8,DA(1)=80.2
  1.  D ^DIK
  1.  ;  kill old data from deleted field
  1.  D BMES^XPDUTL(">>> Deleting data from obsolete MUMPS CODE field")
  1.  F I=0:0 S I=$O(^ICD(I)) Q:'I  K ^ICD(I,"MC")
  1.  Q
  1. FYUPD ; change FY for weights & trims, break-evens to FM format
  1.  S U="^"
  1.  N DRG,FY
  1.  D BMES^XPDUTL(">> Updating FY nodes for Year 2000 compatibility.")
  1.  F DRG=0:0 S DRG=$O(^ICD(DRG)) Q:'DRG  D
  1.  . I $D(^ICD(DRG,"FY")) D WTUP(DRG) ; update wts/trims nodes
  1.  . I $D(^ICD(DRG,"BE")) D BEUP(DRG) ; update break-even nodes
  1.  F FY=0:0 S FY=$O(^ICD("AFY",FY)) Q:'FY!(FY>500)  D
  1.  . N X,Y,%DT S X=FY D ^%DT
  1.  . S ^ICD("AFY",Y)="" K ^(FY)
  1.  Q
  1. WTUP(DRG) ; change wts/trims FY to FM FY references
  1.  N FY,FMFY
  1.  F FY=0:0 S FY=$O(^ICD(DRG,"FY",FY)) Q:'FY!(FY>500)  D
  1.  . S FMFY=$S(FY>500:FY,1:(FY+200)_"0000")
  1.  . S ^ICD(DRG,"FY",FMFY,0)=FMFY_U_$P(^ICD(DRG,"FY",FY,0),U,2,99)
  1.  . I FY'=FMFY K ^ICD(DRG,"FY",FY)
  1.  S:$G(FMFY) $P(^ICD(DRG,"FY",0),U,3)=FMFY
  1.  Q
  1. BEUP(DRG) ;change break-even FY to FM FY references
  1.  N BE,FMBE
  1.  F BE=0:0 S BE=$O(^ICD(DRG,"BE",BE)) Q:'BE!(BE>10000)  D
  1.  . S FMBE=$S(BE>10000:BE,1:BE+19000)
  1.  . S X=$G(^ICD(DRG,"BE",BE,0)) I X]"" S ^ICD(DRG,"BE",FMBE,0)=FMBE_U_$P(X,U,2,99)
  1.  . I $D(^ICD(DRG,"BE",BE,"S")) D SERVICE
  1.  . I BE'=FMBE K ^ICD(DRG,"BE",BE)
  1.  S:$G(FMBE) $P(^ICD(DRG,"BE",0),U,3)=FMBE
  1.  Q
  1. SERVICE ; update services for break-evens
  1.  N SVC,X
  1.  S X=$G(^ICD(DRG,"BE",BE,"S",0)) I X]"" S ^ICD(DRG,"BE",FMBE,"S",0)=X
  1.  I $O(^ICD(DRG,"BE",BE,"S",0)) F SVC=1:1:5 S X=$G(^ICD(DRG,"BE",BE,"S",SVC,0)) I X S ^ICD(DRG,"BE",FMBE,"S",SVC,0)=X
  1.  Q
  1.  ;
  1. BEGWT ;  entry point for wts & trims update for 95
  1.  N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
  1.  D UPD95
  1.  D UPD96
  1.  Q
  1. UPD95 ;  load fy 95 wwu into ICD DRG file (80.2)
  1.  S FYR=2950000
  1.  D MES^XPDUTL(">> Adding FY 95 Weights & Trims.")
  1.  F I=1:1 S WT=$P($T(WW95+I^ICD15P95),";;",2,99) Q:'WT  D SETVAR,FY
  1.  F I=1:1 S WT=$P($T(WW95+I^ICD1595A),";;",2,99) Q:'WT  D SETVAR,FY
  1.  S ^ICD("AFY",2950000)=""
  1.  Q
  1. UPD96 ;  load fy 96 wwu into ICD DRG file (80.2)
  1.  S FYR=2960000
  1.  D MES^XPDUTL(">> Adding FY 96 Weights & Trims.")
  1.  F I=1:1 S WT=$P($T(WW96+I^ICD15P96),";;",2,99) Q:'WT  D SETVAR,FY,MORE
  1.  F I=1:1 S WT=$P($T(WW96+I^ICD1596A),";;",2,99) Q:'WT  D SETVAR,FY,MORE
  1.  S ^ICD("AFY",2960000)=""
  1.  Q
  1. FY ;set fy multiple with FYR stats
  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.22^"_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. SETVAR ; SET VARIABLES
  1.  S DRG=+WT,ICDLOW=$P(WT,U,2),ICDLOS=$P(WT,U,3),ICDHIGH=$P(WT,U,4),ICDWWU=$P(WT,U,5)
  1.  Q
  1. MORE ;set 0 node with FY 96 stats
  1.  S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
  1.  D FY
  1.  Q