ICD182P ;ALB/ESD/JAT - ICD/DRG; 6/22/01 2:43pm ; 9/19/01 2:55pm
;;18.0;DRG Grouper;**2**;Oct 13,2000
;
;
EN ;- Post-Install entry point
;
; - Add new DRGs
D ADDDRG^ICD182P1
S ^DD(80.2,0,"VR")="19.0"
;
;- Add new Diagnoses
D ADDDIAG^ICD182P2
S ^DD(80,0,"VR")="19.0"
;
;- Add new Procedures
D ADDPROC^ICD182P1
S ^DD(80.1,0,"VR")="19.0"
;
;- Inactivate/revise Diagnoses
D CHGDIAG^ICD182P3
;
;- Inactivate/revise Procedures
D CHGPROC^ICD182P3
;
;- Inactivate/revise DRGS
D DRGEDIT
;
;- DRG reclassification changes
D EN^ICD182P4
;
; - Weights & trims for FY 2001
D BEGWT01
;
;- Update Diagnoses w/complications/comorbidities
D EN^ICD182P5
;
Q
;
;
DRGEDIT ;- Edit DRG records (Description change)
;
N CNT,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y
S CNT=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))
. E D ERRMSG($P(DRG,"^"))
;
;- Total DRG records revised
D MES^XPDUTL(">>> ...completed. "_CNT_" record(s) revised.")
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 2001
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
D UPD01
Q
;
;
UPD01 ;- Load FY 2001 into ICD DRG file (#80.2)
S FYR=3010000
D BMES^XPDUTL(">>> Adding FY 2001 Weights & Trims...")
Q:$D(^ICD(511,"FY",3010000,0))
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD182PA),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD182PB),";;",2,99) Q:I>200 D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WEIGHTS+I^ICD182PC),";;",2,99) Q:$E(WT,1,3)="END" D SETVAR,FY,MORE
S ^ICD("AFY",3010000)=""
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=$E(WT,1,3),ICDLOW=1,ICDLOS=$E(WT,12,14),ICDHIGH=$E(WT,16,17),ICDWWU=$E(WT,5,10)
DRG I $E(DRG,1)=0 S DRG=$E(DRG,2,3) G DRG
S ICDLOS=$E(ICDLOS,1,2)_"."_$E(ICDLOS,3) I $E(ICDLOS,1)=0 S ICDLOS=$E(ICDLOS,2,4)
I $E(ICDHIGH,1)=0 S ICDHIGH=$E(ICDHIGH,2)
S ICDWWU=$E(ICDWWU,1,2)_"."_$E(ICDWWU,3,6) I $E(ICDWWU,1)=0 S ICDWWU=$E(ICDWWU,2,7)
Q
;
;
MORE ;- Set zero node with FY 2001 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
Q
;
;
REVDRG ;- Description edits
;;DRG116^OTHER CARDIAC PACEMAKER IMPLANTATION
;;DRG497^SPINAL FUSION EXCEPT CERVICAL W CC
;;DRG498^SPINAL FUSION EXCEPT CERVICAL W/O CC
;;DRG112^NO LONGER VALID
;;DRG434^NO LONGER VALID
;;DRG435^NO LONGER VALID
;;DRG436^NO LONGER VALID
;;DRG437^NO LONGER VALID
;;QUIT
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD182P 3649 printed Dec 13, 2024@01:48:17 Page 2
ICD182P ;ALB/ESD/JAT - ICD/DRG; 6/22/01 2:43pm ; 9/19/01 2:55pm
+1 ;;18.0;DRG Grouper;**2**;Oct 13,2000
+2 ;
+3 ;
EN ;- Post-Install entry point
+1 ;
+2 ; - Add new DRGs
+3 DO ADDDRG^ICD182P1
+4 SET ^DD(80.2,0,"VR")="19.0"
+5 ;
+6 ;- Add new Diagnoses
+7 DO ADDDIAG^ICD182P2
+8 SET ^DD(80,0,"VR")="19.0"
+9 ;
+10 ;- Add new Procedures
+11 DO ADDPROC^ICD182P1
+12 SET ^DD(80.1,0,"VR")="19.0"
+13 ;
+14 ;- Inactivate/revise Diagnoses
+15 DO CHGDIAG^ICD182P3
+16 ;
+17 ;- Inactivate/revise Procedures
+18 DO CHGPROC^ICD182P3
+19 ;
+20 ;- Inactivate/revise DRGS
+21 DO DRGEDIT
+22 ;
+23 ;- DRG reclassification changes
+24 DO EN^ICD182P4
+25 ;
+26 ; - Weights & trims for FY 2001
+27 DO BEGWT01
+28 ;
+29 ;- Update Diagnoses w/complications/comorbidities
+30 DO EN^ICD182P5
+31 ;
+32 QUIT
+33 ;
+34 ;
DRGEDIT ;- Edit DRG records (Description change)
+1 ;
+2 NEW CNT,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y
+3 SET CNT=0
+4 DO BMES^XPDUTL(">>> Revising DRG records in the DRG file (#80.2)...")
+5 FOR I=1:1
SET DRG=$PIECE($TEXT(REVDRG+I),";;",2)
if DRG="QUIT"
QUIT
Begin DoDot:1
+6 SET DIC="^ICD("
SET DIC(0)="MX"
+7 SET X=$PIECE(DRG,"^")
+8 DO ^DIC
+9 IF +Y>0
Begin DoDot:2
+10 SET ICDESC=""
+11 FOR
SET ICDESC=$ORDER(^ICD(+Y,1,"B",ICDESC))
if ICDESC=""
QUIT
SET ICDIEN=+$ORDER(^(ICDESC,0))
+12 SET (ICDI,DA(1))=+Y
SET DA=ICDIEN
+13 SET DIE=DIC_DA(1)_","_DA_","
+14 SET DR=".01///^S X=$P(DRG,""^"",2)"
+15 DO ^DIE
+16 Begin DoDot:3
+17 IF $PIECE(DRG,"^",3)=""
QUIT
+18 SET DIE=DIC
+19 SET DA=ICDI
+20 SET DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"
+21 DO ^DIE
End DoDot:3
+22 SET CNT=CNT+1
+23 DO MES^XPDUTL(" Edited: "_$PIECE(DRG,"^")_" to "_$PIECE(DRG,"^",2))
End DoDot:2
+24 IF '$TEST
DO ERRMSG($PIECE(DRG,"^"))
End DoDot:1
+25 ;
+26 ;- Total DRG records revised
+27 DO MES^XPDUTL(">>> ...completed. "_CNT_" record(s) revised.")
+28 DO MES^XPDUTL("")
+29 QUIT
+30 ;
+31 ;
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 ;
+7 ;
BEGWT01 ;- Entry point for wts & trims update for 2001
+1 NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
+2 DO UPD01
+3 QUIT
+4 ;
+5 ;
UPD01 ;- Load FY 2001 into ICD DRG file (#80.2)
+1 SET FYR=3010000
+2 DO BMES^XPDUTL(">>> Adding FY 2001 Weights & Trims...")
+3 if $DATA(^ICD(511,"FY",3010000,0))
QUIT
+4 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD182PA),";;",2,99)
if I>200
QUIT
DO SETVAR
DO FY
DO MORE
+5 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD182PB),";;",2,99)
if I>200
QUIT
DO SETVAR
DO FY
DO MORE
+6 FOR I=1:1
SET WT=$PIECE($TEXT(WEIGHTS+I^ICD182PC),";;",2,99)
if $EXTRACT(WT,1,3)="END"
QUIT
DO SETVAR
DO FY
DO MORE
+7 SET ^ICD("AFY",3010000)=""
+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=$EXTRACT(WT,1,3)
SET ICDLOW=1
SET ICDLOS=$EXTRACT(WT,12,14)
SET ICDHIGH=$EXTRACT(WT,16,17)
SET ICDWWU=$EXTRACT(WT,5,10)
DRG IF $EXTRACT(DRG,1)=0
SET DRG=$EXTRACT(DRG,2,3)
GOTO DRG
+1 SET ICDLOS=$EXTRACT(ICDLOS,1,2)_"."_$EXTRACT(ICDLOS,3)
IF $EXTRACT(ICDLOS,1)=0
SET ICDLOS=$EXTRACT(ICDLOS,2,4)
+2 IF $EXTRACT(ICDHIGH,1)=0
SET ICDHIGH=$EXTRACT(ICDHIGH,2)
+3 SET ICDWWU=$EXTRACT(ICDWWU,1,2)_"."_$EXTRACT(ICDWWU,3,6)
IF $EXTRACT(ICDWWU,1)=0
SET ICDWWU=$EXTRACT(ICDWWU,2,7)
+4 QUIT
+5 ;
+6 ;
MORE ;- Set zero node with FY 2001 stats
+1 SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",8)=ICDLOS
+2 QUIT
+3 ;
+4 ;
REVDRG ;- Description edits
+1 ;;DRG116^OTHER CARDIAC PACEMAKER IMPLANTATION
+2 ;;DRG497^SPINAL FUSION EXCEPT CERVICAL W CC
+3 ;;DRG498^SPINAL FUSION EXCEPT CERVICAL W/O CC
+4 ;;DRG112^NO LONGER VALID
+5 ;;DRG434^NO LONGER VALID
+6 ;;DRG435^NO LONGER VALID
+7 ;;DRG436^NO LONGER VALID
+8 ;;DRG437^NO LONGER VALID
+9 ;;QUIT
+10 ;
+11 ;
