ICD1861L.m

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 7

 ;

 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

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 7

 +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