AUM101RL.m

AUM101RL ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2010 ; [ 08/18/2003  11:02 AM ]

 ;;10.2;TABLE MAINTENANCE;;MAR 09, 2010

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^AUM101R1("Beginning AUM 10.1 RELOAD, ICD Update.")

 D DRGS^AUM101E  ;update DRGs

 D DASH^AUM101R1,ICD9NEW

 D DASH^AUM101R1,ICD9REV

 D DASH^AUM101R1,ICD9INAC

 D DASH^AUM101R1,ICD0NEW

 D DASH^AUM101R1,ICD0REV

 D DASH^AUM101R1,ICD0INAC

 ;D DASH^AUM101R1,ICD9OREV

 ;D DASH^AUM101R1,ICD0OREV

 D DASH^AUM101R1

 D RSLT^AUM101R1("End AUM 10.1 RELOAD ICD Update.")

 Q

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

ICD9NEW ;

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, NEW CODES:")  ;("ICD9NEW")

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

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

 ;  loads new ICD9 CODES

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

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

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

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

 D NEWVCODS

 Q

ICD9NPRC ;

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

 S Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$P(AUMLN,U)_" ",80)

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

 S DA=+Y

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

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

 ;

 S DR=DR_";100////@"                               ;inactive flag

 S DR=DR_";102////@"                               ;inactive date

 ;

 S DR=DR_";9999999.04///3091001"       ;date added

 S DR=DR_";16///3091001"  ;activation date

 ;

 S DR=DR_";9.5///"_$P(AUMLN,U,4)        ;use with sex

 S DR=DR_";5///"_$P(AUMLN,U,5)           ;MDC

 I $P(AUMLN,U,7)=1 S DR=DR_";70///1"  ;complication/comorbidity

 S DIE="^ICD9("

 S AUMDA=DA

 D DIE^AUM101R1

 ;

 ;effective date multiple

 D EFFDTMUL("NEW")

 ;diagnosis multiple

 D SDSCMULT("NEW")

 ;description multiple

 D DESCMULT("NEW")

 ;MDC multiple

 D MDCMULT("NEW")

 ;CC multiple

 D CCMULT("NEW")

 ;

 ;  this part loads DRGs if there are any

 S (AUMDRG,AUMDRGS,DR)=""

 S AUMDRGS=$P(AUMLN,U,6)

 I $L(AUMDRGS,",")>0 D

 .F AUMJ=1:1:$L(AUMDRGS,",") D

 ..S AUMDRG=$TR($P(AUMDRGS,",",AUMJ)," ")

 ..S DR=60+(AUMJ-1)_"///"_AUMDRG

 ..S DA=AUMDA

 ..S DIE="^ICD9("

 ..D DIE^AUM101R1

 F AUMJ=AUMJ:1:5 D

 .S DR=60+(AUMJ)_"////@"

 .S DA=AUMDA

 .S DIE="^ICD9("

 .D DIE^AUM101R1

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

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

 ;remove any data in OTHER WORDS or TAXONOMY

 I $D(^ICD9(AUMDA,9999999.21,0)) D

 .S AUMO=0

 .F  S AUMO=$O(^ICD9(AUMDA,9999999.21,AUMO)) Q:+AUMO=0  D

 ..S DA(1)=AUMDA

 ..S DA=AUMO

 ..S DIK="^ICD9("_DA(1)_",9999999.21,"

 ..D ^DIK

 I $D(^ICD9(AUMDA,9999999.41,0)) D

 .S AUMO=0

 .F  S AUMO=$O(^ICD9(AUMDA,9999999.41,AUMO)) Q:+AUMO=0  D

 ..S DA(1)=AUMDA

 ..S DA=AUMO

 ..S DIK="^ICD9("_DA(1)_",9999999.41,"

 ..D ^DIK

 Q

NEWVCODS ;  loads NEW V-CODES

 D DASH^AUM101R1

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, NEW V-CODES:")  ;("ICD9VNEW")

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

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

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

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

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

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

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

 .S DA=+Y

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

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

 .;

 .S DR=DR_";100///@"   ;inactive flag

 .S DR=DR_";102///@"   ;inactive date

 .S DR=DR_";9999999.04///3091001"   ;date added

 .;

 .S DR=DR_";9.5///"_$P(AUMLN,U,4)   ;use with sex

 .S DR=DR_";5///"_$P(AUMLN,U,5)     ;MDC

 .S DIE="^ICD9("

 .S AUMDA=DA

 .D DIE^AUM101R1

 .;

 .;effective date multiple

 .K AUMFLG

 .D EFFDTMUL("NEW")

 .;diagnosis multiple

 .D SDSCMULT("NEW")

 .;description multiple

 .D DESCMULT("NEW")

 .;

 .;  this part loads the DRGs if there are any

 .S (AUMDRGS,DR)=""

 .S AUMDRGS=$P(AUMLN,U,6)

 .I $L(AUMDRGS,",")>0 D

 ..F AUMJ=1:1:$L(AUMDRGS,",") D

 ...S AUMDRG=$TR($P(AUMDRGS,",",AUMJ)," ")

 ...S DR=60+(AUMJ-1)_"///"_AUMDRG

 ...S DA=AUMDA

 ...S DIE="^ICD9("

 ...D DIE^AUM101R1

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

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

 .Q

 ;loads new E-CODES

 D DASH^AUM101R1

 D RSLT^AUM101R1("ICD 9, NEW/REVISED E-CODES:")  ;("ICD9ENEW")

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

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

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

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

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

 .;don't add space if E- or V-code; lookup fails

 .S Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$P(AUMLN,U)_$S($A($E($P(AUMLN,U)))<58:" ",1:""),80)

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

 .S DA=+Y

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

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

 .S DR=DR_";100///@"   ;inactive flag

 .S DR=DR_";102///@"   ;inactive date

 .S DR=DR_";9999999.04///3091001"   ;date added

 .S DR=DR_";9.5///"_$P(AUMLN,U,4)   ;use with sex

 .S DIE="^ICD9("

 .S AUMDA=DA

 .D DIE^AUM101R1

 .;

 .;effective date multiple

 .K AUMFLG

 .D EFFDTMUL("NEW")

 .;diagnosis multiple

 .D SDSCMULT("NEW")

 .;description multiple

 .D DESCMULT("NEW")

 .;

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

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

 .Q

 Q

 ;

ICD9INAC ;

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, INACTIVE CODES:")  ;("ICD9DINA")

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

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

 NEW AUMI,DA,DIE,DR,X

 F AUMI=1:1 S X=$P($T(ICD9DINA+AUMI^AUM101D),";;",2) Q:X="END"  D

 .S Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$P(X,U)_" ")

 .I Y=-1 D RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).") Q

 .S DA=+Y,AUMDA=+Y

 .S DIE="^ICD9("

 .S DR="102///3091001"  ;inactive date

 .S DR=DR_";100////1"  ;inactive flag

 .D DIE^AUM101R1

 .;effective date multiple

 .K AUMFLG

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",66,"

 .S DIC("P")=$P(^DD(80,66,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")=".02////0"

 .D ^DIC

 .I $G(AUMFLG) D RSLT^AUM101R1("ERROR:  Edit of INACTIVE DATE field for CODE '"_$P(X,U)_"' FAILED.") Q

 .D RSLT^AUM101R1($J("",8)_$P(^ICD9(AUMDA,0),U,1)_$J("",4)_$E($P(^ICD9(AUMDA,0),U,3),1,30))

 .Q

 Q

 ;

ICD9OINA ;

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, OTHER INACTIVATED CODES:")  ;("ICD9OINA")

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

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

 NEW AUMI,DA,DIE,DR,X

 F AUMI=1:1 S X=$P($T(ICD9OINA+AUMI^AUM101D),";;",2) Q:X="END"  D

 .S Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$P(X,U)_" ")

 .I Y=-1 D RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).") Q

 .S DA=+Y,AUMDA=+Y

 .S DIE="^ICD9("

 .S DR="102///3091001"  ;inactive date

 .S DR=DR_";100////1"  ;inactive flag

 .D DIE^AUM101R1

 .;effective date multiple

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",66,"

 .S DIC("P")=$P(^DD(80,66,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")=".02////0"

 .D ^DIC

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

 .D RSLT^AUM101R1($J("",8)_$P(^ICD9(AUMDA,0),U,1)_$J("",4)_$E($P(^ICD9(AUMDA,0),U,3),1,30))

 .Q

 Q

 ;

ICD9REV ;

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, MODIFIED CODES:")

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

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

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

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

 Q

 ;

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

 S Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$P(AUMLN,U)_$S($A($E($P(AUMLN,U)))<58:" ",1:""),80)

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

 S DA=+Y

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

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

 ;

 S DR=DR_";100///@"   ;inactive flag

 S DR=DR_";102///@"   ;inactive date

 S DR=DR_";2100000///"_DT   ;date updated

 ;

 S DR=DR_";9.5///"_$P(AUMLN,U,4)   ;use with sex

 S DR=DR_";5///"_$P(AUMLN,U,5)     ;MDC

 S DIE="^ICD9("

 S AUMDA=DA

 D DIE^AUM101R1

 ;effective date multiple

 D EFFDTMUL("REV")

 ;diagnosis multiple

 D SDSCMULT("REV")

 ;description multiple

 D DESCMULT("REV")

 ;

 ;clear DRGs in case there are less than before

 F AUMJ=60:1:65 D

 .S DIE="^ICD9("

 .S DA=AUMDA

 .S DR=AUMJ_"////@"

 .D ^DIE

 ;

 ;  this part loads the DRGs if there are any

 S (AUMDRGS,DR)=""

 S AUMDRGS=$P(AUMLN,U,6)

 I $L(AUMDRGS,",")>0 D

 .F AUMJ=1:1:$L(AUMDRGS,",") D

 ..S AUMDRG=$TR($P(AUMDRGS,",",AUMJ)," ")

 ..S DR=60+(AUMJ-1)_"///"_AUMDRG

 ..S DA=AUMDA

 ..S DIE="^ICD9("

 ..D DIE^AUM101R1

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

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

 Q

 ;

ICD9OREV ;

 D RSLT^AUM101R1("ICD 9 DIAGNOSIS, OTHER MODIFIED CODE TITLES:")  ;("ICD9OREV")

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

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

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

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

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

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

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

 .S DA=+Y

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

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

 .;

 .S DR=DR_";100///@"   ;inactive flag

 .S DR=DR_";102///@"   ;inactive date

 .S DR=DR_";2100000///"_DT   ;date updated

 .;

 .S DR=DR_";9.5///"_$P(AUMLN,U,4)   ;use with sex

 .S DR=DR_";5///"_$P(AUMLN,U,5)   ;MDC

 .S DIE="^ICD9("

 .S AUMDA=DA

 .D DIE^AUM101R1

 ;effective date multiple

 D EFFDTMUL("REV")

 ;diagnosis multiple

 D SDSCMULT("REV")

 ;description multiple

 D DESCMULT("REV")

 Q

 ;

 ;

EFFDTMUL(AUMX) ;

 ;effective date multiple

 S AUMLDT=0

 S AUMLDT=$O(^ICD9(AUMDA,66,"B",9999999),-1)  ;get last date in multiple

 I +AUMLDT>0 D  ;entry exists; check if status is correct (active)

 .S AUMMIEN=$O(^ICD9(AUMDA,66,"B",AUMLDT,0))

 .I +AUMMIEN=0 S AUMLDT=0 Q  ;quit if incomplete entry for some reason

 .I AUMX="REV",(AUMLDT=3091001) Q  ;already has 10/01/2009 entry

 .I $P($G(^ICD9(AUMDA,66,AUMMIEN,0)),U,2)=1 Q  ;already active

 .S AUMLDT=0  ;set date to zero so it will add entry

 I +AUMLDT=0 D  ;no entry or needs a new entry

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",66,"

 .S DIC("P")=$P(^DD(80,66,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")=".02////1"

 .D ^DIC

 Q

 ;

DESCMULT(AUMX) ;

 S AUMODESC=""

 S AUMLDT=0

 S AUMLDT=$O(^ICD9(AUMDA,68,"B",9999999),-1)

 I +AUMLDT>0 D  ;there is an entry

 .S AUMMIEN=$O(^ICD9(AUMDA,68,"B",AUMLDT,0))

 .I +AUMMIEN=0 S AUMLDT=0  Q

 .I AUMX="REV",(AUMLDT=3091001) Q  ;already has 10/01/2009 entry

 .I $P($G(^ICD9(AUMDA,68,AUMMIEN,0)),U)=$P(AUMLN,U,3) Q

 .S AUMLDT=0

 I +AUMLDT=0 D  ;no entry or needs a new entry

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",68,"

 .S DIC("P")=$P(^DD(80,68,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")="1////"_$P(AUMLN,U,3)  ;description

 .D ^DIC

 Q

 ;

SDSCMULT(AUMX) ;

 S AUMLDT=0

 S AUMLDT=$O(^ICD9(AUMDA,67,"B",9999999),-1)  ;get last entry

 I +AUMLDT>0 D  ;there is an entry

 .S AUMMIEN=$O(^ICD9(AUMDA,67,"B",AUMLDT,0))

 .I +AUMMIEN=0 S AUMLDT=0 Q  ;quit if incomplete entry

 .I AUMX="REV",(AUMLDT=3091001) Q  ;already has 10/01/2009 entry

 .I $P($G(^ICD0(AUMDA,67,AUMMIEN,0)),U,2)=$P(AUMLN,U,2) Q

 .S AUMLDT=0  ;set date to zero so it will add entry

 I +AUMLDT=0 D  ;no entry or needs a new entry

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",67,"

 .S DIC("P")=$P(^DD(80,67,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

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

 .D ^DIC

 Q

 ;

MDCMULT(AUMX) ;

 S AUMLDT=0

 S AUMLDT=$O(^ICD9(AUMDA,4,"B",9999999),-1)  ;get last entry

 I +AUMLDT>0 D  ;there is an entry

 .S AUMMIEN=$O(^ICD9(AUMDA,4,"B",AUMLDT,0))

 .I +AUMMIEN=0 S AUMLDT=0 Q  ;quit if incomplete entry

 .I AUMX="REV",(AUMLDT=3091001) Q  ;already has 10/01/2009 entry

 .I $P($G(^ICD0(AUMDA,4,AUMMIEN,0)),U,2)=$P(AUMLN,U,2) Q

 .S AUMLDT=0  ;set date to zero so it will add entry

 I +AUMLDT=0 D  ;no entry or needs a new entry

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",4,"

 .S DIC("P")=$P(^DD(80,72,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")="1////"_$P(AUMLN,U,5)  ;MDC

 .D ^DIC

 Q

 ;

CCMULT(AUMX) ;

 Q:$P(AUMLN,U,7)'=1  ;not cc

 S AUMLDT=0

 S AUMLDT=$O(^ICD9(AUMDA,69,"B",9999999),-1)  ;get last entry

 I +AUMLDT>0 D  ;there is an entry

 .S AUMMIEN=$O(^ICD9(AUMDA,69,"B",AUMLDT,0))

 .I +AUMMIEN=0 S AUMLDT=0 Q  ;quit if incomplete entry

 .I AUMX="REV",(AUMLDT=3091001) Q  ;already has 10/01/2009 entry

 .I $P($G(^ICD0(AUMDA,69,AUMMIEN,0)),U,2)=$P(AUMLN,U,2) Q

 .S AUMLDT=0  ;set date to zero so it will add entry

 I +AUMLDT=0 D  ;no entry or needs a new entry

 .K DIC,DIE,DA,X,Y

 .S DA(1)=AUMDA

 .S DIC="^ICD9("_DA(1)_",69,"

 .S DIC("P")=$P(^DD(80,103,0),U,2)

 .S DIC(0)="L"

 .S X="3091001"  ;use active date of 10/01/2009

 .S DIC("DR")="1////1"  ;cc

 .D ^DIC

 Q

 ;

ICD0NEW ;

 D ICD0NEW^AUM101R2

 Q

 ;

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

ICD0REV ;

 D ICD0REV^AUM101R2

 Q

ICD0INAC ;

 D ICD0INAC^AUM101R2

 Q

ICD0OREV ;

 D ICD0OREV^AUM101R2

 Q

AUM101RL  ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2010 ; [ 08/18/2003  11:02 AM ]

 +1       ;;10.2;TABLE MAINTENANCE;;MAR 09, 2010

START     ;EP

 +1       ;

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

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

 +2        SET U="^"

 +3        DO RSLT^AUM101R1("Beginning AUM 10.1 RELOAD, ICD Update.")

 +4       ;update DRGs

           DO DRGS^AUM101E

 +5        DO DASH^AUM101R1

           DO ICD9NEW

 +6        DO DASH^AUM101R1

           DO ICD9REV

 +7        DO DASH^AUM101R1

           DO ICD9INAC

 +8        DO DASH^AUM101R1

           DO ICD0NEW

 +9        DO DASH^AUM101R1

           DO ICD0REV

 +10       DO DASH^AUM101R1

           DO ICD0INAC

 +11      ;D DASH^AUM101R1,ICD9OREV

 +12      ;D DASH^AUM101R1,ICD0OREV

 +13       DO DASH^AUM101R1

 +14       DO RSLT^AUM101R1("End AUM 10.1 RELOAD ICD Update.")

 +15       QUIT 

 +16      ; ---------------------------------

ICD9NEW   ;

 +1       ;("ICD9NEW")

           DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, NEW CODES:")

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

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

 +4       ;  loads new ICD9 CODES

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

 +6        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9NEW+AUMI^AUM101A),";;",2)

               IF AUMLN="END"

                   QUIT 

               DO ICD9NPRC

 +7        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9NEW2+AUMI^AUM101E),";;",2)

               IF AUMLN="END"

                   QUIT 

               DO ICD9NPRC

 +8        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9NEW3+AUMI^AUM101F),";;",2)

               IF AUMLN="END"

                   QUIT 

               DO ICD9NPRC

 +9        DO NEWVCODS

 +10       QUIT 

ICD9NPRC  ;

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

 +2        SET Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$PIECE(AUMLN,U)_" ",80)

 +3        IF Y=-1

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

               QUIT 

 +4        SET DA=+Y

 +5       ;diagnosis

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

 +6       ;description

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

 +7       ;

 +8       ;inactive flag

           SET DR=DR_";100////@"

 +9       ;inactive date

           SET DR=DR_";102////@"

 +10      ;

 +11      ;date added

           SET DR=DR_";9999999.04///3091001"

 +12      ;activation date

           SET DR=DR_";16///3091001"

 +13      ;

 +14      ;use with sex

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

 +15      ;MDC

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

 +16      ;complication/comorbidity

           IF $PIECE(AUMLN,U,7)=1

               SET DR=DR_";70///1"

 +17       SET DIE="^ICD9("

 +18       SET AUMDA=DA

 +19       DO DIE^AUM101R1

 +20      ;

 +21      ;effective date multiple

 +22       DO EFFDTMUL("NEW")

 +23      ;diagnosis multiple

 +24       DO SDSCMULT("NEW")

 +25      ;description multiple

 +26       DO DESCMULT("NEW")

 +27      ;MDC multiple

 +28       DO MDCMULT("NEW")

 +29      ;CC multiple

 +30       DO CCMULT("NEW")

 +31      ;

 +32      ;  this part loads DRGs if there are any

 +33       SET (AUMDRG,AUMDRGS,DR)=""

 +34       SET AUMDRGS=$PIECE(AUMLN,U,6)

 +35       IF $LENGTH(AUMDRGS,",")>0

               Begin DoDot:1

 +36               FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")

                       Begin DoDot:2

 +37                       SET AUMDRG=$TRANSLATE($PIECE(AUMDRGS,",",AUMJ)," ")

 +38                       SET DR=60+(AUMJ-1)_"///"_AUMDRG

 +39                       SET DA=AUMDA

 +40                       SET DIE="^ICD9("

 +41                       DO DIE^AUM101R1

                       End DoDot:2

               End DoDot:1

 +42       FOR AUMJ=AUMJ:1:5

               Begin DoDot:1

 +43               SET DR=60+(AUMJ)_"////@"

 +44               SET DA=AUMDA

 +45               SET DIE="^ICD9("

 +46               DO DIE^AUM101R1

               End DoDot:1

 +47       IF $DATA(Y)

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

               QUIT 

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

 +49      ;remove any data in OTHER WORDS or TAXONOMY

 +50       IF $DATA(^ICD9(AUMDA,9999999.21,0))

               Begin DoDot:1

 +51               SET AUMO=0

 +52               FOR 

                       SET AUMO=$ORDER(^ICD9(AUMDA,9999999.21,AUMO))

                       IF +AUMO=0

                           QUIT 

                       Begin DoDot:2

 +53                       SET DA(1)=AUMDA

 +54                       SET DA=AUMO

 +55                       SET DIK="^ICD9("_DA(1)_",9999999.21,"

 +56                       DO ^DIK

                       End DoDot:2

               End DoDot:1

 +57       IF $DATA(^ICD9(AUMDA,9999999.41,0))

               Begin DoDot:1

 +58               SET AUMO=0

 +59               FOR 

                       SET AUMO=$ORDER(^ICD9(AUMDA,9999999.41,AUMO))

                       IF +AUMO=0

                           QUIT 

                       Begin DoDot:2

 +60                       SET DA(1)=AUMDA

 +61                       SET DA=AUMO

 +62                       SET DIK="^ICD9("_DA(1)_",9999999.41,"

 +63                       DO ^DIK

                       End DoDot:2

               End DoDot:1

 +64       QUIT 

NEWVCODS  ;  loads NEW V-CODES

 +1        DO DASH^AUM101R1

 +2       ;("ICD9VNEW")

           DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, NEW V-CODES:")

 +3        DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE      DESCRIPTION")

 +4        DO RSLT^AUM101R1($JUSTIFY("",8)_"----      -----------")

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

 +6        FOR AUMI=1:1

               SET AUMLN=$PIECE($TEXT(ICD9VNEW+AUMI^AUM101E),";;",2)

               IF AUMLN="END"

                   QUIT 

               Begin DoDot:1

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

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

 +9                IF Y=-1

                       DO RSLT^AUM101R1("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

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

 +13      ;

 +14      ;inactive flag

                   SET DR=DR_";100///@"

 +15      ;inactive date

                   SET DR=DR_";102///@"

 +16      ;date added

                   SET DR=DR_";9999999.04///3091001"

 +17      ;

 +18      ;use with sex

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

 +19      ;MDC

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

 +20               SET DIE="^ICD9("

 +21               SET AUMDA=DA

 +22               DO DIE^AUM101R1

 +23      ;

 +24      ;effective date multiple

 +25               KILL AUMFLG

 +26               DO EFFDTMUL("NEW")

 +27      ;diagnosis multiple

 +28               DO SDSCMULT("NEW")