- ICD115A ;ALB/DMR - YEARLY DRG UPDATE; October 01, 2020@15:42
- ;;18.0;DRG Grouper;**115**;October 20, 2000;Build 7
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;Update the (#80.2) DRG file with FY 2024 DRG Grouper MS-DRG codes.
- ;
- Q
- ;
- ;Routines ICD115* contain each FY 2024 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 2024 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("DRGFY2024",$J)) D
- . K @ICDTMP
- . S @ICDTMP@(0)="PATCH FY 2024 DRG UPDATE^"_$$NOW^XLFDT
- ;
- ;loop each sub-routine
- S ICDSUB="FGHIJK"
- F ICDI=1:1:6 S ICDRTN="^ICD115"_$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=3231001
- 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=3231001
- 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=3240000,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[HICD115A 11392 printed Dec 13, 2024@01:47:17 Page 2
- ICD115A ;ALB/DMR - YEARLY DRG UPDATE; October 01, 2020@15:42
- +1 ;;18.0;DRG Grouper;**115**;October 20, 2000;Build 7
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;Update the (#80.2) DRG file with FY 2024 DRG Grouper MS-DRG codes.
- +5 ;
- +6 QUIT
- +7 ;
- +8 ;Routines ICD115* contain each FY 2024 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 2024 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("DRGFY2024",$JOB))
- Begin DoDot:1
- +16 KILL @ICDTMP
- +17 SET @ICDTMP@(0)="PATCH FY 2024 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="^ICD115"_$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=3231001
- +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=3231001
- +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=3240000
- 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