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

ICD115A.m

Go to the documentation of this file.
  1. ICD115A ;ALB/DMR - YEARLY DRG UPDATE; October 01, 2020@15:42
  1. ;;18.0;DRG Grouper;**115**;October 20, 2000;Build 7
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;Update the (#80.2) DRG file with FY 2024 DRG Grouper MS-DRG codes.
  1. ;
  1. Q
  1. ;
  1. ;Routines ICD115* contain each FY 2024 MS-DRG code update values
  1. ;in a line of text delimited by up-arrow "^".
  1. ; $TEXT line field names
  1. ; MS-DRG^MDC^TYPE^MS-DRG TITLE^WEIGHTS^GEOMETRIC MEAN LOS
  1. ; routine MS-DRG codes
  1. ; ICD115F - 1 to 168
  1. ; ICD115G - 175 to 329
  1. ; ICD115H - 330 to 480
  1. ; ICD115I - 481 to 639
  1. ; ICD115J - 640 to 809
  1. ; ICD115K - 810 to 999
  1. ;
  1. ;The following nodes/fields will be updated or created:
  1. ; .001 NUMBER (same as DRG Number)
  1. ; 0 node - .01 NAME (composed of prefix "DRG"_Number... DRG579)
  1. ; 5 MDC#
  1. ; .06 SURGERY
  1. ; 1 node - #1 DESCRIPTION *** don't update existing records ***
  1. ; 80.21A, .01 DESCRIPTION Multiple
  1. ; 2 node - #71 DRG GROUPER EFFECIVE DATE
  1. ; 80.271D, .01 DRG GROUPER EFFECIVE DATE
  1. ; 1 REFERENCE - MUMPS Routine name
  1. ; 66 node - #66 EFFECTIVE DATE
  1. ; 80.266D, .01 EFFECTIVE DATE
  1. ; .03 STATUS
  1. ; .05 MDC#
  1. ; .06 SURGERY
  1. ; 68 node - #68 DESCRIPTION (VERSIONED)
  1. ; 80.268D, .01 EFFECTIVE DATE
  1. ; 1 DESCRIPTION
  1. ; 80.2681, .01 DESCRIPTION
  1. ; "FY" node - #20 FISCAL YEAR WEIGHTS&TRIM
  1. ; 80.22D, .01 FISCAL YEAR WEIGHTS&TRIMS
  1. ; 2 WEIGHT
  1. ; 3 LOW TRIM(days)
  1. ; 4 HIGH TRIM(days)
  1. ; 4.5 AVG LENGTH OF STAY(days)
  1. ;
  1. DRG ;post-install driver (#80.2) DRG updates
  1. ;This procedure calls a series of routines that contain the data
  1. ;element values used to create the FY 2024 MS-DRG updates.
  1. ; Input:
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ; Output:
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ;
  1. D BMES^XPDUTL(">>> Adding FY 2024 DRG Grouper updates to (#80.2) DRG file...")
  1. N ICDRTN,ICDI,ICDSUB,ICDEDIT,ICDADD,ICDTMP
  1. S (ICDEDIT,ICDADD)=0
  1. S ICDTOT=$G(ICDTOT) I ICDTOT']"" S ICDTOT=0
  1. S ICDTMP=$G(ICDTMP)
  1. I ICDTMP']"" S ICDTMP=$NA(^TMP("DRGFY2024",$J)) D
  1. . K @ICDTMP
  1. . S @ICDTMP@(0)="PATCH FY 2024 DRG UPDATE^"_$$NOW^XLFDT
  1. ;
  1. ;loop each sub-routine
  1. S ICDSUB="FGHIJK"
  1. F ICDI=1:1:6 S ICDRTN="^ICD115"_$E(ICDSUB,ICDI) D
  1. .Q:($T(@ICDRTN)="")
  1. .D GETDRG(ICDRTN,ICDTMP,.ICDTOT,.ICDEDIT,.ICDADD)
  1. ;
  1. I '$D(@ICDTMP@("ERROR")) D
  1. . D MES^XPDUTL(">>> DRG Updates Completed...")
  1. . D MES^XPDUTL(" ...Total Codes Edited: "_ICDEDIT)
  1. . D MES^XPDUTL(" ...Total Codes Added: "_ICDADD)
  1. . D MES^XPDUTL(" ................Total: "_ICDTOT)
  1. . D MES^XPDUTL("")
  1. Q
  1. ;
  1. GETDRG(ICDRTN,ICDTMP,ICDTOT,ICDEDIT,ICDADD) ;get and file MS-DRG data
  1. ; Input:
  1. ; ICDRTN - Post Install routine to process MS-DRG codes
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ; Output:
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ;
  1. N ICDLN,ICDLINE,ICDTAG,ICDDRG,ICDTEXT
  1. ;
  1. F ICDLN=1:1 S ICDTAG="MSDRG+"_ICDLN_ICDRTN,ICDTEXT=$T(@ICDTAG) S ICDLINE=$P(ICDTEXT,";;",2) Q:ICDLINE="EXIT" D
  1. . ; check if DRG exists or is a new one
  1. . I $D(^ICD(+$P(+ICDLINE,U),0)) D EDITDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDEDIT)
  1. . E D NEWDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDADD)
  1. Q
  1. ;
  1. EDITDRG(ICDLINE,ICDTMP,ICDTOT,ICDEDIT) ; edit existing (#80.2) DRG record
  1. ; Input:
  1. ; ICDLINE - $TEXT line of MS-DRG code data
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ; Output:
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ;
  1. N X,Y,DA,DIE,DR,ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF
  1. ;
  1. S ICDFY=3231001
  1. S ICDDRG=+$P(ICDLINE,U)
  1. S ICDDESC=$P(ICDLINE,U,4)
  1. I '$D(^ICD(ICDDRG,0)) D Q
  1. . S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
  1. ;
  1. ; check if already done in case patch being re-installed
  1. Q:$D(^ICD(ICDDRG,66,"B",ICDFY))
  1. ;
  1. ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
  1. ;S ICDREF="ICDTLB6E" ;*** REFERENCE routine not defined yet ???
  1. ;S ICDREF="" ;*** ECF commented out-see next line
  1. ;For FY09 and later the reference will have an alpha character at the end
  1. ;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
  1. ;ICDTLB** Was used before MS-DRG update(FY08)
  1. ;ICDTBL** will be used for MS-DRGs now
  1. ;ICD10TB* will be used for ICD10 MS-DRGs now
  1. ;S ICDYJG=+ICDDRG,ICDREF="ICD10TB"_$S(ICDYJG<100:0,ICDYJG>99&(ICDYJG<202):1,ICDYJG>201&(ICDYJG<302):2,ICDYJG>301&(ICDYJG<400):3,ICDYJG>399&(ICDYJG<500):4,ICDYJG>499&(ICDYJG<602):5,
  1. ;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
  1. D DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;removed 'ICDREF' FY 2017
  1. ;
  1. ;-- 80.266D subfile - #66 EFFECTIVE DATE
  1. S ICDMDC=$P(ICDLINE,U,2) S:ICDMDC="PRE" ICDMDC=98
  1. I ICDMDC]"" S ICDMDC=+ICDMDC
  1. S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:0)
  1. D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
  1. ;
  1. ;-- 80.268D subfile - #68 DESCRIPTION
  1. D DESCA(ICDDRG,ICDFY,ICDTMP)
  1. ;
  1. ;-- 80.2681 subfile - #68 DESCRIPTION
  1. D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
  1. ;
  1. ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
  1. D WEIGHTS(ICDLINE,ICDTMP)
  1. ;
  1. S ICDTOT=ICDTOT+1,ICDEDIT=ICDEDIT+1
  1. Q
  1. ;
  1. NEWDRG(ICDLINE,ICDTMP,ICDTOT,ICDADD) ; add new (#80.2) DRG record
  1. ; Input:
  1. ; ICDLINE - $TEXT line of MS-DRG code data
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ; Output:
  1. ; ICDTMP - Temp file of error msg's
  1. ; ICDTOT - Total MS-DRG codes filed
  1. ;
  1. N DA,DIC,DIE,DR,X,Y
  1. N ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF,ICDIEN
  1. S ICDFY=3231001
  1. S ICDDRG=+$P(ICDLINE,U)
  1. ; check for duplicates in case install is being rerun
  1. I $D(^ICD(ICDDRG,0)) Q
  1. ;
  1. S ICDMDC=$P(ICDLINE,U,2) I ICDMDC="PRE" S ICDMDC=98
  1. I ICDMDC]"" S ICDMDC=+ICDMDC
  1. S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:"")
  1. S ICDDESC=$P(ICDLINE,U,4)
  1. ;
  1. ;-- #.001 NUMBER and 0 node fields
  1. K ICDFDA,ICDIEN,ICDERR
  1. S ICDFDA(80.2,"+1,",.01)="DRG"_ICDDRG
  1. S ICDFDA(80.2,"+1,",5)=ICDMDC
  1. S ICDFDA(80.2,"+1,",.06)=ICDSURG
  1. S ICDIEN(1)=ICDDRG
  1. D UPDATE^DIE("","ICDFDA","ICDIEN","ICDERR") K ICDFDA,ICDIEN
  1. I $D(ICDERR) D K ICDERR ;*** quit here if can't setup IEN ???
  1. . S @ICDTMP@("ERROR",ICDDRG,.001)="FILING TO (#.001) NUMBER FIELD"
  1. ;
  1. ;-- 80.21A subfile - #1 DESCRIPTION
  1. K DIC,DA
  1. S DA(1)=ICDDRG
  1. S DIC="^ICD("_DA(1)_",1,"
  1. S DIC(0)="L"
  1. S X=ICDDESC
  1. K DO D FILE^DICN
  1. K DIC,DA
  1. I Y=-1 D
  1. . S @ICDTMP@("ERROR",ICDDRG,1)="FILING TO (#1) DESCRIPTION FIELD"
  1. ;
  1. ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
  1. ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
  1. ;S ICDREF="" ;ECF commented out - see next line
  1. ;S ICDREF="ICDTBL"_$S(ICDDRG<100:"0",1:$E(ICDDRG,1)) ;ECF new line
  1. ;D DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP)
  1. ;
  1. ; -- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
  1. ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
  1. ;S ICDREF="" ;*** ECF commented out-see next line
  1. ;For FY09 and later the reference will have an alpha character at the end
  1. ;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
  1. ;ICDTLB** Was used before MS-DRG update(FY08)
  1. ;ICDTBL** will be used for MS-DRGs now
  1. ;ICD10TB* will be used for ICD10 MS-DRGs now
  1. ;S ICDYJG=+ICDDRG,ICDREF="ICD10TB"_$S(ICDYJG<100:0,ICDYJG>99&(ICDYJG<202):1,ICDYJG>201&(ICDYJG<302):2,ICDYJG>301&(ICDYJG<400):3,ICDYJG>399&(ICDYJG<500):4,ICDYJG>499&(ICDYJG<602):5,
  1. ;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
  1. D DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;removed 'ICDREF' for FY 2017
  1. ;-- 80.266D subfile - #66 EFFECTIVE DATE
  1. I ICDSURG="" S ICDSURG=0
  1. D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
  1. ;
  1. ;-- 80.268D subfile - #68 DESCRIPTION
  1. D DESCA(ICDDRG,ICDFY,ICDTMP)
  1. ;
  1. ;-- 80.2681 subfile - #68 DESCRIPTION
  1. D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
  1. ;
  1. ;-- 80.22D subfile - update weights&trims/ALOS
  1. D WEIGHTS(ICDLINE,ICDTMP)
  1. ;
  1. S ICDTOT=ICDTOT+1,ICDADD=ICDADD+1
  1. Q
  1. ;
  1. DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;-- 80.271D - #71 DRG GROUPER EFFECIVE DATE (removed 'ICDREF' for FY 2017)
  1. I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"")!($D(^ICD(ICDDRG,2,"B",ICDFY))) Q
  1. K ICDFDA,ICDERR
  1. S ICDFDA(80.2,"?1,",.01)=ICDDRG
  1. ;S ICDFDA(80.271,"+2,?1,",.01)=ICDFY
  1. ;S ICDFDA(80.271,"+2,?1,",1)=ICDREF ;(removed 'ICDREF' for FY 2017)
  1. D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
  1. I $D(ICDERR) D K ICDERR
  1. . S @ICDTMP@("ERROR",ICDDRG,71)="FILING TO (#71) DRG GROUPER EFFECIVE DATE FIELD"
  1. Q
  1. ;
  1. EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP) ;-- 80.266D - #66 EFFECTIVE DATE
  1. I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
  1. K ICDFDA,ICDERR
  1. S ICDFDA(80.2,"?1,",.01)=ICDDRG
  1. S ICDFDA(80.266,"+2,?1,",.01)=ICDFY
  1. S ICDFDA(80.266,"+2,?1,",.03)=1
  1. S ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
  1. S ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
  1. D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
  1. I $D(ICDERR) D K ICDERR
  1. . S @ICDTMP@("ERROR",ICDDRG,66)="FILING TO (#66) EFFECTIVE DATE FIELD"
  1. Q
  1. ;
  1. DESCA(ICDDRG,ICDFY,ICDTMP) ;-- 80.268D - #68 DESCRIPTION
  1. I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
  1. K ICDFDA,ICDERR
  1. S ICDFDA(80.2,"?1,",.01)=ICDDRG
  1. S ICDFDA(80.268,"+2,?1,",.01)=ICDFY
  1. D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
  1. I $D(ICDERR) D K ICDERR
  1. . S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION FIELD"
  1. Q
  1. ;
  1. DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP) ;-- 80.2681 - #68 DESCRIPTION
  1. I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDDESC)']"")!($G(ICDTMP)']"") Q
  1. K ICDFDA,ICDERR
  1. S ICDFDA(80.2,"?1,",.01)=ICDDRG
  1. S ICDFDA(80.268,"?2,?1,",.01)=ICDFY
  1. S ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
  1. D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
  1. I $D(ICDERR) D K ICDERR
  1. . S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION SUB-FIELD"
  1. Q
  1. ;
  1. WEIGHTS(ICDLINE,ICDTMP) ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
  1. ; Input:
  1. ; ICDLINE - $TEXT line of MS-DRG code data
  1. ; ICDTMP - Temp file of error msg's
  1. ; Output:
  1. ; ICDTMP - Temp file of error msg's
  1. ;
  1. I $G(ICDLINE)'[""!($G(ICDTMP)'["") Q
  1. N ICDDRG,ICDWT,ICDLOS,ICDSTR,ICDX,ICDJ,ICDFYR,ICDLOW,ICDHIGH
  1. S ICDFYR=3240000,ICDLOW=1,ICDHIGH=99 ; *** default Low/High ???
  1. S ICDDRG=+$P(ICDLINE,U)
  1. I '$D(^ICD(ICDDRG,0)) D Q
  1. . S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
  1. ;
  1. ; check if being re-installed
  1. Q:$D(^ICD(ICDDRG,"FY",ICDFYR))
  1. ;
  1. I ICDDRG=998!(ICDDRG=999) S (ICDLOW,ICDHIGH)=0
  1. S ICDWT=$P(ICDLINE,U,5),ICDLOS=$P(ICDLINE,U,6)
  1. I ICDLOS["*" S ICDLOS=0
  1. S $P(ICDSTR,U)=ICDFYR,$P(ICDSTR,U,2)=ICDWT,$P(ICDSTR,U,3)=ICDLOW,$P(ICDSTR,U,4)=ICDHIGH,$P(ICDSTR,U,9)=ICDLOS
  1. ;
  1. S ^ICD(ICDDRG,"FY",ICDFYR,0)=ICDSTR
  1. ;
  1. I '$D(^ICD(ICDDRG,"FY",0)) S ^ICD(ICDDRG,"FY",0)="^80.22D^"_ICDFYR_"^1" Q
  1. E D
  1. . S ICDX=0 F ICDJ=0:1 S ICDX=$O(^ICD(ICDDRG,"FY",ICDX)) Q:ICDX=""
  1. . S $P(^ICD(ICDDRG,"FY",0),"^",3,4)=ICDFYR_"^"_ICDJ
  1. Q