ICD120A ;ALB/RFS - YEARLY DRG UPDATE; August 15, 2024@15:09
;;18.0;DRG Grouper;**120**;October 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
;Update the (#80.2) DRG file with FY 2025 DRG Grouper MS-DRG codes.
;
Q
;
;Routines ICD120* contain each FY 2025 MS-DRG code update values
;in a line of text delimited by up-arrow "^".
; $TEXT line field names
; MS-DRG^MDC^TYPE^MS-DRG TITLE^WEIGHTS^GEOMETRIC MEAN LOS
; routine MS-DRG codes
; ICD115F - 1 to 168
; ICD115G - 175 to 329
; ICD115H - 330 to 480
; ICD115I - 481 to 639
; ICD115J - 640 to 809
; ICD115K - 810 to 999
;
;The following nodes/fields will be updated or created:
; .001 NUMBER (same as DRG Number)
; 0 node - .01 NAME (composed of prefix "DRG"_Number... DRG579)
; 5 MDC#
; .06 SURGERY
; 1 node - #1 DESCRIPTION *** don't update existing records ***
; 80.21A, .01 DESCRIPTION Multiple
; 2 node - #71 DRG GROUPER EFFECIVE DATE
; 80.271D, .01 DRG GROUPER EFFECIVE DATE
; 1 REFERENCE - MUMPS Routine name
; 66 node - #66 EFFECTIVE DATE
; 80.266D, .01 EFFECTIVE DATE
; .03 STATUS
; .05 MDC#
; .06 SURGERY
; 68 node - #68 DESCRIPTION (VERSIONED)
; 80.268D, .01 EFFECTIVE DATE
; 1 DESCRIPTION
; 80.2681, .01 DESCRIPTION
; "FY" node - #20 FISCAL YEAR WEIGHTS&TRIM
; 80.22D, .01 FISCAL YEAR WEIGHTS&TRIMS
; 2 WEIGHT
; 3 LOW TRIM(days)
; 4 HIGH TRIM(days)
; 4.5 AVG LENGTH OF STAY(days)
;
DRG ;post-install driver (#80.2) DRG updates
;This procedure calls a series of routines that contain the data
;element values used to create the FY 2024 MS-DRG updates.
; Input:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
; Output:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
;
D BMES^XPDUTL(">>> Adding FY 2025 DRG Grouper updates to (#80.2) DRG file...")
N ICDRTN,ICDI,ICDSUB,ICDEDIT,ICDADD,ICDTMP
S (ICDEDIT,ICDADD)=0
S ICDTOT=$G(ICDTOT) I ICDTOT']"" S ICDTOT=0
S ICDTMP=$G(ICDTMP)
I ICDTMP']"" S ICDTMP=$NA(^TMP("DRGFY2025",$J)) D
. K @ICDTMP
. S @ICDTMP@(0)="PATCH FY 2025 DRG UPDATE^"_$$NOW^XLFDT
;
;loop each sub-routine
S ICDSUB="FGHIJK"
F ICDI=1:1:6 S ICDRTN="^ICD120"_$E(ICDSUB,ICDI) D
.Q:($T(@ICDRTN)="")
.D GETDRG(ICDRTN,ICDTMP,.ICDTOT,.ICDEDIT,.ICDADD)
;
I '$D(@ICDTMP@("ERROR")) D
. D MES^XPDUTL(">>> DRG Updates Completed...")
. D MES^XPDUTL(" ...Total Codes Edited: "_ICDEDIT)
. D MES^XPDUTL(" ...Total Codes Added: "_ICDADD)
. D MES^XPDUTL(" ................Total: "_ICDTOT)
. D MES^XPDUTL("")
Q
;
GETDRG(ICDRTN,ICDTMP,ICDTOT,ICDEDIT,ICDADD) ;get and file MS-DRG data
; Input:
; ICDRTN - Post Install routine to process MS-DRG codes
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
; Output:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
;
N ICDLN,ICDLINE,ICDTAG,ICDDRG,ICDTEXT
;
F ICDLN=1:1 S ICDTAG="MSDRG+"_ICDLN_ICDRTN,ICDTEXT=$T(@ICDTAG) S ICDLINE=$P(ICDTEXT,";;",2) Q:ICDLINE="EXIT" D
. ; check if DRG exists or is a new one
. I $D(^ICD(+$P(+ICDLINE,U),0)) D EDITDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDEDIT)
. E D NEWDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDADD)
Q
;
EDITDRG(ICDLINE,ICDTMP,ICDTOT,ICDEDIT) ; edit existing (#80.2) DRG record
; Input:
; ICDLINE - $TEXT line of MS-DRG code data
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
; Output:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
;
N X,Y,DA,DIE,DR,ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF
;
S ICDFY=3241001
S ICDDRG=+$P(ICDLINE,U)
S ICDDESC=$P(ICDLINE,U,4)
I '$D(^ICD(ICDDRG,0)) D Q
. S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
;
; check if already done in case patch being re-installed
Q:$D(^ICD(ICDDRG,66,"B",ICDFY))
;
;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
;S ICDREF="ICDTLB6E" ;*** REFERENCE routine not defined yet ???
;S ICDREF="" ;*** ECF commented out-see next line
;For FY09 and later the reference will have an alpha character at the end
;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
;ICDTLB** Was used before MS-DRG update(FY08)
;ICDTBL** will be used for MS-DRGs now
;ICD10TB* will be used for ICD10 MS-DRGs now
;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,
;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
D DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;removed 'ICDREF' FY 2017
;
;-- 80.266D subfile - #66 EFFECTIVE DATE
S ICDMDC=$P(ICDLINE,U,2) S:ICDMDC="PRE" ICDMDC=98
I ICDMDC]"" S ICDMDC=+ICDMDC
S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:0)
D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
;
;-- 80.268D subfile - #68 DESCRIPTION
D DESCA(ICDDRG,ICDFY,ICDTMP)
;
;-- 80.2681 subfile - #68 DESCRIPTION
D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
;
;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
D WEIGHTS(ICDLINE,ICDTMP)
;
S ICDTOT=ICDTOT+1,ICDEDIT=ICDEDIT+1
Q
;
NEWDRG(ICDLINE,ICDTMP,ICDTOT,ICDADD) ; add new (#80.2) DRG record
; Input:
; ICDLINE - $TEXT line of MS-DRG code data
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
; Output:
; ICDTMP - Temp file of error msg's
; ICDTOT - Total MS-DRG codes filed
;
N DA,DIC,DIE,DR,X,Y
N ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF,ICDIEN
S ICDFY=3241001
S ICDDRG=+$P(ICDLINE,U)
; check for duplicates in case install is being rerun
I $D(^ICD(ICDDRG,0)) Q
;
S ICDMDC=$P(ICDLINE,U,2) I ICDMDC="PRE" S ICDMDC=98
I ICDMDC]"" S ICDMDC=+ICDMDC
S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:"")
S ICDDESC=$P(ICDLINE,U,4)
;
;-- #.001 NUMBER and 0 node fields
K ICDFDA,ICDIEN,ICDERR
S ICDFDA(80.2,"+1,",.01)="DRG"_ICDDRG
S ICDFDA(80.2,"+1,",5)=ICDMDC
S ICDFDA(80.2,"+1,",.06)=ICDSURG
S ICDIEN(1)=ICDDRG
D UPDATE^DIE("","ICDFDA","ICDIEN","ICDERR") K ICDFDA,ICDIEN
I $D(ICDERR) D K ICDERR ;*** quit here if can't setup IEN ???
. S @ICDTMP@("ERROR",ICDDRG,.001)="FILING TO (#.001) NUMBER FIELD"
;
;-- 80.21A subfile - #1 DESCRIPTION
K DIC,DA
S DA(1)=ICDDRG
S DIC="^ICD("_DA(1)_",1,"
S DIC(0)="L"
S X=ICDDESC
K DO D FILE^DICN
K DIC,DA
I Y=-1 D
. S @ICDTMP@("ERROR",ICDDRG,1)="FILING TO (#1) DESCRIPTION FIELD"
;
;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
;S ICDREF="" ;ECF commented out - see next line
;S ICDREF="ICDTBL"_$S(ICDDRG<100:"0",1:$E(ICDDRG,1)) ;ECF new line
;D DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP)
;
; -- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
;S ICDREF="" ;*** ECF commented out-see next line
;For FY09 and later the reference will have an alpha character at the end
;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
;ICDTLB** Was used before MS-DRG update(FY08)
;ICDTBL** will be used for MS-DRGs now
;ICD10TB* will be used for ICD10 MS-DRGs now
;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,
;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
D DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;removed 'ICDREF' for FY 2017
;-- 80.266D subfile - #66 EFFECTIVE DATE
I ICDSURG="" S ICDSURG=0
D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
;
;-- 80.268D subfile - #68 DESCRIPTION
D DESCA(ICDDRG,ICDFY,ICDTMP)
;
;-- 80.2681 subfile - #68 DESCRIPTION
D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
;
;-- 80.22D subfile - update weights&trims/ALOS
D WEIGHTS(ICDLINE,ICDTMP)
;
S ICDTOT=ICDTOT+1,ICDADD=ICDADD+1
Q
;
DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;-- 80.271D - #71 DRG GROUPER EFFECIVE DATE (removed 'ICDREF' for FY 2017)
I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"")!($D(^ICD(ICDDRG,2,"B",ICDFY))) Q
K ICDFDA,ICDERR
S ICDFDA(80.2,"?1,",.01)=ICDDRG
;S ICDFDA(80.271,"+2,?1,",.01)=ICDFY
;S ICDFDA(80.271,"+2,?1,",1)=ICDREF ;(removed 'ICDREF' for FY 2017)
D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
I $D(ICDERR) D K ICDERR
. S @ICDTMP@("ERROR",ICDDRG,71)="FILING TO (#71) DRG GROUPER EFFECIVE DATE FIELD"
Q
;
EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP) ;-- 80.266D - #66 EFFECTIVE DATE
I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
K ICDFDA,ICDERR
S ICDFDA(80.2,"?1,",.01)=ICDDRG
S ICDFDA(80.266,"+2,?1,",.01)=ICDFY
S ICDFDA(80.266,"+2,?1,",.03)=1
S ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
S ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
I $D(ICDERR) D K ICDERR
. S @ICDTMP@("ERROR",ICDDRG,66)="FILING TO (#66) EFFECTIVE DATE FIELD"
Q
;
DESCA(ICDDRG,ICDFY,ICDTMP) ;-- 80.268D - #68 DESCRIPTION
I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
K ICDFDA,ICDERR
S ICDFDA(80.2,"?1,",.01)=ICDDRG
S ICDFDA(80.268,"+2,?1,",.01)=ICDFY
D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
I $D(ICDERR) D K ICDERR
. S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION FIELD"
Q
;
DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP) ;-- 80.2681 - #68 DESCRIPTION
I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDDESC)']"")!($G(ICDTMP)']"") Q
K ICDFDA,ICDERR
S ICDFDA(80.2,"?1,",.01)=ICDDRG
S ICDFDA(80.268,"?2,?1,",.01)=ICDFY
S ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
I $D(ICDERR) D K ICDERR
. S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION SUB-FIELD"
Q
;
WEIGHTS(ICDLINE,ICDTMP) ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
; Input:
; ICDLINE - $TEXT line of MS-DRG code data
; ICDTMP - Temp file of error msg's
; Output:
; ICDTMP - Temp file of error msg's
;
I $G(ICDLINE)'[""!($G(ICDTMP)'["") Q
N ICDDRG,ICDWT,ICDLOS,ICDSTR,ICDX,ICDJ,ICDFYR,ICDLOW,ICDHIGH
S ICDFYR=3250000,ICDLOW=1,ICDHIGH=99 ; *** default Low/High ???
S ICDDRG=+$P(ICDLINE,U)
I '$D(^ICD(ICDDRG,0)) D Q
. S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
;
; check if being re-installed
Q:$D(^ICD(ICDDRG,"FY",ICDFYR))
;
I ICDDRG=998!(ICDDRG=999) S (ICDLOW,ICDHIGH)=0
S ICDWT=$P(ICDLINE,U,5),ICDLOS=$P(ICDLINE,U,6)
I ICDLOS["*" S ICDLOS=0
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
;
S ^ICD(ICDDRG,"FY",ICDFYR,0)=ICDSTR
;
I '$D(^ICD(ICDDRG,"FY",0)) S ^ICD(ICDDRG,"FY",0)="^80.22D^"_ICDFYR_"^1" Q
E D
. S ICDX=0 F ICDJ=0:1 S ICDX=$O(^ICD(ICDDRG,"FY",ICDX)) Q:ICDX=""
. S $P(^ICD(ICDDRG,"FY",0),"^",3,4)=ICDFYR_"^"_ICDJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD120A 11391 printed Dec 13, 2024@01:47:26 Page 2
ICD120A ;ALB/RFS - YEARLY DRG UPDATE; August 15, 2024@15:09
+1 ;;18.0;DRG Grouper;**120**;October 20, 2000;Build 4
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Update the (#80.2) DRG file with FY 2025 DRG Grouper MS-DRG codes.
+5 ;
+6 QUIT
+7 ;
+8 ;Routines ICD120* contain each FY 2025 MS-DRG code update values
+9 ;in a line of text delimited by up-arrow "^".
+10 ; $TEXT line field names
+11 ; MS-DRG^MDC^TYPE^MS-DRG TITLE^WEIGHTS^GEOMETRIC MEAN LOS
+12 ; routine MS-DRG codes
+13 ; ICD115F - 1 to 168
+14 ; ICD115G - 175 to 329
+15 ; ICD115H - 330 to 480
+16 ; ICD115I - 481 to 639
+17 ; ICD115J - 640 to 809
+18 ; ICD115K - 810 to 999
+19 ;
+20 ;The following nodes/fields will be updated or created:
+21 ; .001 NUMBER (same as DRG Number)
+22 ; 0 node - .01 NAME (composed of prefix "DRG"_Number... DRG579)
+23 ; 5 MDC#
+24 ; .06 SURGERY
+25 ; 1 node - #1 DESCRIPTION *** don't update existing records ***
+26 ; 80.21A, .01 DESCRIPTION Multiple
+27 ; 2 node - #71 DRG GROUPER EFFECIVE DATE
+28 ; 80.271D, .01 DRG GROUPER EFFECIVE DATE
+29 ; 1 REFERENCE - MUMPS Routine name
+30 ; 66 node - #66 EFFECTIVE DATE
+31 ; 80.266D, .01 EFFECTIVE DATE
+32 ; .03 STATUS
+33 ; .05 MDC#
+34 ; .06 SURGERY
+35 ; 68 node - #68 DESCRIPTION (VERSIONED)
+36 ; 80.268D, .01 EFFECTIVE DATE
+37 ; 1 DESCRIPTION
+38 ; 80.2681, .01 DESCRIPTION
+39 ; "FY" node - #20 FISCAL YEAR WEIGHTS&TRIM
+40 ; 80.22D, .01 FISCAL YEAR WEIGHTS&TRIMS
+41 ; 2 WEIGHT
+42 ; 3 LOW TRIM(days)
+43 ; 4 HIGH TRIM(days)
+44 ; 4.5 AVG LENGTH OF STAY(days)
+45 ;
DRG ;post-install driver (#80.2) DRG updates
+1 ;This procedure calls a series of routines that contain the data
+2 ;element values used to create the FY 2024 MS-DRG updates.
+3 ; Input:
+4 ; ICDTMP - Temp file of error msg's
+5 ; ICDTOT - Total MS-DRG codes filed
+6 ; Output:
+7 ; ICDTMP - Temp file of error msg's
+8 ; ICDTOT - Total MS-DRG codes filed
+9 ;
+10 DO BMES^XPDUTL(">>> Adding FY 2025 DRG Grouper updates to (#80.2) DRG file...")
+11 NEW ICDRTN,ICDI,ICDSUB,ICDEDIT,ICDADD,ICDTMP
+12 SET (ICDEDIT,ICDADD)=0
+13 SET ICDTOT=$GET(ICDTOT)
IF ICDTOT']""
SET ICDTOT=0
+14 SET ICDTMP=$GET(ICDTMP)
+15 IF ICDTMP']""
SET ICDTMP=$NAME(^TMP("DRGFY2025",$JOB))
Begin DoDot:1
+16 KILL @ICDTMP
+17 SET @ICDTMP@(0)="PATCH FY 2025 DRG UPDATE^"_$$NOW^XLFDT
End DoDot:1
+18 ;
+19 ;loop each sub-routine
+20 SET ICDSUB="FGHIJK"
+21 FOR ICDI=1:1:6
SET ICDRTN="^ICD120"_$EXTRACT(ICDSUB,ICDI)
Begin DoDot:1
+22 if ($TEXT(@ICDRTN)="")
QUIT
+23 DO GETDRG(ICDRTN,ICDTMP,.ICDTOT,.ICDEDIT,.ICDADD)
End DoDot:1
+24 ;
+25 IF '$DATA(@ICDTMP@("ERROR"))
Begin DoDot:1
+26 DO MES^XPDUTL(">>> DRG Updates Completed...")
+27 DO MES^XPDUTL(" ...Total Codes Edited: "_ICDEDIT)
+28 DO MES^XPDUTL(" ...Total Codes Added: "_ICDADD)
+29 DO MES^XPDUTL(" ................Total: "_ICDTOT)
+30 DO MES^XPDUTL("")
End DoDot:1
+31 QUIT
+32 ;
GETDRG(ICDRTN,ICDTMP,ICDTOT,ICDEDIT,ICDADD) ;get and file MS-DRG data
+1 ; Input:
+2 ; ICDRTN - Post Install routine to process MS-DRG codes
+3 ; ICDTMP - Temp file of error msg's
+4 ; ICDTOT - Total MS-DRG codes filed
+5 ; Output:
+6 ; ICDTMP - Temp file of error msg's
+7 ; ICDTOT - Total MS-DRG codes filed
+8 ;
+9 NEW ICDLN,ICDLINE,ICDTAG,ICDDRG,ICDTEXT
+10 ;
+11 FOR ICDLN=1:1
SET ICDTAG="MSDRG+"_ICDLN_ICDRTN
SET ICDTEXT=$TEXT(@ICDTAG)
SET ICDLINE=$PIECE(ICDTEXT,";;",2)
if ICDLINE="EXIT"
QUIT
Begin DoDot:1
+12 ; check if DRG exists or is a new one
+13 IF $DATA(^ICD(+$PIECE(+ICDLINE,U),0))
DO EDITDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDEDIT)
+14 IF '$TEST
DO NEWDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDADD)
End DoDot:1
+15 QUIT
+16 ;
EDITDRG(ICDLINE,ICDTMP,ICDTOT,ICDEDIT) ; edit existing (#80.2) DRG record
+1 ; Input:
+2 ; ICDLINE - $TEXT line of MS-DRG code data
+3 ; ICDTMP - Temp file of error msg's
+4 ; ICDTOT - Total MS-DRG codes filed
+5 ; Output:
+6 ; ICDTMP - Temp file of error msg's
+7 ; ICDTOT - Total MS-DRG codes filed
+8 ;
+9 NEW X,Y,DA,DIE,DR,ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF
+10 ;
+11 SET ICDFY=3241001
+12 SET ICDDRG=+$PIECE(ICDLINE,U)
+13 SET ICDDESC=$PIECE(ICDLINE,U,4)
+14 IF '$DATA(^ICD(ICDDRG,0))
Begin DoDot:1
+15 SET @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
End DoDot:1
QUIT
+16 ;
+17 ; check if already done in case patch being re-installed
+18 if $DATA(^ICD(ICDDRG,66,"B",ICDFY))
QUIT
+19 ;
+20 ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
+21 ;S ICDREF="ICDTLB6E" ;*** REFERENCE routine not defined yet ???
+22 ;S ICDREF="" ;*** ECF commented out-see next line
+23 ;For FY09 and later the reference will have an alpha character at the end
+24 ;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
+25 ;ICDTLB** Was used before MS-DRG update(FY08)
+26 ;ICDTBL** will be used for MS-DRGs now
+27 ;ICD10TB* will be used for ICD10 MS-DRGs now
+28 ;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,
+29 ;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
+30 ;removed 'ICDREF' FY 2017
DO DRGEFFDT(ICDDRG,ICDFY,ICDTMP)
+31 ;
+32 ;-- 80.266D subfile - #66 EFFECTIVE DATE
+33 SET ICDMDC=$PIECE(ICDLINE,U,2)
if ICDMDC="PRE"
SET ICDMDC=98
+34 IF ICDMDC]""
SET ICDMDC=+ICDMDC
+35 SET ICDSURG=$PIECE(ICDLINE,U,3)
SET ICDSURG=$SELECT(ICDSURG="SURG":1,1:0)
+36 DO EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
+37 ;
+38 ;-- 80.268D subfile - #68 DESCRIPTION
+39 DO DESCA(ICDDRG,ICDFY,ICDTMP)
+40 ;
+41 ;-- 80.2681 subfile - #68 DESCRIPTION
+42 DO DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
+43 ;
+44 ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
+45 DO WEIGHTS(ICDLINE,ICDTMP)
+46 ;
+47 SET ICDTOT=ICDTOT+1
SET ICDEDIT=ICDEDIT+1
+48 QUIT
+49 ;
NEWDRG(ICDLINE,ICDTMP,ICDTOT,ICDADD) ; add new (#80.2) DRG record
+1 ; Input:
+2 ; ICDLINE - $TEXT line of MS-DRG code data
+3 ; ICDTMP - Temp file of error msg's
+4 ; ICDTOT - Total MS-DRG codes filed
+5 ; Output:
+6 ; ICDTMP - Temp file of error msg's
+7 ; ICDTOT - Total MS-DRG codes filed
+8 ;
+9 NEW DA,DIC,DIE,DR,X,Y
+10 NEW ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF,ICDIEN
+11 SET ICDFY=3241001
+12 SET ICDDRG=+$PIECE(ICDLINE,U)
+13 ; check for duplicates in case install is being rerun
+14 IF $DATA(^ICD(ICDDRG,0))
QUIT
+15 ;
+16 SET ICDMDC=$PIECE(ICDLINE,U,2)
IF ICDMDC="PRE"
SET ICDMDC=98
+17 IF ICDMDC]""
SET ICDMDC=+ICDMDC
+18 SET ICDSURG=$PIECE(ICDLINE,U,3)
SET ICDSURG=$SELECT(ICDSURG="SURG":1,1:"")
+19 SET ICDDESC=$PIECE(ICDLINE,U,4)
+20 ;
+21 ;-- #.001 NUMBER and 0 node fields
+22 KILL ICDFDA,ICDIEN,ICDERR
+23 SET ICDFDA(80.2,"+1,",.01)="DRG"_ICDDRG
+24 SET ICDFDA(80.2,"+1,",5)=ICDMDC
+25 SET ICDFDA(80.2,"+1,",.06)=ICDSURG
+26 SET ICDIEN(1)=ICDDRG
+27 DO UPDATE^DIE("","ICDFDA","ICDIEN","ICDERR")
KILL ICDFDA,ICDIEN
+28 ;*** quit here if can't setup IEN ???
IF $DATA(ICDERR)
Begin DoDot:1
+29 SET @ICDTMP@("ERROR",ICDDRG,.001)="FILING TO (#.001) NUMBER FIELD"
End DoDot:1
KILL ICDERR
+30 ;
+31 ;-- 80.21A subfile - #1 DESCRIPTION
+32 KILL DIC,DA
+33 SET DA(1)=ICDDRG
+34 SET DIC="^ICD("_DA(1)_",1,"
+35 SET DIC(0)="L"
+36 SET X=ICDDESC
+37 KILL DO
DO FILE^DICN
+38 KILL DIC,DA
+39 IF Y=-1
Begin DoDot:1
+40 SET @ICDTMP@("ERROR",ICDDRG,1)="FILING TO (#1) DESCRIPTION FIELD"
End DoDot:1
+41 ;
+42 ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
+43 ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
+44 ;S ICDREF="" ;ECF commented out - see next line
+45 ;S ICDREF="ICDTBL"_$S(ICDDRG<100:"0",1:$E(ICDDRG,1)) ;ECF new line
+46 ;D DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP)
+47 ;
+48 ; -- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
+49 ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
+50 ;S ICDREF="" ;*** ECF commented out-see next line
+51 ;For FY09 and later the reference will have an alpha character at the end
+52 ;For FY09 "A" will be used - ex-ICDTBL0A, For FY10 "B" will be used, etc.
+53 ;ICDTLB** Was used before MS-DRG update(FY08)
+54 ;ICDTBL** will be used for MS-DRGs now
+55 ;ICD10TB* will be used for ICD10 MS-DRGs now
+56 ;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,
+57 ;ICDYJG>601&(ICDYJG<701):6,ICDYJG>700&(ICDYJG<802):7,ICDYJG>801&(ICDYJG<901):8,1:9) ;ECF new line
+58 ;removed 'ICDREF' for FY 2017
DO DRGEFFDT(ICDDRG,ICDFY,ICDTMP)
+59 ;-- 80.266D subfile - #66 EFFECTIVE DATE
+60 IF ICDSURG=""
SET ICDSURG=0
+61 DO EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
+62 ;
+63 ;-- 80.268D subfile - #68 DESCRIPTION
+64 DO DESCA(ICDDRG,ICDFY,ICDTMP)
+65 ;
+66 ;-- 80.2681 subfile - #68 DESCRIPTION
+67 DO DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
+68 ;
+69 ;-- 80.22D subfile - update weights&trims/ALOS
+70 DO WEIGHTS(ICDLINE,ICDTMP)
+71 ;
+72 SET ICDTOT=ICDTOT+1
SET ICDADD=ICDADD+1
+73 QUIT
+74 ;
DRGEFFDT(ICDDRG,ICDFY,ICDTMP) ;-- 80.271D - #71 DRG GROUPER EFFECIVE DATE (removed 'ICDREF' for FY 2017)
+1 IF '$GET(ICDDRG)!'$GET(ICDFY)!($GET(ICDTMP)']"")!($DATA(^ICD(ICDDRG,2,"B",ICDFY)))
QUIT
+2 KILL ICDFDA,ICDERR
+3 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+4 ;S ICDFDA(80.271,"+2,?1,",.01)=ICDFY
+5 ;S ICDFDA(80.271,"+2,?1,",1)=ICDREF ;(removed 'ICDREF' for FY 2017)
+6 DO UPDATE^DIE("","ICDFDA","","ICDERR")
KILL ICDFDA
+7 IF $DATA(ICDERR)
Begin DoDot:1
+8 SET @ICDTMP@("ERROR",ICDDRG,71)="FILING TO (#71) DRG GROUPER EFFECIVE DATE FIELD"
End DoDot:1
KILL ICDERR
+9 QUIT
+10 ;
EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP) ;-- 80.266D - #66 EFFECTIVE DATE
+1 IF '$GET(ICDDRG)!'$GET(ICDFY)!($GET(ICDTMP)']"")
QUIT
+2 KILL ICDFDA,ICDERR
+3 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+4 SET ICDFDA(80.266,"+2,?1,",.01)=ICDFY
+5 SET ICDFDA(80.266,"+2,?1,",.03)=1
+6 SET ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
+7 SET ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
+8 DO UPDATE^DIE("","ICDFDA","","ICDERR")
KILL ICDFDA
+9 IF $DATA(ICDERR)
Begin DoDot:1
+10 SET @ICDTMP@("ERROR",ICDDRG,66)="FILING TO (#66) EFFECTIVE DATE FIELD"
End DoDot:1
KILL ICDERR
+11 QUIT
+12 ;
DESCA(ICDDRG,ICDFY,ICDTMP) ;-- 80.268D - #68 DESCRIPTION
+1 IF '$GET(ICDDRG)!'$GET(ICDFY)!($GET(ICDTMP)']"")
QUIT
+2 KILL ICDFDA,ICDERR
+3 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+4 SET ICDFDA(80.268,"+2,?1,",.01)=ICDFY
+5 DO UPDATE^DIE("","ICDFDA","","ICDERR")
KILL ICDFDA
+6 IF $DATA(ICDERR)
Begin DoDot:1
+7 SET @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION FIELD"
End DoDot:1
KILL ICDERR
+8 QUIT
+9 ;
DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP) ;-- 80.2681 - #68 DESCRIPTION
+1 IF '$GET(ICDDRG)!'$GET(ICDFY)!($GET(ICDDESC)']"")!($GET(ICDTMP)']"")
QUIT
+2 KILL ICDFDA,ICDERR
+3 SET ICDFDA(80.2,"?1,",.01)=ICDDRG
+4 SET ICDFDA(80.268,"?2,?1,",.01)=ICDFY
+5 SET ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
+6 DO UPDATE^DIE("","ICDFDA","","ICDERR")
KILL ICDFDA
+7 IF $DATA(ICDERR)
Begin DoDot:1
+8 SET @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION SUB-FIELD"
End DoDot:1
KILL ICDERR
+9 QUIT
+10 ;
WEIGHTS(ICDLINE,ICDTMP) ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
+1 ; Input:
+2 ; ICDLINE - $TEXT line of MS-DRG code data
+3 ; ICDTMP - Temp file of error msg's
+4 ; Output:
+5 ; ICDTMP - Temp file of error msg's
+6 ;
+7 IF $GET(ICDLINE)'[""!($GET(ICDTMP)'["")
QUIT
+8 NEW ICDDRG,ICDWT,ICDLOS,ICDSTR,ICDX,ICDJ,ICDFYR,ICDLOW,ICDHIGH
+9 ; *** default Low/High ???
SET ICDFYR=3250000
SET ICDLOW=1
SET ICDHIGH=99
+10 SET ICDDRG=+$PIECE(ICDLINE,U)
+11 IF '$DATA(^ICD(ICDDRG,0))
Begin DoDot:1
+12 SET @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
End DoDot:1
QUIT
+13 ;
+14 ; check if being re-installed
+15 if $DATA(^ICD(ICDDRG,"FY",ICDFYR))
QUIT
+16 ;
+17 IF ICDDRG=998!(ICDDRG=999)
SET (ICDLOW,ICDHIGH)=0
+18 SET ICDWT=$PIECE(ICDLINE,U,5)
SET ICDLOS=$PIECE(ICDLINE,U,6)
+19 IF ICDLOS["*"
SET ICDLOS=0
+20 SET $PIECE(ICDSTR,U)=ICDFYR
SET $PIECE(ICDSTR,U,2)=ICDWT
SET $PIECE(ICDSTR,U,3)=ICDLOW
SET $PIECE(ICDSTR,U,4)=ICDHIGH
SET $PIECE(ICDSTR,U,9)=ICDLOS
+21 ;
+22 SET ^ICD(ICDDRG,"FY",ICDFYR,0)=ICDSTR
+23 ;
+24 IF '$DATA(^ICD(ICDDRG,"FY",0))
SET ^ICD(ICDDRG,"FY",0)="^80.22D^"_ICDFYR_"^1"
QUIT
+25 IF '$TEST
Begin DoDot:1
+26 SET ICDX=0
FOR ICDJ=0:1
SET ICDX=$ORDER(^ICD(ICDDRG,"FY",ICDX))
if ICDX=""
QUIT
+27 SET $PIECE(^ICD(ICDDRG,"FY",0),"^",3,4)=ICDFYR_"^"_ICDJ
End DoDot:1
+28 QUIT
