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")
+29 ;description multiple
+30 DO DESCMULT("NEW")
+31 ;
+32 ; this part loads the DRGs if there are any
+33 SET (AUMDRGS,DR)=""
+34 SET AUMDRGS=$PIECE(AUMLN,U,6)
+35 IF $LENGTH(AUMDRGS,",")>0
Begin DoDot:2
+36 FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")
Begin DoDot:3
+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:3
End DoDot:2
+42 IF $DATA(Y)!$GET(AUMFLG)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+43 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+44 QUIT
End DoDot:1
+45 ;loads new E-CODES
+46 DO DASH^AUM101R1
+47 ;("ICD9ENEW")
DO RSLT^AUM101R1("ICD 9, NEW/REVISED E-CODES:")
+48 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+49 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+50 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+51 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9ENEW+AUMI^AUM101B),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+52 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+53 ;don't add space if E- or V-code; lookup fails
+54 SET Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$PIECE(AUMLN,U)_$SELECT($ASCII($EXTRACT($PIECE(AUMLN,U)))<58:" ",1:""),80)
+55 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+56 SET DA=+Y
+57 ;diagnosis
SET DR="3///"_$PIECE(AUMLN,U,2)
+58 ;description
SET DR=DR_";10///"_$PIECE(AUMLN,U,3)
+59 ;inactive flag
SET DR=DR_";100///@"
+60 ;inactive date
SET DR=DR_";102///@"
+61 ;date added
SET DR=DR_";9999999.04///3091001"
+62 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+63 SET DIE="^ICD9("
+64 SET AUMDA=DA
+65 DO DIE^AUM101R1
+66 ;
+67 ;effective date multiple
+68 KILL AUMFLG
+69 DO EFFDTMUL("NEW")
+70 ;diagnosis multiple
+71 DO SDSCMULT("NEW")
+72 ;description multiple
+73 DO DESCMULT("NEW")
+74 ;
+75 IF $GET(AUMFLG)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+76 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+77 QUIT
End DoDot:1
+78 QUIT
+79 ;
ICD9INAC ;
+1 ;("ICD9DINA")
DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, INACTIVE CODES:")
+2 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMI,DA,DIE,DR,X
+5 FOR AUMI=1:1
SET X=$PIECE($TEXT(ICD9DINA+AUMI^AUM101D),";;",2)
IF X="END"
QUIT
Begin DoDot:1
+6 SET Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$PIECE(X,U)_" ")
+7 IF Y=-1
DO RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).")
QUIT
+8 SET DA=+Y
SET AUMDA=+Y
+9 SET DIE="^ICD9("
+10 ;inactive date
SET DR="102///3091001"
+11 ;inactive flag
SET DR=DR_";100////1"
+12 DO DIE^AUM101R1
+13 ;effective date multiple
+14 KILL AUMFLG
+15 KILL DIC,DIE,DA,X,Y
+16 SET DA(1)=AUMDA
+17 SET DIC="^ICD9("_DA(1)_",66,"
+18 SET DIC("P")=$PIECE(^DD(80,66,0),U,2)
+19 SET DIC(0)="L"
+20 ;use active date of 10/01/2009
SET X="3091001"
+21 SET DIC("DR")=".02////0"
+22 DO ^DIC
+23 IF $GET(AUMFLG)
DO RSLT^AUM101R1("ERROR: Edit of INACTIVE DATE field for CODE '"_$PIECE(X,U)_"' FAILED.")
QUIT
+24 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(^ICD9(AUMDA,0),U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(^ICD9(AUMDA,0),U,3),1,30))
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
ICD9OINA ;
+1 ;("ICD9OINA")
DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, OTHER INACTIVATED CODES:")
+2 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMI,DA,DIE,DR,X
+5 FOR AUMI=1:1
SET X=$PIECE($TEXT(ICD9OINA+AUMI^AUM101D),";;",2)
IF X="END"
QUIT
Begin DoDot:1
+6 SET Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$PIECE(X,U)_" ")
+7 IF Y=-1
DO RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).")
QUIT
+8 SET DA=+Y
SET AUMDA=+Y
+9 SET DIE="^ICD9("
+10 ;inactive date
SET DR="102///3091001"
+11 ;inactive flag
SET DR=DR_";100////1"
+12 DO DIE^AUM101R1
+13 ;effective date multiple
+14 KILL DIC,DIE,DA,X,Y
+15 SET DA(1)=AUMDA
+16 SET DIC="^ICD9("_DA(1)_",66,"
+17 SET DIC("P")=$PIECE(^DD(80,66,0),U,2)
+18 SET DIC(0)="L"
+19 ;use active date of 10/01/2009
SET X="3091001"
+20 SET DIC("DR")=".02////0"
+21 DO ^DIC
+22 IF $DATA(Y)
DO RSLT^AUM101R1("ERROR: Edit of INACTIVE DATE field for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+23 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(^ICD9(AUMDA,0),U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(^ICD9(AUMDA,0),U,3),1,30))
+24 QUIT
End DoDot:1
+25 QUIT
+26 ;
ICD9REV ;
+1 DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, MODIFIED CODES:")
+2 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+5 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9REV+AUMI^AUM101C),";;",2)
IF AUMLN="END"
QUIT
DO PROCESS
+6 QUIT
+7 ;
PROCESS SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+1 SET Y=$$IXDIC^AUM101R1("^ICD9(","ILXM","AB",$PIECE(AUMLN,U)_$SELECT($ASCII($EXTRACT($PIECE(AUMLN,U)))<58:" ",1:""),80)
+2 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+3 SET DA=+Y
+4 ;diagnosis
SET DR="3///"_$PIECE(AUMLN,U,2)
+5 ;description
SET DR=DR_";10///"_$PIECE(AUMLN,U,3)
+6 ;
+7 ;inactive flag
SET DR=DR_";100///@"
+8 ;inactive date
SET DR=DR_";102///@"
+9 ;date updated
SET DR=DR_";2100000///"_DT
+10 ;
+11 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+12 ;MDC
SET DR=DR_";5///"_$PIECE(AUMLN,U,5)
+13 SET DIE="^ICD9("
+14 SET AUMDA=DA
+15 DO DIE^AUM101R1
+16 ;effective date multiple
+17 DO EFFDTMUL("REV")
+18 ;diagnosis multiple
+19 DO SDSCMULT("REV")
+20 ;description multiple
+21 DO DESCMULT("REV")
+22 ;
+23 ;clear DRGs in case there are less than before
+24 FOR AUMJ=60:1:65
Begin DoDot:1
+25 SET DIE="^ICD9("
+26 SET DA=AUMDA
+27 SET DR=AUMJ_"////@"
+28 DO ^DIE
End DoDot:1
+29 ;
+30 ; this part loads the DRGs if there are any
+31 SET (AUMDRGS,DR)=""
+32 SET AUMDRGS=$PIECE(AUMLN,U,6)
+33 IF $LENGTH(AUMDRGS,",")>0
Begin DoDot:1
+34 FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")
Begin DoDot:2
+35 SET AUMDRG=$TRANSLATE($PIECE(AUMDRGS,",",AUMJ)," ")
+36 SET DR=60+(AUMJ-1)_"///"_AUMDRG
+37 SET DA=AUMDA
+38 SET DIE="^ICD9("
+39 DO DIE^AUM101R1
End DoDot:2
End DoDot:1
+40 IF $DATA(Y)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+41 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+42 QUIT
+43 ;
ICD9OREV ;
+1 ;("ICD9OREV")
DO RSLT^AUM101R1("ICD 9 DIAGNOSIS, OTHER MODIFIED CODE TITLES:")
+2 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+5 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9OREV+AUMI^AUM101C),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+6 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 SET Y=$$IXDIC^AUM101R1("^ICD9(","ILX","AB",$PIECE(AUMLN,U)_" ",80)
+8 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+9 SET DA=+Y
+10 ;diagnosis
SET DR="3///"_$PIECE(AUMLN,U,2)
+11 ;description
SET DR=DR_";10///"_$PIECE(AUMLN,U,3)
+12 ;
+13 ;inactive flag
SET DR=DR_";100///@"
+14 ;inactive date
SET DR=DR_";102///@"
+15 ;date updated
SET DR=DR_";2100000///"_DT
+16 ;
+17 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+18 ;MDC
SET DR=DR_";5///"_$PIECE(AUMLN,U,5)
+19 SET DIE="^ICD9("
+20 SET AUMDA=DA
+21 DO DIE^AUM101R1
End DoDot:1
+22 ;effective date multiple
+23 DO EFFDTMUL("REV")
+24 ;diagnosis multiple
+25 DO SDSCMULT("REV")
+26 ;description multiple
+27 DO DESCMULT("REV")
+28 QUIT
+29 ;
+30 ;
EFFDTMUL(AUMX) ;
+1 ;effective date multiple
+2 SET AUMLDT=0
+3 ;get last date in multiple
SET AUMLDT=$ORDER(^ICD9(AUMDA,66,"B",9999999),-1)
+4 ;entry exists; check if status is correct (active)
IF +AUMLDT>0
Begin DoDot:1
+5 SET AUMMIEN=$ORDER(^ICD9(AUMDA,66,"B",AUMLDT,0))
+6 ;quit if incomplete entry for some reason
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+7 ;already has 10/01/2009 entry
IF AUMX="REV"
IF (AUMLDT=3091001)
QUIT
+8 ;already active
IF $PIECE($GET(^ICD9(AUMDA,66,AUMMIEN,0)),U,2)=1
QUIT
+9 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:1
+10 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:1
+11 KILL DIC,DIE,DA,X,Y
+12 SET DA(1)=AUMDA
+13 SET DIC="^ICD9("_DA(1)_",66,"
+14 SET DIC("P")=$PIECE(^DD(80,66,0),U,2)
+15 SET DIC(0)="L"
+16 ;use active date of 10/01/2009
SET X="3091001"
+17 SET DIC("DR")=".02////1"
+18 DO ^DIC
End DoDot:1
+19 QUIT
+20 ;
DESCMULT(AUMX) ;
+1 SET AUMODESC=""
+2 SET AUMLDT=0
+3 SET AUMLDT=$ORDER(^ICD9(AUMDA,68,"B",9999999),-1)
+4 ;there is an entry
IF +AUMLDT>0
Begin DoDot:1
+5 SET AUMMIEN=$ORDER(^ICD9(AUMDA,68,"B",AUMLDT,0))
+6 IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+7 ;already has 10/01/2009 entry
IF AUMX="REV"
IF (AUMLDT=3091001)
QUIT
+8 IF $PIECE($GET(^ICD9(AUMDA,68,AUMMIEN,0)),U)=$PIECE(AUMLN,U,3)
QUIT
+9 SET AUMLDT=0
End DoDot:1
+10 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:1
+11 KILL DIC,DIE,DA,X,Y
+12 SET DA(1)=AUMDA
+13 SET DIC="^ICD9("_DA(1)_",68,"
+14 SET DIC("P")=$PIECE(^DD(80,68,0),U,2)
+15 SET DIC(0)="L"
+16 ;use active date of 10/01/2009
SET X="3091001"
+17 ;description
SET DIC("DR")="1////"_$PIECE(AUMLN,U,3)
+18 DO ^DIC
End DoDot:1
+19 QUIT
+20 ;
SDSCMULT(AUMX) ;
+1 SET AUMLDT=0
+2 ;get last entry
SET AUMLDT=$ORDER(^ICD9(AUMDA,67,"B",9999999),-1)
+3 ;there is an entry
IF +AUMLDT>0
Begin DoDot:1
+4 SET AUMMIEN=$ORDER(^ICD9(AUMDA,67,"B",AUMLDT,0))
+5 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+6 ;already has 10/01/2009 entry
IF AUMX="REV"
IF (AUMLDT=3091001)
QUIT
+7 IF $PIECE($GET(^ICD0(AUMDA,67,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+8 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:1
+9 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:1
+10 KILL DIC,DIE,DA,X,Y
+11 SET DA(1)=AUMDA
+12 SET DIC="^ICD9("_DA(1)_",67,"
+13 SET DIC("P")=$PIECE(^DD(80,67,0),U,2)
+14 SET DIC(0)="L"
+15 ;use active date of 10/01/2009
SET X="3091001"
+16 ;diagnosis
SET DIC("DR")="1////"_$PIECE(AUMLN,U,2)
+17 DO ^DIC
End DoDot:1
+18 QUIT
+19 ;
MDCMULT(AUMX) ;
+1 SET AUMLDT=0
+2 ;get last entry
SET AUMLDT=$ORDER(^ICD9(AUMDA,4,"B",9999999),-1)
+3 ;there is an entry
IF +AUMLDT>0
Begin DoDot:1
+4 SET AUMMIEN=$ORDER(^ICD9(AUMDA,4,"B",AUMLDT,0))
+5 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+6 ;already has 10/01/2009 entry
IF AUMX="REV"
IF (AUMLDT=3091001)
QUIT
+7 IF $PIECE($GET(^ICD0(AUMDA,4,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+8 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:1
+9 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:1
+10 KILL DIC,DIE,DA,X,Y
+11 SET DA(1)=AUMDA
+12 SET DIC="^ICD9("_DA(1)_",4,"
+13 SET DIC("P")=$PIECE(^DD(80,72,0),U,2)
+14 SET DIC(0)="L"
+15 ;use active date of 10/01/2009
SET X="3091001"
+16 ;MDC
SET DIC("DR")="1////"_$PIECE(AUMLN,U,5)
+17 DO ^DIC
End DoDot:1
+18 QUIT
+19 ;
CCMULT(AUMX) ;
+1 ;not cc
IF $PIECE(AUMLN,U,7)'=1
QUIT
+2 SET AUMLDT=0
+3 ;get last entry
SET AUMLDT=$ORDER(^ICD9(AUMDA,69,"B",9999999),-1)
+4 ;there is an entry
IF +AUMLDT>0
Begin DoDot:1
+5 SET AUMMIEN=$ORDER(^ICD9(AUMDA,69,"B",AUMLDT,0))
+6 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+7 ;already has 10/01/2009 entry
IF AUMX="REV"
IF (AUMLDT=3091001)
QUIT
+8 IF $PIECE($GET(^ICD0(AUMDA,69,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+9 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:1
+10 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:1
+11 KILL DIC,DIE,DA,X,Y
+12 SET DA(1)=AUMDA
+13 SET DIC="^ICD9("_DA(1)_",69,"
+14 SET DIC("P")=$PIECE(^DD(80,103,0),U,2)
+15 SET DIC(0)="L"
+16 ;use active date of 10/01/2009
SET X="3091001"
+17 ;cc
SET DIC("DR")="1////1"
+18 DO ^DIC
End DoDot:1
+19 QUIT
+20 ;
ICD0NEW ;
+1 DO ICD0NEW^AUM101R2
+2 QUIT
+3 ;
+4 ; -----------------------------------------------------
ICD0REV ;
+1 DO ICD0REV^AUM101R2
+2 QUIT
ICD0INAC ;
+1 DO ICD0INAC^AUM101R2
+2 QUIT
ICD0OREV ;
+1 DO ICD0OREV^AUM101R2
+2 QUIT
