ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am
;;18.0;DRG Grouper;;Oct 20, 2000
;
;
; This routine may be re-run.
;
EN ;- Post-Install entry point
;
;- Remove dup "B" xrefs from Description multiple
;D REMXREF
;
;- Revise DRGs/new descriptions, or changed to Inactie
;D DRGEDIT
;
;- Weights & trims for FY 97
;D BEGWT
;
;- Display reminder msg
D BMES^XPDUTL(">>> IMPORTANT: Please restore your ICD9 and ICD0 global files from <<<")
D MES^XPDUTL(">>> ICD9_18.GBL and ICD0_18.GBL at this time. <<<")
Q
;
;
REMXREF ;- Remove dup "B" xref on Description multiple and reindex
;
N DA,DIK,I,ICDIEN
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Correcting duplicate ""B"" cross-ref entries in the Description")
D MES^XPDUTL(" multiple of the DRG file (#80.2)...")
F I=1:1 S ICDIEN=$P($T(REMXDRG+I),";;",2) Q:ICDIEN="QUIT" D
. K ^ICD(ICDIEN,1,"B")
. S DA(1)=ICDIEN,DA=1
. S DIK="^ICD("_DA(1)_",1,"
. S DIK(1)=".01^B"
. D EN1^DIK
D MES^XPDUTL(">>> ...completed.")
D MES^XPDUTL("")
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
;
;
BEGWT ;- Entry point for wts & trims update for 97
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
D UPD97
Q
;
;
UPD97 ;- Load FY 97 WWU into ICD DRG file (#80.2)
S FYR=2970000
D BMES^XPDUTL(">>> Adding FY 97 Weights & Trims...")
F I=1:1 S WT=$P($T(WW97+I^ICD16P97),";;",2,99) Q:'WT D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WW97+I^ICD1697A),";;",2,99) Q:'WT D SETVAR,FY,MORE
S ^ICD("AFY",2970000)=""
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=+WT,ICDLOW=$P(WT,"^",2),ICDLOS=$P(WT,"^",3),ICDHIGH=$P(WT,"^",4),ICDWWU=$P(WT,"^",5)
Q
;
;
MORE ;- Set zero node with FY 97 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
D FY
Q
;
;
REVDRG ;- Description edits
;;DRG104^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W CARD CATH
;;DRG105^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W/O CARD CATH
;;DRG106^CORONARY BYPASS WITH PTCA^1^5
;;DRG107^CORONARY BYPASS W CARDIAC CATH^1^5
;;DRG109^CORONARY BYPASS W/O CARDIAC CATH^1^5
;;DRG115^PERM PACE IMPLNT W AMI,HRT FAIL OR SHOCK OR AICD LEAD OR GEN PROC
;;DRG116^OTH PERM CARDIAC PACEMAKER IMPLANT OR PTCA W CORONARY ART STENT
;;DRG121^CIRCULATORY DISORDERS W AMI & MAJOR COMP DISCH ALIVE
;;DRG122^CIRCULATORY DISORDERS W AMI W/O MAJOR COMP DISCH ALIVE
;;DRG406^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W CC
;;DRG407^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W/O CC
;;DRG485^LIMB REATTACHMENT, HIP AND FEMUR PROC FOR MULTIPLE SIGNIFICANT TR
;;DRG214^NO LONGER VALID
;;DRG215^NO LONGER VALID
;;DRG221^NO LONGER VALID
;;DRG222^NO LONGER VALID
;;DRG456^NO LONGER VALID
;;DRG457^NO LONGER VALID
;;DRG458^NO LONGER VALID
;;DRG459^NO LONGER VALID
;;DRG460^NO LONGER VALID
;;DRG472^NO LONGER VALID
;;QUIT
;
;
REMXDRG ;- DRG dup "B" xref IENs
;;11
;;48
;;53
;;54
;;89
;;90
;;91
;;104
;;105
;;116
;;193
;;194
;;195
;;196
;;197
;;198
;;384
;;410
;;444
;;445
;;446
;;461
;;477
;;482
;;483
;;485
;;486
;;488
;;490
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD18PT 4669 printed Apr 09, 2024@20:53:40 Page 2
ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am
+1 ;;18.0;DRG Grouper;;Oct 20, 2000
+2 ;
+3 ;
+4 ; This routine may be re-run.
+5 ;
EN ;- Post-Install entry point
+1 ;
+2 ;- Remove dup "B" xrefs from Description multiple
+3 ;D REMXREF
+4 ;
+5 ;- Revise DRGs/new descriptions, or changed to Inactie
+6 ;D DRGEDIT
+7 ;
+8 ;- Weights & trims for FY 97
+9 ;D BEGWT
+10 ;
+11 ;- Display reminder msg
+12 DO BMES^XPDUTL(">>> IMPORTANT: Please restore your ICD9 and ICD0 global files from <<<")
+13 DO MES^XPDUTL(">>> ICD9_18.GBL and ICD0_18.GBL at this time. <<<")
+14 QUIT
+15 ;
+16 ;
REMXREF ;- Remove dup "B" xref on Description multiple and reindex
+1 ;
+2 NEW DA,DIK,I,ICDIEN
+3 DO MES^XPDUTL("")
+4 DO BMES^XPDUTL(">>> Correcting duplicate ""B"" cross-ref entries in the Description")
+5 DO MES^XPDUTL(" multiple of the DRG file (#80.2)...")
+6 FOR I=1:1
SET ICDIEN=$PIECE($TEXT(REMXDRG+I),";;",2)
if ICDIEN="QUIT"
QUIT
Begin DoDot:1
+7 KILL ^ICD(ICDIEN,1,"B")
+8 SET DA(1)=ICDIEN
SET DA=1
+9 SET DIK="^ICD("_DA(1)_",1,"
+10 SET DIK(1)=".01^B"
+11 DO EN1^DIK
End DoDot:1
+12 DO MES^XPDUTL(">>> ...completed.")
+13 DO MES^XPDUTL("")
+14 QUIT
+15 ;
+16 ;
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 ;
BEGWT ;- Entry point for wts & trims update for 97
+1 NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
+2 DO UPD97
+3 QUIT
+4 ;
+5 ;
UPD97 ;- Load FY 97 WWU into ICD DRG file (#80.2)
+1 SET FYR=2970000
+2 DO BMES^XPDUTL(">>> Adding FY 97 Weights & Trims...")
+3 FOR I=1:1
SET WT=$PIECE($TEXT(WW97+I^ICD16P97),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
DO MORE
+4 FOR I=1:1
SET WT=$PIECE($TEXT(WW97+I^ICD1697A),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
DO MORE
+5 SET ^ICD("AFY",2970000)=""
+6 DO MES^XPDUTL(">>> ...completed.")
+7 DO MES^XPDUTL("")
+8 QUIT
+9 ;
+10 ;
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=+WT
SET ICDLOW=$PIECE(WT,"^",2)
SET ICDLOS=$PIECE(WT,"^",3)
SET ICDHIGH=$PIECE(WT,"^",4)
SET ICDWWU=$PIECE(WT,"^",5)
+2 QUIT
+3 ;
+4 ;
MORE ;- Set zero node with FY 97 stats
+1 SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",8)=ICDLOS
+2 DO FY
+3 QUIT
+4 ;
+5 ;
REVDRG ;- Description edits
+1 ;;DRG104^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W CARD CATH
+2 ;;DRG105^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W/O CARD CATH
+3 ;;DRG106^CORONARY BYPASS WITH PTCA^1^5
+4 ;;DRG107^CORONARY BYPASS W CARDIAC CATH^1^5
+5 ;;DRG109^CORONARY BYPASS W/O CARDIAC CATH^1^5
+6 ;;DRG115^PERM PACE IMPLNT W AMI,HRT FAIL OR SHOCK OR AICD LEAD OR GEN PROC
+7 ;;DRG116^OTH PERM CARDIAC PACEMAKER IMPLANT OR PTCA W CORONARY ART STENT
+8 ;;DRG121^CIRCULATORY DISORDERS W AMI & MAJOR COMP DISCH ALIVE
+9 ;;DRG122^CIRCULATORY DISORDERS W AMI W/O MAJOR COMP DISCH ALIVE
+10 ;;DRG406^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W CC
+11 ;;DRG407^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W/O CC
+12 ;;DRG485^LIMB REATTACHMENT, HIP AND FEMUR PROC FOR MULTIPLE SIGNIFICANT TR
+13 ;;DRG214^NO LONGER VALID
+14 ;;DRG215^NO LONGER VALID
+15 ;;DRG221^NO LONGER VALID
+16 ;;DRG222^NO LONGER VALID
+17 ;;DRG456^NO LONGER VALID
+18 ;;DRG457^NO LONGER VALID
+19 ;;DRG458^NO LONGER VALID
+20 ;;DRG459^NO LONGER VALID
+21 ;;DRG460^NO LONGER VALID
+22 ;;DRG472^NO LONGER VALID
+23 ;;QUIT
+24 ;
+25 ;
REMXDRG ;- DRG dup "B" xref IENs
+1 ;;11
+2 ;;48
+3 ;;53
+4 ;;54
+5 ;;89
+6 ;;90
+7 ;;91
+8 ;;104
+9 ;;105
+10 ;;116
+11 ;;193
+12 ;;194
+13 ;;195
+14 ;;196
+15 ;;197
+16 ;;198
+17 ;;384
+18 ;;410
+19 ;;444
+20 ;;445
+21 ;;446
+22 ;;461
+23 ;;477
+24 ;;482
+25 ;;483
+26 ;;485
+27 ;;486
+28 ;;488
+29 ;;490
+30 ;;QUIT
