ICD1861L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; 10/5/11 3:23pm
;;18.0;DRG Grouper;**61**;Oct 20, 2000;Build 18
;
Q
;
;DX - update DX identifier(s)
ICDDX ;Update Dx
D BMES^XPDUTL(">>> UPDATING DX CODE 767.2 IDENTIFIER...")
N LINE,DXTXT,ICDDXDA,DA,DIE,IDENT,DR
S DIE="^ICD9(",DR="2///^S X=IDENT"
F LINE=1:1 S DXTXT=$T(PROC+LINE) S ICDDXDA=$P(DXTXT,";;",2) Q:ICDDXDA="EXIT" D
.S DA=ICDDXDA
.S IDENT="S"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING DX CODE 959.09 IDENTIFIER...")
N LINE,DXTXT,ICDDXDA3,DA,IDENT
F LINE=1:1 S DXTXT=$T(PROC3+LINE) S ICDDXDA3=$P(DXTXT,";;",2) Q:ICDDXDA3="EXIT" D
.S DA=ICDDXDA3
.S IDENT="T"
.D ^DIE
.Q
Q
;
;PX - update PX identifier(s)
ICDPX ;Update Px
D BMES^XPDUTL(">>> UPDATING PX CODE 37.22 IDENTIFIER...")
N LINE,PXTXT,ICDPXDA,DA,IDENT
S DIE="^ICD0(",DR="2///^S X=IDENT"
F LINE=1:1 S PXTXT=$T(PROC1+LINE) S ICDPXDA=$P(PXTXT,";;",2) Q:ICDPXDA="EXIT" D
.S DA=ICDPXDA
.S IDENT="HNp"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING PX CODE 37.72 IDENTIFIER...")
N LINE,PXTXT,ICDPXDA1,DA,IDENT
F LINE=1:1 S PXTXT=$T(PROC2+LINE) S ICDPXDA1=$P(PXTXT,";;",2) Q:ICDPXDA1="EXIT" D
.S DA=ICDPXDA1
.S IDENT="oVp"
.D ^DIE
.Q
Q
;
PROC ;
;;5307
;;EXIT
;
PROC1 ;
;;579
;;EXIT
;
PROC2 ;
;;594
;;EXIT
;
PROC3 ;
;;13350
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1861L 1345 printed Nov 22, 2024@16:59:12 Page 2
ICD1861L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; 10/5/11 3:23pm
+1 ;;18.0;DRG Grouper;**61**;Oct 20, 2000;Build 18
+2 ;
+3 QUIT
+4 ;
+5 ;DX - update DX identifier(s)
ICDDX ;Update Dx
+1 DO BMES^XPDUTL(">>> UPDATING DX CODE 767.2 IDENTIFIER...")
+2 NEW LINE,DXTXT,ICDDXDA,DA,DIE,IDENT,DR
+3 SET DIE="^ICD9("
SET DR="2///^S X=IDENT"
+4 FOR LINE=1:1
SET DXTXT=$TEXT(PROC+LINE)
SET ICDDXDA=$PIECE(DXTXT,";;",2)
if ICDDXDA="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDDXDA
+6 SET IDENT="S"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 DO BMES^XPDUTL(">>> UPDATING DX CODE 959.09 IDENTIFIER...")
+10 NEW LINE,DXTXT,ICDDXDA3,DA,IDENT
+11 FOR LINE=1:1
SET DXTXT=$TEXT(PROC3+LINE)
SET ICDDXDA3=$PIECE(DXTXT,";;",2)
if ICDDXDA3="EXIT"
QUIT
Begin DoDot:1
+12 SET DA=ICDDXDA3
+13 SET IDENT="T"
+14 DO ^DIE
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
+18 ;PX - update PX identifier(s)
ICDPX ;Update Px
+1 DO BMES^XPDUTL(">>> UPDATING PX CODE 37.22 IDENTIFIER...")
+2 NEW LINE,PXTXT,ICDPXDA,DA,IDENT
+3 SET DIE="^ICD0("
SET DR="2///^S X=IDENT"
+4 FOR LINE=1:1
SET PXTXT=$TEXT(PROC1+LINE)
SET ICDPXDA=$PIECE(PXTXT,";;",2)
if ICDPXDA="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDPXDA
+6 SET IDENT="HNp"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 DO BMES^XPDUTL(">>> UPDATING PX CODE 37.72 IDENTIFIER...")
+10 NEW LINE,PXTXT,ICDPXDA1,DA,IDENT
+11 FOR LINE=1:1
SET PXTXT=$TEXT(PROC2+LINE)
SET ICDPXDA1=$PIECE(PXTXT,";;",2)
if ICDPXDA1="EXIT"
QUIT
Begin DoDot:1
+12 SET DA=ICDPXDA1
+13 SET IDENT="oVp"
+14 DO ^DIE
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
PROC ;
+1 ;;5307
+2 ;;EXIT
+3 ;
PROC1 ;
+1 ;;579
+2 ;;EXIT
+3 ;
PROC2 ;
+1 ;;594
+2 ;;EXIT
+3 ;
PROC3 ;
+1 ;;13350
+2 ;;EXIT
