Routine: AUM61P1

AUM61P1 ;IHS/ASDST/DMJ,SDR - ICD9 MODS TO CODES FOR FY 2006 ; [ 08/18/2003  11:02 AM ]

 ;;06.1;TABLE MAINTENANCE;**1**;SEP 28,2001

START ;EP

SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables.

 NEW DA,DIC,DIE,DINUM,DLAYGO,DR,@($P($T(SVARS),";",3))

 S U="^"

 D RSLT("Beginning v6.1 p1 ICD Update.")

 D DASH,ICD9REV

 D DASH,ICD0REV

 D RSLT("End v6.1 p1 ICD Update.")

 ; -----------------------------------------------------

ADDOK D RSLT($J("",5)_"Added : "_L)

ADDFAIL D RSLT($J("",5)_$$M(0)_"ADD FAILED => "_L)

DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("")

DIE ;EP

 NEW @($P($T(SVARS),";",3))

 LOCK +(@(DIE_DA_")")):10 E  D RSLT($J("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.") S Y=1 Q

 D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR

E(L) Q $P($P($T(@L),";",3),":",1)

DIK NEW @($P($T(SVARS),";",3)) D ^DIK KILL DIK

FILE NEW @($P($T(SVARS),";",3)) K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC

M(%) Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")

MODOK D RSLT($J("",5)_"Changed : "_L)

RSLT(%) S ^(0)=$G(^TMP("AUM2104",$J,0))+1,^(^(0))=% D MES(%)

MES(%) NEW @($P($T(SVARS),";",3)) D MES^XPDUTL(%)

IXDIC(DIC,DIC0,D,X,DLAYGO,DINUM) ;EP

 NEW @($P($T(SVARS),";",3))

 S DIC(0)=DIC0

 KILL DIC0

 I '$G(DLAYGO) KILL DLAYGO

 D IX^DIC

Q Y

 ; -----------------------------------------------------

ICD9REV ;

 D RSLT($$E("ICD9REVC"))

 D RSLT($J("",8)_"CODE      REVISION")

 D RSLT($J("",8)_"----      ------------")

 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 F AUMI=1:1 S AUMLN=$P($T(ICD9REVC+AUMI),";;",2) Q:AUMLN="END"  D PROCESS

 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 F AUMI=1:1 S AUMLN=$P($T(ICD9REV2+AUMI),";;",2) Q:AUMLN="END"  D

 .S Y=$$IXDIC("^ICD9(","IX","AB",$P(AUMLN,U),80)

 .I Y=-1 D RSLT("ERROR:  Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q

 .S DA=+Y

 .S DR="3////"_$P(AUMLN,U,2)  ;diagnosis

 .I $P(AUMLN,U,3)'="" S DR=DR_";10////"_$P(AUMLN,U,3)  ;description

 .S DIE="^ICD9("

 .S AUMDA=DA

 .D DIE

 .I $D(Y) D RSLT("ERROR:  Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q

 .D RSLT($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))

PROCESS S Y=$$IXDIC("^ICD9(","IX","AB",$P(AUMLN,U),80)

 I Y=-1 D RSLT("ERROR:  Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q

 S DA=+Y

 S DR=".01////"_$P(AUMLN,U,2)

 I $P(AUMLN,U,3)'="" S DR=DR_";3////"_$P(AUMLN,U,3)  ;diagnosis

 I $P(AUMLN,U,4)'="" S DR=DR_";10////"_$P(AUMLN,U,4)  ;description

 S DIE="^ICD9("

 S AUMDA=DA

 D DIE

 I $D(Y) D RSLT("ERROR:  Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q

 D RSLT($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))

 ; -----------------------------------------------------

ICD0REV ;

 D RSLT($$E("ICD0REVC"))

 D RSLT($J("",8)_"CODE      DESCRIPTION")

 D RSLT($J("",8)_"----      -----------")

 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 F AUMI=1:1 S AUMLN=$P($T(ICD0REVC+AUMI),";;",2) Q:AUMLN="END"  D

 . S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 . S Y=$$IXDIC("^ICD0(","IX","AB",$P(AUMLN,U))

 . I Y=-1 D RSLT("ERROR:  Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q

 . S DA=+Y

 . S DR="10///"_$P(AUMLN,U,2)         ;description

 . S DIE="^ICD0("

 . S AUMDA=DA

 . D DIE

 . I $D(Y) D RSLT("ERROR:  Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q

 . D RSLT($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))

.Q

PRNT ;;

 S U="^"

 W !," CODE",?10,"DIAGNOSIS",!?10,"DESCRIPTION",!," -----",?10,"-----------"

 NEW X,Y,P2,P3

 F X=1:1 S Y=$P($T(ICD9NEW+X),";;",3),P2=$P(Y,U,2),P3=$P(Y,U,3) Q:Y="END"  W !," ",$P(Y,U,1),?10,$S($L(P3):P3,1:P2),!?10,P2

ICD9REVC ;;ICD 9 DIAGNOSIS, REVISED CODES: OLD CODE NUMBER (#.01)^CODE NUMBER(#.01)

 ;;259.50^259.5

 ;;327.80^327.8

 ;;585.10^585.1

 ;;585.20^585.2

 ;;585.30^585.3

 ;;585.40^585.4

 ;;585.50^585.5

 ;;585.60^585.6

 ;;585.90^585.9

 ;;V18.90^V18.9

 ;;V69.50^V69.5

 ;;V85.00^V85.0

 ;;V85.10^V85.1

 ;;V85.40^V85.4

 ;;END

ICD9REV2 ;;CODE^DIAGNOSIS^DESCRIPTION

 ;;567.89^OTHER SPECIFIED PERITONITIS^OTHER SPECIFIED PERITONITIS

 ;;599.69^URINARY OBSTRUCTION, NEC

 ;;259.5^ANDROGEN INSENSITIVITY SYNDRME^ANDROGEN INSENSITIVITY SYNDROME

 ;;END

ICD0REVC ;;ICD 0 PROCEDURE, REVISED CODES: CODE NUMBER(#.01)^DESCRIPTION(#10)

 ;;86.94^Insertion or replacement of single array neurostimulator pulse generator, not specified as rechargeable

 ;;86.95^Insertion or replacement of dual array neurostimulator pulse generator, not specified as rechargeable

 ;;END

AUM61P1   ;IHS/ASDST/DMJ,SDR - ICD9 MODS TO CODES FOR FY 2006 ; [ 08/18/2003  11:02 AM ]

 +1       ;;06.1;TABLE MAINTENANCE;**1**;SEP 28,2001

 +2       ;

START     ;EP

 +1       ;

SVARS     ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables.

 +1       ;

 +2        NEW DA,DIC,DIE,DINUM,DLAYGO,DR,@($PIECE($TEXT(SVARS),";",3))

 +3        SET U="^"

 +4       ;

 +5        DO RSLT("Beginning v6.1 p1 ICD Update.")

 +6        DO DASH

           DO ICD9REV

 +7        DO DASH

           DO ICD0REV

 +8        DO RSLT("End v6.1 p1 ICD Update.")

 +9        QUIT

 +10      ; -----------------------------------------------------

ADDOK      DO RSLT($JUSTIFY("",5)_"Added : "_L)

 +1        QUIT

ADDFAIL    DO RSLT($JUSTIFY("",5)_$$M(0)_"ADD FAILED => "_L)

 +1        QUIT

DASH       DO RSLT("")

           DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))

           DO RSLT("")

 +1        QUIT

DIE       ;EP

 +1        NEW @($PIECE($TEXT(SVARS),";",3))

 +2        LOCK +(@(DIE_DA_")")):10

          IF '$TEST

               DO RSLT($JUSTIFY("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED.  NOTIFY PROGRAMMER.")

               SET Y=1

               QUIT

 +3        DO ^DIE

           LOCK -(@(DIE_DA_")"))

           KILL DA,DIE,DR

 +4        QUIT

E(L)       QUIT $PIECE($PIECE($TEXT(@L),";",3),":",1)

DIK        NEW @($PIECE($TEXT(SVARS),";",3))

           DO ^DIK

           KILL DIK

 +1        QUIT

FILE       NEW @($PIECE($TEXT(SVARS),";",3))

           KILL DD,DO

           SET DIC(0)="L"

           DO FILE^DICN

           KILL DIC

 +1        QUIT

M(%)       QUIT $SELECT(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")

MODOK      DO RSLT($JUSTIFY("",5)_"Changed : "_L)

 +1        QUIT

RSLT(%)    SET ^(0)=$GET(^TMP("AUM2104",$JOB,0))+1

           SET ^(^(0))=%

           DO MES(%)

 +1        QUIT

MES(%)     NEW @($PIECE($TEXT(SVARS),";",3))

           DO MES^XPDUTL(%)

 +1        QUIT

IXDIC(DIC,DIC0,D,X,DLAYGO,DINUM) ;EP

 +1        NEW @($PIECE($TEXT(SVARS),";",3))

 +2        SET DIC(0)=DIC0

 +3        KILL DIC0

 +4        IF '$GET(DLAYGO)

               KILL DLAYGO

 +5        DO IX^DIC

 +6        QUIT Y

 +7       ; -----------------------------------------------------

ICD9REV   ;

 +1        DO RSLT($$E("ICD9REVC"))

 +2        DO RSLT($JUSTIFY("",8)_"CODE      REVISION")

 +3        DO RSLT($JUSTIFY("",8)_"----      ------------")

 +4        NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 +5        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9REVC+AUMI),";;",2)

               IF AUMLN="END"

                   QUIT

               DO PROCESS

 +6        NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 +7        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9REV2+AUMI),";;",2)

               IF AUMLN="END"

                   QUIT

               Begin DoDot:1

 +8                SET Y=$$IXDIC("^ICD9(","IX","AB",$PIECE(AUMLN,U),80)

 +9                IF Y=-1

                       DO RSLT("ERROR:  Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")

                       QUIT

 +10               SET DA=+Y

 +11      ;diagnosis

                   SET DR="3////"_$PIECE(AUMLN,U,2)

 +12      ;description

                   IF $PIECE(AUMLN,U,3)'=""

                       SET DR=DR_";10////"_$PIECE(AUMLN,U,3)

 +13               SET DIE="^ICD9("

 +14               SET AUMDA=DA

 +15               DO DIE

 +16               IF $DATA(Y)

                       DO RSLT("ERROR:  Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")

                       QUIT

 +17               DO RSLT($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))

               End DoDot:1

 +18       QUIT

 +19      ;

PROCESS    SET Y=$$IXDIC("^ICD9(","IX","AB",$PIECE(AUMLN,U),80)

 +1        IF Y=-1

               DO RSLT("ERROR:  Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")

               QUIT

 +2        SET DA=+Y

 +3        SET DR=".01////"_$PIECE(AUMLN,U,2)

 +4       ;diagnosis

           IF $PIECE(AUMLN,U,3)'=""

               SET DR=DR_";3////"_$PIECE(AUMLN,U,3)

 +5       ;description

           IF $PIECE(AUMLN,U,4)'=""

               SET DR=DR_";10////"_$PIECE(AUMLN,U,4)

 +6        SET DIE="^ICD9("

 +7        SET AUMDA=DA

 +8        DO DIE

 +9        IF $DATA(Y)

               DO RSLT("ERROR:  Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")

               QUIT

 +10       DO RSLT($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))

 +11       QUIT

 +12      ; -----------------------------------------------------

ICD0REV   ;

 +1        DO RSLT($$E("ICD0REVC"))

 +2        DO RSLT($JUSTIFY("",8)_"CODE      DESCRIPTION")

 +3        DO RSLT($JUSTIFY("",8)_"----      -----------")

 +4        NEW AUMDA,AUMI,AUMLN,DA,DIE,DR

 +5        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD0REVC+AUMI),";;",2)

               IF AUMLN="END"

                   QUIT

               Begin DoDot:1

 +6                SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 +7                SET Y=$$IXDIC("^ICD0(","IX","AB",$PIECE(AUMLN,U))

 +8                IF Y=-1

                       DO RSLT("ERROR:  Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")

                       QUIT

 +9                SET DA=+Y

 +10      ;description

                   SET DR="10///"_$PIECE(AUMLN,U,2)

 +11               SET DIE="^ICD0("

 +12               SET AUMDA=DA

 +13               DO DIE

 +14               IF $DATA(Y)

                       DO RSLT("ERROR:  Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")

                       QUIT

 +15               DO RSLT($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))

 +16               QUIT

               End DoDot:1

 +17       QUIT

PRNT      ;;

 +1        SET U="^"

 +2        WRITE !," CODE",?10,"DIAGNOSIS",!?10,"DESCRIPTION",!," -----",?10,"-----------"

 +3        NEW X,Y,P2,P3

 +4        FOR X=1:1

               SET Y=$PIECE($TEXT(ICD9NEW+X),";;",3)

               SET P2=$PIECE(Y,U,2)

               SET P3=$PIECE(Y,U,3)

               IF Y="END"

                   QUIT

               WRITE !," ",$PIECE(Y,U,1),?10,$SELECT($LENGTH(P3):P3,1:P2),!?10,P2

 +5        QUIT

ICD9REVC  ;;ICD 9 DIAGNOSIS, REVISED CODES: OLD CODE NUMBER (#.01)^CODE NUMBER(#.01)

 +1       ;;259.50^259.5

 +2       ;;327.80^327.8

 +3       ;;585.10^585.1

 +4       ;;585.20^585.2

 +5       ;;585.30^585.3

 +6       ;;585.40^585.4

 +7       ;;585.50^585.5

 +8       ;;585.60^585.6

 +9       ;;585.90^585.9

 +10      ;;V18.90^V18.9

 +11      ;;V69.50^V69.5

 +12      ;;V85.00^V85.0

 +13      ;;V85.10^V85.1

 +14      ;;V85.40^V85.4

 +15      ;;END

ICD9REV2  ;;CODE^DIAGNOSIS^DESCRIPTION

 +1       ;;567.89^OTHER SPECIFIED PERITONITIS^OTHER SPECIFIED PERITONITIS

 +2       ;;599.69^URINARY OBSTRUCTION, NEC

 +3       ;;259.5^ANDROGEN INSENSITIVITY SYNDRME^ANDROGEN INSENSITIVITY SYNDROME

 +4       ;;END

ICD0REVC  ;;ICD 0 PROCEDURE, REVISED CODES: CODE NUMBER(#.01)^DESCRIPTION(#10)

 +1       ;;86.94^Insertion or replacement of single array neurostimulator pulse generator, not specified as rechargeable

 +2       ;;86.95^Insertion or replacement of dual array neurostimulator pulse generator, not specified as rechargeable

 +3       ;;END

AUM61P1.m