ICD1855L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; ; 10/5/11 3:23pm
;;18.0;DRG Grouper;**55**;Oct 20,2000;Build 20
;
Q
;
;DX - update DX identifier(s)
ICDDX ;Update Dx
D BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
N LINE,X,ICDDXDA,DA,DIE,IDENT,DR
F LINE=1:1 S X=$T(PROC+LINE) S ICDDXDA=$P(X,";;",2) Q:ICDDXDA="EXIT" D
.S DA=ICDDXDA
.S DIE="^ICD9("
.S IDENT="@"
.S DR="2///^S X=IDENT"
.D ^DIE
.Q
Q
;
;
;PX - update PX identifier(s)
ICDPX ;Update Px
D BMES^XPDUTL(">>> UPDATING PX CODES 84.10 - 84.17...")
N LINE,X,ICDPXDA,DA,IDENT
S DIE="^ICD0(",DR="2///^S X=IDENT"
F LINE=1:1 S X=$T(PROC1+LINE) S ICDPXDA=$P(X,";;",2) Q:ICDPXDA="EXIT" D
.S DA=ICDPXDA
.S IDENT="OA"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING PX CODE 64.0...")
N LINE,X,ICDPXDA1,DA,IDENT
F LINE=1:1 S X=$T(PROC2+LINE) S ICDPXDA1=$P(X,";;",2) Q:ICDPXDA1="EXIT" D
.S DA=ICDPXDA1
.S IDENT="Oza"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING PX CODES 51.21 & 51.24...")
N LINE,X,ICDPXDA2,DA,IDENT
F LINE=1:1 S X=$T(PROC3+LINE) S ICDPXDA2=$P(X,";;",2) Q:ICDPXDA2="EXIT" D
.S DA=ICDPXDA2
.S IDENT="OT"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING PX CODE 07.83 IDENTIFIER...")
N LINE,X,ICDPXDA3,DA,IDENT
F LINE=1:1 S X=$T(PROC4+LINE) S ICDPXDA3=$P(X,";;",2) Q:ICDPXDA3="EXIT" D
.S DA=ICDPXDA3
.S IDENT="O"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING PX CODE 04.41...")
N ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN
S ICDDATE1=3071001,MDC1=1
S ICDPXIEN=$O(^ICD0("AB","04.41",""))
S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
F ICDDRGNUM=31,32,33 S DRGIEN=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,"")) D
.S ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)="@"
D UPDATE^DIE("","ICDFDA") K ICDFDA
Q
;
;
;PX - update PX Major O.R. procedure
ICDPX1 ; Update Px
D BMES^XPDUTL(">>> UPDATING PX CODE 07.83 MAJOR O.R. PROCEDURE...")
N LINE,X,ICDPXDA3,DA,MAJOR
S DIE="^ICD0(",DR="20///^S X=MAJOR"
F LINE=1:1 S X=$T(PROC4+LINE) S ICDPXDA3=$P(X,";;",2) Q:ICDPXDA3="EXIT" D
.S DA=ICDPXDA3
.S MAJOR="23"
.D ^DIE
.Q
;
;
PROC ;
;;4795
;;EXIT
;
;
PROC1 ;
;;3360
;;2117
;;2118
;;2119
;;2120
;;2121
;;2122
;;2123
;;EXIT
;
;
PROC2 ;
;;3308
;;EXIT
;
;
PROC3 ;
;;1017
;;4108
;;EXIT
;
;
PROC4 ;
;;4365
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1855L 2389 printed Nov 22, 2024@16:59:08 Page 2
ICD1855L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; ; 10/5/11 3:23pm
+1 ;;18.0;DRG Grouper;**55**;Oct 20,2000;Build 20
+2 ;
+3 QUIT
+4 ;
+5 ;DX - update DX identifier(s)
ICDDX ;Update Dx
+1 DO BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
+2 NEW LINE,X,ICDDXDA,DA,DIE,IDENT,DR
+3 FOR LINE=1:1
SET X=$TEXT(PROC+LINE)
SET ICDDXDA=$PIECE(X,";;",2)
if ICDDXDA="EXIT"
QUIT
Begin DoDot:1
+4 SET DA=ICDDXDA
+5 SET DIE="^ICD9("
+6 SET IDENT="@"
+7 SET DR="2///^S X=IDENT"
+8 DO ^DIE
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
+12 ;
+13 ;PX - update PX identifier(s)
ICDPX ;Update Px
+1 DO BMES^XPDUTL(">>> UPDATING PX CODES 84.10 - 84.17...")
+2 NEW LINE,X,ICDPXDA,DA,IDENT
+3 SET DIE="^ICD0("
SET DR="2///^S X=IDENT"
+4 FOR LINE=1:1
SET X=$TEXT(PROC1+LINE)
SET ICDPXDA=$PIECE(X,";;",2)
if ICDPXDA="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDPXDA
+6 SET IDENT="OA"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 DO BMES^XPDUTL(">>> UPDATING PX CODE 64.0...")
+10 NEW LINE,X,ICDPXDA1,DA,IDENT
+11 FOR LINE=1:1
SET X=$TEXT(PROC2+LINE)
SET ICDPXDA1=$PIECE(X,";;",2)
if ICDPXDA1="EXIT"
QUIT
Begin DoDot:1
+12 SET DA=ICDPXDA1
+13 SET IDENT="Oza"
+14 DO ^DIE
+15 QUIT
End DoDot:1
+16 DO BMES^XPDUTL(">>> UPDATING PX CODES 51.21 & 51.24...")
+17 NEW LINE,X,ICDPXDA2,DA,IDENT
+18 FOR LINE=1:1
SET X=$TEXT(PROC3+LINE)
SET ICDPXDA2=$PIECE(X,";;",2)
if ICDPXDA2="EXIT"
QUIT
Begin DoDot:1
+19 SET DA=ICDPXDA2
+20 SET IDENT="OT"
+21 DO ^DIE
+22 QUIT
End DoDot:1
+23 DO BMES^XPDUTL(">>> UPDATING PX CODE 07.83 IDENTIFIER...")
+24 NEW LINE,X,ICDPXDA3,DA,IDENT
+25 FOR LINE=1:1
SET X=$TEXT(PROC4+LINE)
SET ICDPXDA3=$PIECE(X,";;",2)
if ICDPXDA3="EXIT"
QUIT
Begin DoDot:1
+26 SET DA=ICDPXDA3
+27 SET IDENT="O"
+28 DO ^DIE
+29 QUIT
End DoDot:1
+30 DO BMES^XPDUTL(">>> UPDATING PX CODE 04.41...")
+31 NEW ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN
+32 SET ICDDATE1=3071001
SET MDC1=1
+33 SET ICDPXIEN=$ORDER(^ICD0("AB","04.41",""))
+34 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
+35 FOR ICDDRGNUM=31,32,33
SET DRGIEN=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
Begin DoDot:1
+36 SET ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)="@"
End DoDot:1
+37 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
+38 QUIT
+39 ;
+40 ;
+41 ;PX - update PX Major O.R. procedure
ICDPX1 ; Update Px
+1 DO BMES^XPDUTL(">>> UPDATING PX CODE 07.83 MAJOR O.R. PROCEDURE...")
+2 NEW LINE,X,ICDPXDA3,DA,MAJOR
+3 SET DIE="^ICD0("
SET DR="20///^S X=MAJOR"
+4 FOR LINE=1:1
SET X=$TEXT(PROC4+LINE)
SET ICDPXDA3=$PIECE(X,";;",2)
if ICDPXDA3="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDPXDA3
+6 SET MAJOR="23"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 ;
+10 ;
PROC ;
+1 ;;4795
+2 ;;EXIT
+3 ;
+4 ;
PROC1 ;
+1 ;;3360
+2 ;;2117
+3 ;;2118
+4 ;;2119
+5 ;;2120
+6 ;;2121
+7 ;;2122
+8 ;;2123
+9 ;;EXIT
+10 ;
+11 ;
PROC2 ;
+1 ;;3308
+2 ;;EXIT
+3 ;
+4 ;
PROC3 ;
+1 ;;1017
+2 ;;4108
+3 ;;EXIT
+4 ;
+5 ;
PROC4 ;
+1 ;;4365
+2 ;;EXIT
