ICD1810A ;ALB/MRY - ICD/DRG; 9/4/03 2:43pm
;;18.0;DRG Grouper;**10**;Oct 13,2000
;
; Taken from ICD182P with the exception of updates released
; in ICD184P.
;
EN ;- Post-Install entry point
;
; - Add DRGs to new Diagnosis codes
D ADDDIAG^ICD1810P
;
; - Add DRGs to new Procedure codes
D ADDPROC^ICD1810P
;
; - Add new DRGs
D ADDDRG^ICD1810B ; taken from ICD185P1
S ^DD(80.2,0,"VR")="21.0"
;
;- Inactivate/revise DRGS
D DRGEDIT
;
;- DRG reclassification changes
D EN^ICD1810C ; taken from ICD185P4
;
;- Weights & trims for FY 2004
D BEGWT01
;
Q
;
DRGEDIT ;- Edit DRG records (Description change)
; Invalid DRGs in FY 04:
; DRG4: SPINAL PROCEDURES
; DRG5: EXTRACRANIAL VASCULAR PROCEDURES
; DRG231: LOCAL EXCISION & REMOVAL OF INT FIX DEVICES EXCEPT HIP & FEMUR
; DRG400: LYMPHOMA & LEUKEMIA W MAJOR O.R. PROCEDURE
; DRG514: CARDIAC DEFIBRILLATOR IMPLANT W/CARDIAC CATH
;
N CNT,CNTI,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y
S (CNT,CNTI)=0
D BMES^XPDUTL(">>> Revising DRG records in the DRG file (#80.2)...")
F I=1:1 S DRG=$P($T(REVDRG+I),";;",2) Q:DRG="QUIT" D
. S DIC="^ICD(",DIC(0)="MX"
. S X=$P(DRG,"^")
. D ^DIC
. I +Y>0 D
.. S ICDESC=""
.. F S ICDESC=$O(^ICD(+Y,1,"B",ICDESC)) Q:ICDESC="" S ICDIEN=+$O(^(ICDESC,0))
.. S (ICDI,DA(1))=+Y,DA=ICDIEN
.. S DIE=DIC_DA(1)_","_DA_","
.. S DR=".01///^S X=$P(DRG,""^"",2)"
.. D ^DIE
.. D
... I $P(DRG,"^",3)="" Q
... S DIE=DIC
... S DA=ICDI
... S DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"
... D ^DIE
.. S CNT=CNT+1
.. D MES^XPDUTL(" Edited: "_$P(DRG,"^")_" to "_$P(DRG,"^",2))
.. I $P(DRG,"^",5) D
... I $D(^ICD(ICDI,66,"B",$P(DRG,"^",5))) Q
... S DIE="^ICD("
... S DA=ICDI
... S DR="15///"_$P(DRG,"^",6)_";16///"_$P(DRG,"^",5)
... D ^DIE
... K DIC("DR")
... S DA(1)=+ICDI,DIC=DIC_DA(1)_",66,"
... S DIC(0)="L",DIC("P")=$P(^DD(80.2,66,0),"^",2)
... S DIC("DR")=".03///"_$P(DRG,"^",7)
... S X=$P(DRG,"^",5)
... K DO D FILE^DICN
... I +Y=-1 Q
... S CNTI=CNTI+1
. E D ERRMSG($P(DRG,"^"))
;
;- Total DRG records revised
D MES^XPDUTL(">>> ...completed. "_CNT_" record(s) revised. "_CNTI_" record(s) made invalid.")
D MES^XPDUTL("")
Q
;
;
ERRMSG(VAR,IN) ;- Display error msg if DRG not found
;
Q:VAR=""
D BMES^XPDUTL(">>> ERROR: "_VAR_" was not found and could not be "_$S(+$G(IN):"inactivated.",1:"revised."))
D MES^XPDUTL("")
Q
;
BEGWT01 ;- Entry point for wts & trims update for 2004
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J,PFYR
D UPD01
Q
;
;
UPD01 ;- Load FY 2004 into ICD DRG file (#80.2)
S FYR=3040000
D BMES^XPDUTL(">>> Adding FY 2004 Weights & Trims...")
Q:$D(^ICD(540,"FY",3040000,0))
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1810X),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1810Y),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD1810Z),";;",2,99) Q:$E(WT,1,3)="END" D SETVAR,FY,MORE
S ^ICD("AFY",3040000)=""
D MES^XPDUTL(">>> ...completed.")
D MES^XPDUTL("")
Q
;
;
FY ;- Set FY multiple with FYR stats
S $P(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",9)=ICDLOS
I '$D(^ICD(DRG,"FY",0)) S ^ICD(DRG,"FY",0)="^80.22^"_FYR_"^1" Q
S ICDCNT="" F J=0:1 S ICDCNT=$O(^ICD(DRG,"FY",ICDCNT)) Q:ICDCNT=""
S $P(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J
Q
;
;
SETVAR ;- Set variables
S DRG=$P(WT,"^"),ICDLOW=1,ICDLOS=$P(WT,"^",3),ICDHIGH=".0",ICDWWU=$P(WT,"^",2)
DRG I $E(DRG,1)=0 S DRG=$E(DRG,2,3) G DRG
; if HIGH-TRIM is .0 use last year's FY03 value. If new DRG, use 99
I ICDHIGH["." D
.S ICDHIGH=$S(DRG>527:99,1:ICDHIGH) I ICDHIGH=99 Q
.I $D(^ICD(DRG,"FY",3030000,0)) S ICDHIGH=$P(^(0),"^",4)
I ICDWWU=0,ICDLOS=0 S (ICDLOW,ICDHIGH)=0
Q
;
;
MORE ;- Set zero node with FY 2004 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
Q
;
REVDRG ;- Description edits
;;DRG492^CHEMOTHERAPY W ACUTE LEUKEMIA OR W USE OF HIGH DOSE CHEMOTHERAPY AGENT
;;DRG4^NO LONGER VALID^^^3031001^1^0
;;DRG5^NO LONGER VALID^^^3031001^1^0
;;DRG231^NO LONGER VALID^^^3031001^1^0
;;DRG400^NO LONGER VALID^^^3031001^1^0
;;DRG514^NO LONGER VALID^^^3031001^1^0
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1810A 4305 printed Dec 13, 2024@01:48 Page 2
ICD1810A ;ALB/MRY - ICD/DRG; 9/4/03 2:43pm
+1 ;;18.0;DRG Grouper;**10**;Oct 13,2000
+2 ;
+3 ; Taken from ICD182P with the exception of updates released
+4 ; in ICD184P.
+5 ;
EN ;- Post-Install entry point
+1 ;
+2 ; - Add DRGs to new Diagnosis codes
+3 DO ADDDIAG^ICD1810P
+4 ;
+5 ; - Add DRGs to new Procedure codes
+6 DO ADDPROC^ICD1810P
+7 ;
+8 ; - Add new DRGs
+9 ; taken from ICD185P1
DO ADDDRG^ICD1810B
+10 SET ^DD(80.2,0,"VR")="21.0"
+11 ;
+12 ;- Inactivate/revise DRGS
+13 DO DRGEDIT
+14 ;
+15 ;- DRG reclassification changes
+16 ; taken from ICD185P4
DO EN^ICD1810C
+17 ;
+18 ;- Weights & trims for FY 2004
+19 DO BEGWT01
+20 ;
+21 QUIT
+22 ;
DRGEDIT ;- Edit DRG records (Description change)
+1 ; Invalid DRGs in FY 04:
+2 ; DRG4: SPINAL PROCEDURES
+3 ; DRG5: EXTRACRANIAL VASCULAR PROCEDURES
+4 ; DRG231: LOCAL EXCISION & REMOVAL OF INT FIX DEVICES EXCEPT HIP & FEMUR
+5 ; DRG400: LYMPHOMA & LEUKEMIA W MAJOR O.R. PROCEDURE
+6 ; DRG514: CARDIAC DEFIBRILLATOR IMPLANT W/CARDIAC CATH
+7 ;
+8 NEW CNT,CNTI,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y
+9 SET (CNT,CNTI)=0
+10 DO BMES^XPDUTL(">>> Revising DRG records in the DRG file (#80.2)...")
+11 FOR I=1:1
SET DRG=$PIECE($TEXT(REVDRG+I),";;",2)
if DRG="QUIT"
QUIT
Begin DoDot:1
+12 SET DIC="^ICD("
SET DIC(0)="MX"
+13 SET X=$PIECE(DRG,"^")
+14 DO ^DIC
+15 IF +Y>0
Begin DoDot:2
+16 SET ICDESC=""
+17 FOR
SET ICDESC=$ORDER(^ICD(+Y,1,"B",ICDESC))
if ICDESC=""
QUIT
SET ICDIEN=+$ORDER(^(ICDESC,0))
+18 SET (ICDI,DA(1))=+Y
SET DA=ICDIEN
+19 SET DIE=DIC_DA(1)_","_DA_","
+20 SET DR=".01///^S X=$P(DRG,""^"",2)"
+21 DO ^DIE
+22 Begin DoDot:3
+23 IF $PIECE(DRG,"^",3)=""
QUIT
+24 SET DIE=DIC
+25 SET DA=ICDI
+26 SET DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"
+27 DO ^DIE
End DoDot:3
+28 SET CNT=CNT+1
+29 DO MES^XPDUTL(" Edited: "_$PIECE(DRG,"^")_" to "_$PIECE(DRG,"^",2))
+30 IF $PIECE(DRG,"^",5)
Begin DoDot:3
+31 IF $DATA(^ICD(ICDI,66,"B",$PIECE(DRG,"^",5)))
QUIT
+32 SET DIE="^ICD("
+33 SET DA=ICDI
+34 SET DR="15///"_$PIECE(DRG,"^",6)_";16///"_$PIECE(DRG,"^",5)
+35 DO ^DIE
+36 KILL DIC("DR")
+37 SET DA(1)=+ICDI
SET DIC=DIC_DA(1)_",66,"
+38 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(80.2,66,0),"^",2)
+39 SET DIC("DR")=".03///"_$PIECE(DRG,"^",7)
+40 SET X=$PIECE(DRG,"^",5)
+41 KILL DO
DO FILE^DICN
+42 IF +Y=-1
QUIT
+43 SET CNTI=CNTI+1
End DoDot:3
End DoDot:2
+44 IF '$TEST
DO ERRMSG($PIECE(DRG,"^"))
End DoDot:1
+45 ;
+46 ;- Total DRG records revised
+47 DO MES^XPDUTL(">>> ...completed. "_CNT_" record(s) revised. "_CNTI_" record(s) made invalid.")
+48 DO MES^XPDUTL("")
+49 QUIT
+50 ;
+51 ;
ERRMSG(VAR,IN) ;- Display error msg if DRG not found
+1 ;
+2 if VAR=""
QUIT
+3 DO BMES^XPDUTL(">>> ERROR: "_VAR_" was not found and could not be "_$SELECT(+$GET(IN):"inactivated.",1:"revised."))
+4 DO MES^XPDUTL("")
+5 QUIT
+6 ;
BEGWT01 ;- Entry point for wts & trims update for 2004
+1 NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J,PFYR
+2 DO UPD01
+3 QUIT
+4 ;
+5 ;
UPD01 ;- Load FY 2004 into ICD DRG file (#80.2)
+1 SET FYR=3040000
+2 DO BMES^XPDUTL(">>> Adding FY 2004 Weights & Trims...")
+3 if $DATA(^ICD(540,"FY",3040000,0))
QUIT
+4 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1810X),";;",2,99)
if I>200
QUIT
DO SETVAR
DO FY
DO MORE
+5 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1810Y),";;",2,99)
if I>200
QUIT
DO SETVAR
DO FY
DO MORE
+6 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD1810Z),";;",2,99)
if $EXTRACT(WT,1,3)="END"
QUIT
DO SETVAR
DO FY
DO MORE
+7 SET ^ICD("AFY",3040000)=""
+8 DO MES^XPDUTL(">>> ...completed.")
+9 DO MES^XPDUTL("")
+10 QUIT
+11 ;
+12 ;
FY ;- Set FY multiple with FYR stats
+1 SET $PIECE(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",9)=ICDLOS
+2 IF '$DATA(^ICD(DRG,"FY",0))
SET ^ICD(DRG,"FY",0)="^80.22^"_FYR_"^1"
QUIT
+3 SET ICDCNT=""
FOR J=0:1
SET ICDCNT=$ORDER(^ICD(DRG,"FY",ICDCNT))
if ICDCNT=""
QUIT
+4 SET $PIECE(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J
+5 QUIT
+6 ;
+7 ;
SETVAR ;- Set variables
+1 SET DRG=$PIECE(WT,"^")
SET ICDLOW=1
SET ICDLOS=$PIECE(WT,"^",3)
SET ICDHIGH=".0"
SET ICDWWU=$PIECE(WT,"^",2)
DRG IF $EXTRACT(DRG,1)=0
SET DRG=$EXTRACT(DRG,2,3)
GOTO DRG
+1 ; if HIGH-TRIM is .0 use last year's FY03 value. If new DRG, use 99
+2 IF ICDHIGH["."
Begin DoDot:1
+3 SET ICDHIGH=$SELECT(DRG>527:99,1:ICDHIGH)
IF ICDHIGH=99
QUIT
+4 IF $DATA(^ICD(DRG,"FY",3030000,0))
SET ICDHIGH=$PIECE(^(0),"^",4)
End DoDot:1
+5 IF ICDWWU=0
IF ICDLOS=0
SET (ICDLOW,ICDHIGH)=0
+6 QUIT
+7 ;
+8 ;
MORE ;- Set zero node with FY 2004 stats
+1 SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",8)=ICDLOS
+2 QUIT
+3 ;
REVDRG ;- Description edits
+1 ;;DRG492^CHEMOTHERAPY W ACUTE LEUKEMIA OR W USE OF HIGH DOSE CHEMOTHERAPY AGENT
+2 ;;DRG4^NO LONGER VALID^^^3031001^1^0
+3 ;;DRG5^NO LONGER VALID^^^3031001^1^0
+4 ;;DRG231^NO LONGER VALID^^^3031001^1^0
+5 ;;DRG400^NO LONGER VALID^^^3031001^1^0
+6 ;;DRG514^NO LONGER VALID^^^3031001^1^0
+7 ;;QUIT
