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.")
Q
; -----------------------------------------------------
ADDOK D RSLT($J("",5)_"Added : "_L)
Q
ADDFAIL D RSLT($J("",5)_$$M(0)_"ADD FAILED => "_L)
Q
DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("")
Q
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
Q
E(L) Q $P($P($T(@L),";",3),":",1)
DIK NEW @($P($T(SVARS),";",3)) D ^DIK KILL DIK
Q
FILE NEW @($P($T(SVARS),";",3)) K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC
Q
M(%) Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
MODOK D RSLT($J("",5)_"Changed : "_L)
Q
RSLT(%) S ^(0)=$G(^TMP("AUM2104",$J,0))+1,^(^(0))=% D MES(%)
Q
MES(%) NEW @($P($T(SVARS),";",3)) D MES^XPDUTL(%)
Q
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))
Q
;
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))
Q
; -----------------------------------------------------
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
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
Q
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
