ICD1869L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
;;18.0;DRG Grouper;**69**;Oct 20,2000;Build 4
;
Q
;
; Update Dx code(s)
ICDUPDDX ; update DX identifier(s)
D BMES^XPDUTL(">>> UPDATING DX CODE 482.42 IDENTIFIER...")
N LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
S DIE="^ICD9(",DR="2///^S X=IDENT"
F LINE=1:1 S LINEXX=$T(PROCUP1+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
.S DA=ICDDXDA
.S IDENT="k"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING DX CODE 779.84 IDENTIFIER...")
N LINE,DXTXT,ICDDXDA1,DA,IDENT
F LINE=1:1 S DXTXT=$T(PROCUP3+LINE) S ICDDXDA1=$P(DXTXT,";;",2) Q:ICDDXDA1="EXIT" D
.S DA=ICDDXDA1
.S IDENT="S"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING DX CODE V64.06 IDENTIFIER...")
N LINE,DXTXT,ICDDXDA4,DA,IDENT
F LINE=1:1 S DXTXT=$T(PROCUP4+LINE) S ICDDXDA4=$P(DXTXT,";;",2) Q:ICDDXDA4="EXIT" D
.S DA=ICDDXDA4
.S IDENT="S"
.D ^DIE
.Q
D BMES^XPDUTL(">>> UPDATING DX CODE V18.0 IDENTIFIER...")
N LINE,DXTXT,ICDDXDA2,DA,IDENT
F LINE=1:1 S DXTXT=$T(PROCUP5+LINE) S ICDDXDA2=$P(DXTXT,";;",2) Q:ICDDXDA2="EXIT" D
.S DA=ICDDXDA2
.S IDENT="S"
.D ^DIE
.Q
Q
;
;
; Update Px code(s)
ICDUPDPX ; Update Px identifier(s)
D BMES^XPDUTL(">>> UPDATING PX CODE 32.20 IDENTIFIER...")
N LINE,LINEXX,ICDPXDA3,DA,IDENT,DR,DIE
F LINE=1:1 S LINEXX=$T(PROCUP2+LINE) S ICDPXDA3=$P(LINEXX,";;",2) Q:ICDPXDA3="EXIT" D
.S DIE="^ICD0(",DR="2///^S X=IDENT"
.S DA=ICDPXDA3
.S IDENT="O"
.D ^DIE
Q
;
;
ICDECUP1 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.20
N ICDSAVXC,ICDXC,ICDDX
S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
S $P(^DD(45.89,.01,0),U,2)=ICDXC
F ICDDX=294.20 D
.S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
.Q:+Y'>0
.I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
.S DIC="^DIC(45.89,",DIC(0)=""
.S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
.K DO D FILE^DICN
.I +Y<0 D Q
..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
.D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
K DIC,DIE,DA,DR,Y,X
Q
;
;
ICDECUP2 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.21
N ICDSAVXC,ICDXC,ICDDX
S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
S $P(^DD(45.89,.01,0),U,2)=ICDXC
F ICDDX=294.21 D
.S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
.Q:+Y'>0
.I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
.S DIC="^DIC(45.89,",DIC(0)=""
.S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
.K DO D FILE^DICN
.I +Y<0 D Q
..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
.D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
K DIC,DIE,DA,DR,Y,X
Q
;
;
PROCUP1 ;
;;14734
;;EXIT
;
;
PROCUP2 ;
;;4369
;;EXIT
;
;
PROCUP3 ;
;;14156
;;EXIT
;
;
PROCUP4 ;
;;14211
;;EXIT
;
;
PROCUP5 ;
;;11396
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1869L 3414 printed Apr 09, 2024@20:57:42 Page 2
ICD1869L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
+1 ;;18.0;DRG Grouper;**69**;Oct 20,2000;Build 4
+2 ;
+3 QUIT
+4 ;
+5 ; Update Dx code(s)
ICDUPDDX ; update DX identifier(s)
+1 DO BMES^XPDUTL(">>> UPDATING DX CODE 482.42 IDENTIFIER...")
+2 NEW LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
+3 SET DIE="^ICD9("
SET DR="2///^S X=IDENT"
+4 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP1+LINE)
SET ICDDXDA=$PIECE(LINEXX,";;",2)
if ICDDXDA="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDDXDA
+6 SET IDENT="k"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 DO BMES^XPDUTL(">>> UPDATING DX CODE 779.84 IDENTIFIER...")
+10 NEW LINE,DXTXT,ICDDXDA1,DA,IDENT
+11 FOR LINE=1:1
SET DXTXT=$TEXT(PROCUP3+LINE)
SET ICDDXDA1=$PIECE(DXTXT,";;",2)
if ICDDXDA1="EXIT"
QUIT
Begin DoDot:1
+12 SET DA=ICDDXDA1
+13 SET IDENT="S"
+14 DO ^DIE
+15 QUIT
End DoDot:1
+16 DO BMES^XPDUTL(">>> UPDATING DX CODE V64.06 IDENTIFIER...")
+17 NEW LINE,DXTXT,ICDDXDA4,DA,IDENT
+18 FOR LINE=1:1
SET DXTXT=$TEXT(PROCUP4+LINE)
SET ICDDXDA4=$PIECE(DXTXT,";;",2)
if ICDDXDA4="EXIT"
QUIT
Begin DoDot:1
+19 SET DA=ICDDXDA4
+20 SET IDENT="S"
+21 DO ^DIE
+22 QUIT
End DoDot:1
+23 DO BMES^XPDUTL(">>> UPDATING DX CODE V18.0 IDENTIFIER...")
+24 NEW LINE,DXTXT,ICDDXDA2,DA,IDENT
+25 FOR LINE=1:1
SET DXTXT=$TEXT(PROCUP5+LINE)
SET ICDDXDA2=$PIECE(DXTXT,";;",2)
if ICDDXDA2="EXIT"
QUIT
Begin DoDot:1
+26 SET DA=ICDDXDA2
+27 SET IDENT="S"
+28 DO ^DIE
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
+32 ;
+33 ; Update Px code(s)
ICDUPDPX ; Update Px identifier(s)
+1 DO BMES^XPDUTL(">>> UPDATING PX CODE 32.20 IDENTIFIER...")
+2 NEW LINE,LINEXX,ICDPXDA3,DA,IDENT,DR,DIE
+3 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP2+LINE)
SET ICDPXDA3=$PIECE(LINEXX,";;",2)
if ICDPXDA3="EXIT"
QUIT
Begin DoDot:1
+4 SET DIE="^ICD0("
SET DR="2///^S X=IDENT"
+5 SET DA=ICDPXDA3
+6 SET IDENT="O"
+7 DO ^DIE
End DoDot:1
+8 QUIT
+9 ;
+10 ;
ICDECUP1 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.20
+1 NEW ICDSAVXC,ICDXC,ICDDX
+2 ;diagnosis/procedure code field
SET ICDSAVXC=$PIECE(^DD(45.89,.01,0),U,2)
+3 ;Remove the 'I'
SET ICDXC=$PIECE(ICDSAVXC,"I",1)_$PIECE(ICDSAVXC,"I",2,99)
+4 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDXC
+5 FOR ICDDX=294.20
Begin DoDot:1
+6 SET DIC="^ICD9("
SET DIC(0)="MX"
SET X=ICDDX
DO ^DIC
+7 if +Y'>0
QUIT
+8 IF $DATA(^DIC(45.89,"ASPL",+Y_";ICD9("))
Begin DoDot:2
+9 DO MES^XPDUTL(">>>>Entry "_$PIECE(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
End DoDot:2
QUIT
+10 SET DIC="^DIC(45.89,"
SET DIC(0)=""
+11 SET DIC("DR")=".01///5"_";.02///"_ICDDX
SET X="PSYCHIATRY AXIS CLASSIFICATION"
+12 KILL DO
DO FILE^DICN
+13 IF +Y<0
Begin DoDot:2
+14 DO MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
End DoDot:2
QUIT
+15 DO MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
End DoDot:1
+16 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDSAVXC
+17 KILL DIC,DIE,DA,DR,Y,X
+18 QUIT
+19 ;
+20 ;
ICDECUP2 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.21
+1 NEW ICDSAVXC,ICDXC,ICDDX
+2 ;diagnosis/procedure code field
SET ICDSAVXC=$PIECE(^DD(45.89,.01,0),U,2)
+3 ;Remove the 'I'
SET ICDXC=$PIECE(ICDSAVXC,"I",1)_$PIECE(ICDSAVXC,"I",2,99)
+4 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDXC
+5 FOR ICDDX=294.21
Begin DoDot:1
+6 SET DIC="^ICD9("
SET DIC(0)="MX"
SET X=ICDDX
DO ^DIC
+7 if +Y'>0
QUIT
+8 IF $DATA(^DIC(45.89,"ASPL",+Y_";ICD9("))
Begin DoDot:2
+9 DO MES^XPDUTL(">>>>Entry "_$PIECE(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
End DoDot:2
QUIT
+10 SET DIC="^DIC(45.89,"
SET DIC(0)=""
+11 SET DIC("DR")=".01///5"_";.02///"_ICDDX
SET X="PSYCHIATRY AXIS CLASSIFICATION"
+12 KILL DO
DO FILE^DICN
+13 IF +Y<0
Begin DoDot:2
+14 DO MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
End DoDot:2
QUIT
+15 DO MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
End DoDot:1
+16 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDSAVXC
+17 KILL DIC,DIE,DA,DR,Y,X
+18 QUIT
+19 ;
+20 ;
PROCUP1 ;
+1 ;;14734
+2 ;;EXIT
+3 ;
+4 ;
PROCUP2 ;
+1 ;;4369
+2 ;;EXIT
+3 ;
+4 ;
PROCUP3 ;
+1 ;;14156
+2 ;;EXIT
+3 ;
+4 ;
PROCUP4 ;
+1 ;;14211
+2 ;;EXIT
+3 ;
+4 ;
PROCUP5 ;
+1 ;;11396
+2 ;;EXIT
