ICD142PT ;;ALB/EG/ABR - ADD NEW ICD DX/OPS/UPDATES ;DEC 15, 1993
;;14.0;DRG Grouper;**2**;Apr 03, 1997
;
;
EN N ACTION,DIC,I,ICDTEST,ICDDEBUG,REF
S ICDDEBUG=1,ICDTEST=0
D KILL
;D MDC ; add new MDC (FY1996 only)
D ADDDRG ; add new DRG's
INACT D ACT^ICD142A1 ; inactivate dx and op codes
D EN^ICD142A2 ; for revised descriptions only - ensures KWIK x-ref's updated
ADOPS D ADDP^ICD142P1 ; add new op codes
D RIDXP ; reindex new op codes
;
; add new dx codes
;
D BMES^XPDUTL("Adding or Revising the following Diagnostic codes")
F ICDI=1:1:2 S ICDX="D ADDP^ICD1420"_ICDI X ICDX
; F ICDI=10:1:29 S ICDX="D ADDP^ICDYQ"_ICDI X ICDX ; (used if more than 9 routines)
;
D RIDXD ;reindex new dx codes
;
; Set new Zero nodes
;
DXHDR S $P(^ICD9(0),"^",3)=13380,$P(^(0),"^",4)=13373
OPSHDR S $P(^ICD0(0),"^",3)=4140,$P(^(0),"^",4)=4140
K ^ICD9("B"),^ICD0("B")
D BMES^XPDUTL("ICD Codes Updating Done!")
Q
RIDXP ;reindex procedure entries
Q:ICDTEST
D BMES^XPDUTL("Re-indexing the updated procedure codes")
F ICDI=1:1 S DIK="^ICD0(",ICDX=$P($T(REIDXP+ICDI),";;",2) Q:ICDX="" F ICDJ=1:1 S DA=$P(ICDX,"^",ICDJ) Q:'DA D IX^DIK
K DA,DIK,ICDI,ICDJ,ICDX
Q
REIDXP ;new and revised procedure entries
;;4138^4139^4140
;;
RIDXD ;new dx entries
N DA,DIK
Q:ICDTEST
D BMES^XPDUTL("Re-indexing the updated diagnostic codes")
S DIK="^ICD9("
;F DA=0:0 S DA=$O(^TMP("ICDUPD",$J,DA)) Q:'DA D RIDXD1,IX^DIK
F DA=0:0 S DA=$O(^TMP("ICDUPD",$J,DA)) Q:'DA D IX^DIK
Q
RIDXD1 ;cc exclusion x-ref
Q:ICDTEST
Q:'$D(^ICD9(DA,2,0))
S ICDX=0 F ICDI=1:1 S ICDX=$O(^ICD9(DA,2,ICDX)) Q:ICDX="" I ICDX>0 S ICDY=$G(^ICD9(DA,2,ICDX,0)) S:ICDY'="" ^ICD9("ACC",DA,ICDY)=""
K ICDI,ICDX,ICDY
Q
ADDDRG ;-- Add any new DRGs, update DRG information
N DRGX,DRGY
D BMES^XPDUTL(">>> Adding New DRGs")
F I=1:1 S X=$T(ADD+I) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT" X ICDDRG I $P(ICDDRG,",",3) D
. ; when description set up, displays listing
. S DRGX=+$P(ICDDRG,"(",2),DRGY=$P(ICDDRG,$C(34),2)
. D MES^XPDUTL(" DRG"_DRGX_" "_DRGY_" added.")
. Q
D BMES^XPDUTL(">>> Re-indexing DRG file ")
S DIK="^ICD(" F DA=496:1:503 D IX^DIK
S ^ICD(0)="DRG^80.2^503^508"
K DA,DIK,I,ICDDRG,X
Q
;
ADD ;New DRGs
;;S ^ICD(496,0)="DRG496^^^^8^1"
;;S ^ICD(496,1,0)="^80.21A^1^1"
;;S ^ICD(496,1,1,0)="COMBINED ANTERIOR/POSTERIOR SPINAL FUSION"
;;S ^ICD(496,1,"B","COMBINED ANTERIOR/POSTERIOR SP",1)=""
;;S ^ICD(497,0)="DRG497^^^^8^1"
;;S ^ICD(497,1,0)="^80.21A^1^1"
;;S ^ICD(497,1,1,0)="SPINAL FUSION W CC"
;;S ^ICD(497,1,"B","SPINAL FUSION W CC",1)=""
;;S ^ICD(498,0)="DRG498^^^^8^1"
;;S ^ICD(498,1,0)="^80.21A^1^1"
;;S ^ICD(498,1,1,0)="SPINAL FUSION W/O CC"
;;S ^ICD(498,1,"B","SPINAL FUSION W/O CC",1)=""
;;S ^ICD(499,0)="DRG499^^^^8^1"
;;S ^ICD(499,1,0)="^80.21A^1^1"
;;S ^ICD(499,1,1,0)="BACK & NECK PROCS EXCEPT SPINAL FUSION W CC"
;;S ^ICD(499,1,"B","BACK & NECK PROCS EXCEPT SPINA",1)=""
;;S ^ICD(500,0)="DRG500^^^^8^1"
;;S ^ICD(500,1,0)="^80.21A^1^1"
;;S ^ICD(500,1,1,0)="BACK & NECK PROCS EXCEPT SPINAL FUSION W/O CC"
;;S ^ICD(500,1,"B","BACK & NECK PROCS EXCEPT SPINA",1)=""
;;S ^ICD(501,0)="DRG501^^^^8^1"
;;S ^ICD(501,1,0)="^80.21A^1^1"
;;S ^ICD(501,1,1,0)="KNEE PROC W PDX OF INFECTION W CC"
;;S ^ICD(501,1,"B","KNEE PROC W PDX OF INFECTION W",1)=""
;;S ^ICD(502,0)="DRG502^^^^8^1"
;;S ^ICD(502,1,0)="^80.21A^1^1"
;;S ^ICD(502,1,1,0)="KNEE PROC W PDX OF INFECTION W/O CC"
;;S ^ICD(502,1,"B","KNEE PROC W PDX OF INFECTION W",1)=""
;;S ^ICD(503,0)="DRG503^^^^8^1"
;;S ^ICD(503,1,0)="^80.21A^1^1"
;;S ^ICD(503,1,1,0)="KNEE PROCEDURES W/O PDX OF INFECTION"
;;S ^ICD(503,1,"B","KNEE PROCEDURES W/O PDX OF INF",1)=""
;;EXIT
MDC ;add PRE Major Diagnostic Category for lung transplants (fy96)
Q
KILL K ^TMP("ICDUPD",$J)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD142PT 3838 printed Dec 13, 2024@01:47:35 Page 2
ICD142PT ;;ALB/EG/ABR - ADD NEW ICD DX/OPS/UPDATES ;DEC 15, 1993
+1 ;;14.0;DRG Grouper;**2**;Apr 03, 1997
+2 ;
+3 ;
EN NEW ACTION,DIC,I,ICDTEST,ICDDEBUG,REF
+1 SET ICDDEBUG=1
SET ICDTEST=0
+2 DO KILL
+3 ;D MDC ; add new MDC (FY1996 only)
+4 ; add new DRG's
DO ADDDRG
INACT ; inactivate dx and op codes
DO ACT^ICD142A1
+1 ; for revised descriptions only - ensures KWIK x-ref's updated
DO EN^ICD142A2
ADOPS ; add new op codes
DO ADDP^ICD142P1
+1 ; reindex new op codes
DO RIDXP
+2 ;
+3 ; add new dx codes
+4 ;
+5 DO BMES^XPDUTL("Adding or Revising the following Diagnostic codes")
+6 FOR ICDI=1:1:2
SET ICDX="D ADDP^ICD1420"_ICDI
XECUTE ICDX
+7 ; F ICDI=10:1:29 S ICDX="D ADDP^ICDYQ"_ICDI X ICDX ; (used if more than 9 routines)
+8 ;
+9 ;reindex new dx codes
DO RIDXD
+10 ;
+11 ; Set new Zero nodes
+12 ;
DXHDR SET $PIECE(^ICD9(0),"^",3)=13380
SET $PIECE(^(0),"^",4)=13373
OPSHDR SET $PIECE(^ICD0(0),"^",3)=4140
SET $PIECE(^(0),"^",4)=4140
+1 KILL ^ICD9("B"),^ICD0("B")
+2 DO BMES^XPDUTL("ICD Codes Updating Done!")
+3 QUIT
RIDXP ;reindex procedure entries
+1 if ICDTEST
QUIT
+2 DO BMES^XPDUTL("Re-indexing the updated procedure codes")
+3 FOR ICDI=1:1
SET DIK="^ICD0("
SET ICDX=$PIECE($TEXT(REIDXP+ICDI),";;",2)
if ICDX=""
QUIT
FOR ICDJ=1:1
SET DA=$PIECE(ICDX,"^",ICDJ)
if 'DA
QUIT
DO IX^DIK
+4 KILL DA,DIK,ICDI,ICDJ,ICDX
+5 QUIT
REIDXP ;new and revised procedure entries
+1 ;;4138^4139^4140
+2 ;;
RIDXD ;new dx entries
+1 NEW DA,DIK
+2 if ICDTEST
QUIT
+3 DO BMES^XPDUTL("Re-indexing the updated diagnostic codes")
+4 SET DIK="^ICD9("
+5 ;F DA=0:0 S DA=$O(^TMP("ICDUPD",$J,DA)) Q:'DA D RIDXD1,IX^DIK
+6 FOR DA=0:0
SET DA=$ORDER(^TMP("ICDUPD",$JOB,DA))
if 'DA
QUIT
DO IX^DIK
+7 QUIT
RIDXD1 ;cc exclusion x-ref
+1 if ICDTEST
QUIT
+2 if '$DATA(^ICD9(DA,2,0))
QUIT
+3 SET ICDX=0
FOR ICDI=1:1
SET ICDX=$ORDER(^ICD9(DA,2,ICDX))
if ICDX=""
QUIT
IF ICDX>0
SET ICDY=$GET(^ICD9(DA,2,ICDX,0))
if ICDY'=""
SET ^ICD9("ACC",DA,ICDY)=""
+4 KILL ICDI,ICDX,ICDY
+5 QUIT
ADDDRG ;-- Add any new DRGs, update DRG information
+1 NEW DRGX,DRGY
+2 DO BMES^XPDUTL(">>> Adding New DRGs")
+3 FOR I=1:1
SET X=$TEXT(ADD+I)
SET ICDDRG=$PIECE(X,";;",2)
if ICDDRG="EXIT"
QUIT
XECUTE ICDDRG
IF $PIECE(ICDDRG,",",3)
Begin DoDot:1
+4 ; when description set up, displays listing
+5 SET DRGX=+$PIECE(ICDDRG,"(",2)
SET DRGY=$PIECE(ICDDRG,$CHAR(34),2)
+6 DO MES^XPDUTL(" DRG"_DRGX_" "_DRGY_" added.")
+7 QUIT
End DoDot:1
+8 DO BMES^XPDUTL(">>> Re-indexing DRG file ")
+9 SET DIK="^ICD("
FOR DA=496:1:503
DO IX^DIK
+10 SET ^ICD(0)="DRG^80.2^503^508"
+11 KILL DA,DIK,I,ICDDRG,X
+12 QUIT
+13 ;
ADD ;New DRGs
+1 ;;S ^ICD(496,0)="DRG496^^^^8^1"
+2 ;;S ^ICD(496,1,0)="^80.21A^1^1"
+3 ;;S ^ICD(496,1,1,0)="COMBINED ANTERIOR/POSTERIOR SPINAL FUSION"
+4 ;;S ^ICD(496,1,"B","COMBINED ANTERIOR/POSTERIOR SP",1)=""
+5 ;;S ^ICD(497,0)="DRG497^^^^8^1"
+6 ;;S ^ICD(497,1,0)="^80.21A^1^1"
+7 ;;S ^ICD(497,1,1,0)="SPINAL FUSION W CC"
+8 ;;S ^ICD(497,1,"B","SPINAL FUSION W CC",1)=""
+9 ;;S ^ICD(498,0)="DRG498^^^^8^1"
+10 ;;S ^ICD(498,1,0)="^80.21A^1^1"
+11 ;;S ^ICD(498,1,1,0)="SPINAL FUSION W/O CC"
+12 ;;S ^ICD(498,1,"B","SPINAL FUSION W/O CC",1)=""
+13 ;;S ^ICD(499,0)="DRG499^^^^8^1"
+14 ;;S ^ICD(499,1,0)="^80.21A^1^1"
+15 ;;S ^ICD(499,1,1,0)="BACK & NECK PROCS EXCEPT SPINAL FUSION W CC"
+16 ;;S ^ICD(499,1,"B","BACK & NECK PROCS EXCEPT SPINA",1)=""
+17 ;;S ^ICD(500,0)="DRG500^^^^8^1"
+18 ;;S ^ICD(500,1,0)="^80.21A^1^1"
+19 ;;S ^ICD(500,1,1,0)="BACK & NECK PROCS EXCEPT SPINAL FUSION W/O CC"
+20 ;;S ^ICD(500,1,"B","BACK & NECK PROCS EXCEPT SPINA",1)=""
+21 ;;S ^ICD(501,0)="DRG501^^^^8^1"
+22 ;;S ^ICD(501,1,0)="^80.21A^1^1"
+23 ;;S ^ICD(501,1,1,0)="KNEE PROC W PDX OF INFECTION W CC"
+24 ;;S ^ICD(501,1,"B","KNEE PROC W PDX OF INFECTION W",1)=""
+25 ;;S ^ICD(502,0)="DRG502^^^^8^1"
+26 ;;S ^ICD(502,1,0)="^80.21A^1^1"
+27 ;;S ^ICD(502,1,1,0)="KNEE PROC W PDX OF INFECTION W/O CC"
+28 ;;S ^ICD(502,1,"B","KNEE PROC W PDX OF INFECTION W",1)=""
+29 ;;S ^ICD(503,0)="DRG503^^^^8^1"
+30 ;;S ^ICD(503,1,0)="^80.21A^1^1"
+31 ;;S ^ICD(503,1,1,0)="KNEE PROCEDURES W/O PDX OF INFECTION"
+32 ;;S ^ICD(503,1,"B","KNEE PROCEDURES W/O PDX OF INF",1)=""
+33 ;;EXIT
MDC ;add PRE Major Diagnostic Category for lung transplants (fy96)
+1 QUIT
KILL KILL ^TMP("ICDUPD",$JOB)
