AUM91RL ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2009 ; [ 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^AUM91RL1("Beginning AUM*9.1 RELOAD, ICD Update.")
D DRGS^AUM91E ;update DRGs
D DASH^AUM91RL1,ICD9NEW
D DASH^AUM91RL1,ICD9REV
D DASH^AUM91RL1,ICD9INAC
D DASH^AUM91RL1,ICD0NEW
D DASH^AUM91RL1,ICD0REV
D DASH^AUM91RL1,ICD0INAC
;D DASH^AUM91RL1,ICD9OREV
;D DASH^AUM91RL1,ICD0OREV
D DASH^AUM91RL1
D RSLT^AUM91RL1("End AUM*9.1 RELOAD ICD Update.")
Q
; ---------------------------------
ICD9NEW ;
D RSLT^AUM91RL1("ICD 9 DIAGNOSIS, NEW CODES:") ;("ICD9NEW")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
; loads new ICD9 CODES
NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
F AUMI=1:1 S AUMLN=$P($T(ICD9NEW+AUMI^AUM91A),";;",2) Q:AUMLN="END" D ICD9NPRC
F AUMI=1:1 S AUMLN=$P($T(ICD9NEW2+AUMI^AUM91E),";;",2) Q:AUMLN="END" D ICD9NPRC
F AUMI=1:1 S AUMLN=$P($T(ICD9NEW3+AUMI^AUM91F),";;",2) Q:AUMLN="END" D ICD9NPRC
D NEWVCODS
Q
ICD9NPRC ;
S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(AUMLN,U),80)
I Y=-1 D RSLT^AUM91RL1("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///3081001" ;date added
S DR=DR_";16///3081001" ;activation date
;
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^AUM91RL1
;
;effective date multiple
D EFFDTMUL("NEW")
;diagnosis multiple
D SDSCMULT("NEW")
;description multiple
D DESCMULT("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^AUM91RL1
F AUMJ=AUMJ:1:5 D
.S DR=60+(AUMJ)_"////@"
.S DA=AUMDA
.S DIE="^ICD9("
.D DIE^AUM91RL1
I $D(Y) D RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q
D RSLT^AUM91RL1($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^AUM91RL1
D RSLT^AUM91RL1("ICD 9 DIAGNOSIS, NEW V-CODES:") ;("ICD9VNEW")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
F AUMI=1:1 S AUMLN=$P($T(ICD9VNEW+AUMI^AUM91E),";;",2) Q:AUMLN="END" D
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(AUMLN,U),80)
.I Y=-1 D RSLT^AUM91RL1("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///3081001" ;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^AUM91RL1
.;
.;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^AUM91RL1
.I $D(Y)!$G(AUMFLG) D RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q
.D RSLT^AUM91RL1($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))
.Q
;loads new E-CODES
D DASH^AUM91RL1
D RSLT^AUM91RL1("ICD 9, NEW/REVISED E-CODES:") ;("ICD9ENEW")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
F AUMI=1:1 S AUMLN=$P($T(ICD9ENEW+AUMI^AUM91B),";;",2) Q:AUMLN="END" D
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(AUMLN,U),80)
.I Y=-1 D RSLT^AUM91RL1("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///3081001" ;date added
.S DR=DR_";9.5///"_$P(AUMLN,U,4) ;use with sex
.S DIE="^ICD9("
.S AUMDA=DA
.D DIE^AUM91RL1
.;
.;effective date multiple
.K AUMFLG
.D EFFDTMUL("NEW")
.;diagnosis multiple
.D SDSCMULT("NEW")
.;description multiple
.D DESCMULT("NEW")
.;
.I $G(AUMFLG) D RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q
.D RSLT^AUM91RL1($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))
.Q
Q
;
ICD9INAC ;
D RSLT^AUM91RL1("ICD 9 DIAGNOSIS, INACTIVE CODES:") ;("ICD9DINA")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMI,DA,DIE,DR,X
F AUMI=1:1 S X=$P($T(ICD9DINA+AUMI^AUM91D),";;",2) Q:X="END" D
.S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(X,U)_" ")
.I Y=-1 D RSLT^AUM91RL1(" CODE '"_X_"' not found (that's OK).") Q
.S DA=+Y,AUMDA=+Y
.S DIE="^ICD9("
.S DR="102///3081001" ;inactive date
.S DR=DR_";100////1" ;inactive flag
.D DIE^AUM91RL1
.;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="3081001" ;use active date of 10/01/2008
.S DIC("DR")=".02////0"
.D ^DIC
.I $G(AUMFLG) D RSLT^AUM91RL1("ERROR: Edit of INACTIVE DATE field for CODE '"_$P(X,U)_"' FAILED.") Q
.D RSLT^AUM91RL1($J("",8)_$P(^ICD9(AUMDA,0),U,1)_$J("",4)_$E($P(^ICD9(AUMDA,0),U,3),1,30))
.Q
Q
;
ICD9OINA ;
D RSLT^AUM91RL1("ICD 9 DIAGNOSIS, OTHER INACTIVATED CODES:") ;("ICD9OINA")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMI,DA,DIE,DR,X
F AUMI=1:1 S X=$P($T(ICD9OINA+AUMI^AUM91D),";;",2) Q:X="END" D
.S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(X,U))
.I Y=-1 D RSLT^AUM91RL1(" CODE '"_X_"' not found (that's OK).") Q
.S DA=+Y,AUMDA=+Y
.S DIE="^ICD9("
.S DR="102///3081001" ;inactive date
.S DR=DR_";100////1" ;inactive flag
.D DIE^AUM91RL1
.;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="3081001" ;use active date of 10/01/2008
.S DIC("DR")=".02////0"
.D ^DIC
.I $D(Y) D RSLT^AUM91RL1("ERROR: Edit of INACTIVE DATE field for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q
.D RSLT^AUM91RL1($J("",8)_$P(^ICD9(AUMDA,0),U,1)_$J("",4)_$E($P(^ICD9(AUMDA,0),U,3),1,30))
.Q
Q
;
ICD9REV ;
D RSLT^AUM91RL1("ICD9REV")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
F AUMI=1:1 S AUMLN=$P($T(ICD9REV+AUMI^AUM91C),";;",2) Q:AUMLN="END" D PROCESS
Q
;
PROCESS S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(AUMLN,U)_" ",80)
I Y=-1 D RSLT^AUM91RL1("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^AUM91RL1
;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^AUM91RL1
I $D(Y) D RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$P(AUMLN,U,1)_"' FAILED.") Q
D RSLT^AUM91RL1($J("",8)_$P(AUMLN,U,1)_$J("",4)_$E($P(AUMLN,U,2),1,30))
Q
;
ICD9OREV ;
D RSLT^AUM91RL1("ICD 9 DIAGNOSIS, OTHER MODIFIED CODE TITLES:") ;("ICD9OREV")
D RSLT^AUM91RL1($J("",8)_"CODE DESCRIPTION")
D RSLT^AUM91RL1($J("",8)_"---- -----------")
NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
F AUMI=1:1 S AUMLN=$P($T(ICD9OREV+AUMI^AUM91C),";;",2) Q:AUMLN="END" D
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$P(AUMLN,U),80)
.I Y=-1 D RSLT^AUM91RL1("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^AUM91RL1
;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=3081001) Q ;already has 10/01/2008 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="3081001" ;use active date of 10/01/2008
.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=3081001) Q ;already has 10/01/2008 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="3081001" ;use active date of 10/01/2008
.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=3081001) Q ;already has 10/01/2008 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="3081001" ;use active date of 10/01/2008
.S DIC("DR")="1////"_$P(AUMLN,U,2) ;diagnosis
.D ^DIC
Q
;
;
ICD0NEW ;
D ICD0NEW^AUM91RL2
Q
;
; -----------------------------------------------------
ICD0REV ;
D ICD0REV^AUM91RL2
Q
ICD0INAC ;
D ICD0INAC^AUM91RL2
Q
ICD0OREV ;
D ICD0OREV^AUM91RL2
Q
AUM91RL ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2009 ; [ 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^AUM91RL1("Beginning AUM*9.1 RELOAD, ICD Update.")
+4 ;update DRGs
DO DRGS^AUM91E
+5 DO DASH^AUM91RL1
DO ICD9NEW
+6 DO DASH^AUM91RL1
DO ICD9REV
+7 DO DASH^AUM91RL1
DO ICD9INAC
+8 DO DASH^AUM91RL1
DO ICD0NEW
+9 DO DASH^AUM91RL1
DO ICD0REV
+10 DO DASH^AUM91RL1
DO ICD0INAC
+11 ;D DASH^AUM91RL1,ICD9OREV
+12 ;D DASH^AUM91RL1,ICD0OREV
+13 DO DASH^AUM91RL1
+14 DO RSLT^AUM91RL1("End AUM*9.1 RELOAD ICD Update.")
+15 QUIT
+16 ; ---------------------------------
ICD9NEW ;
+1 ;("ICD9NEW")
DO RSLT^AUM91RL1("ICD 9 DIAGNOSIS, NEW CODES:")
+2 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM91RL1($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^AUM91A),";;",2)
IF AUMLN="END"
QUIT
DO ICD9NPRC
+7 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9NEW2+AUMI^AUM91E),";;",2)
IF AUMLN="END"
QUIT
DO ICD9NPRC
+8 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9NEW3+AUMI^AUM91F),";;",2)
IF AUMLN="END"
QUIT
DO ICD9NPRC
+9 DO NEWVCODS
+10 QUIT
ICD9NPRC ;
+1 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(AUMLN,U),80)
+3 IF Y=-1
DO RSLT^AUM91RL1("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///3081001"
+12 ;activation date
SET DR=DR_";16///3081001"
+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 SET DIE="^ICD9("
+17 SET AUMDA=DA
+18 DO DIE^AUM91RL1
+19 ;
+20 ;effective date multiple
+21 DO EFFDTMUL("NEW")
+22 ;diagnosis multiple
+23 DO SDSCMULT("NEW")
+24 ;description multiple
+25 DO DESCMULT("NEW")
+26 ;
+27 ; this part loads DRGs if there are any
+28 SET (AUMDRG,AUMDRGS,DR)=""
+29 SET AUMDRGS=$PIECE(AUMLN,U,6)
+30 IF $LENGTH(AUMDRGS,",")>0
Begin DoDot:1
+31 FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")
Begin DoDot:2
+32 SET AUMDRG=$TRANSLATE($PIECE(AUMDRGS,",",AUMJ)," ")
+33 SET DR=60+(AUMJ-1)_"///"_AUMDRG
+34 SET DA=AUMDA
+35 SET DIE="^ICD9("
+36 DO DIE^AUM91RL1
End DoDot:2
End DoDot:1
+37 FOR AUMJ=AUMJ:1:5
Begin DoDot:1
+38 SET DR=60+(AUMJ)_"////@"
+39 SET DA=AUMDA
+40 SET DIE="^ICD9("
+41 DO DIE^AUM91RL1
End DoDot:1
+42 IF $DATA(Y)
DO RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+43 DO RSLT^AUM91RL1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+44 ;remove any data in OTHER WORDS or TAXONOMY
+45 IF $DATA(^ICD9(AUMDA,9999999.21,0))
Begin DoDot:1
+46 SET AUMO=0
+47 FOR
SET AUMO=$ORDER(^ICD9(AUMDA,9999999.21,AUMO))
IF +AUMO=0
QUIT
Begin DoDot:2
+48 SET DA(1)=AUMDA
+49 SET DA=AUMO
+50 SET DIK="^ICD9("_DA(1)_",9999999.21,"
+51 DO ^DIK
End DoDot:2
End DoDot:1
+52 IF $DATA(^ICD9(AUMDA,9999999.41,0))
Begin DoDot:1
+53 SET AUMO=0
+54 FOR
SET AUMO=$ORDER(^ICD9(AUMDA,9999999.41,AUMO))
IF +AUMO=0
QUIT
Begin DoDot:2
+55 SET DA(1)=AUMDA
+56 SET DA=AUMO
+57 SET DIK="^ICD9("_DA(1)_",9999999.41,"
+58 DO ^DIK
End DoDot:2
End DoDot:1
+59 QUIT
NEWVCODS ; loads NEW V-CODES
+1 DO DASH^AUM91RL1
+2 ;("ICD9VNEW")
DO RSLT^AUM91RL1("ICD 9 DIAGNOSIS, NEW V-CODES:")
+3 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+4 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+5 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+6 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9VNEW+AUMI^AUM91E),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+7 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+8 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(AUMLN,U),80)
+9 IF Y=-1
DO RSLT^AUM91RL1("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///3081001"
+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^AUM91RL1
+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^AUM91RL1
End DoDot:3
End DoDot:2
+42 IF $DATA(Y)!$GET(AUMFLG)
DO RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+43 DO RSLT^AUM91RL1($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^AUM91RL1
+47 ;("ICD9ENEW")
DO RSLT^AUM91RL1("ICD 9, NEW/REVISED E-CODES:")
+48 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+49 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+50 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+51 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9ENEW+AUMI^AUM91B),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+52 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+53 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(AUMLN,U),80)
+54 IF Y=-1
DO RSLT^AUM91RL1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+55 SET DA=+Y
+56 ;diagnosis
SET DR="3///"_$PIECE(AUMLN,U,2)
+57 ;description
SET DR=DR_";10///"_$PIECE(AUMLN,U,3)
+58 ;inactive flag
SET DR=DR_";100///@"
+59 ;inactive date
SET DR=DR_";102///@"
+60 ;date added
SET DR=DR_";9999999.04///3081001"
+61 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+62 SET DIE="^ICD9("
+63 SET AUMDA=DA
+64 DO DIE^AUM91RL1
+65 ;
+66 ;effective date multiple
+67 KILL AUMFLG
+68 DO EFFDTMUL("NEW")
+69 ;diagnosis multiple
+70 DO SDSCMULT("NEW")
+71 ;description multiple
+72 DO DESCMULT("NEW")
+73 ;
+74 IF $GET(AUMFLG)
DO RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+75 DO RSLT^AUM91RL1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+76 QUIT
End DoDot:1
+77 QUIT
+78 ;
ICD9INAC ;
+1 ;("ICD9DINA")
DO RSLT^AUM91RL1("ICD 9 DIAGNOSIS, INACTIVE CODES:")
+2 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMI,DA,DIE,DR,X
+5 FOR AUMI=1:1
SET X=$PIECE($TEXT(ICD9DINA+AUMI^AUM91D),";;",2)
IF X="END"
QUIT
Begin DoDot:1
+6 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(X,U)_" ")
+7 IF Y=-1
DO RSLT^AUM91RL1(" 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///3081001"
+11 ;inactive flag
SET DR=DR_";100////1"
+12 DO DIE^AUM91RL1
+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/2008
SET X="3081001"
+21 SET DIC("DR")=".02////0"
+22 DO ^DIC
+23 IF $GET(AUMFLG)
DO RSLT^AUM91RL1("ERROR: Edit of INACTIVE DATE field for CODE '"_$PIECE(X,U)_"' FAILED.")
QUIT
+24 DO RSLT^AUM91RL1($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^AUM91RL1("ICD 9 DIAGNOSIS, OTHER INACTIVATED CODES:")
+2 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMI,DA,DIE,DR,X
+5 FOR AUMI=1:1
SET X=$PIECE($TEXT(ICD9OINA+AUMI^AUM91D),";;",2)
IF X="END"
QUIT
Begin DoDot:1
+6 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(X,U))
+7 IF Y=-1
DO RSLT^AUM91RL1(" 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///3081001"
+11 ;inactive flag
SET DR=DR_";100////1"
+12 DO DIE^AUM91RL1
+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/2008
SET X="3081001"
+20 SET DIC("DR")=".02////0"
+21 DO ^DIC
+22 IF $DATA(Y)
DO RSLT^AUM91RL1("ERROR: Edit of INACTIVE DATE field for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+23 DO RSLT^AUM91RL1($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^AUM91RL1("ICD9REV")
+2 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+5 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9REV+AUMI^AUM91C),";;",2)
IF AUMLN="END"
QUIT
DO PROCESS
+6 QUIT
+7 ;
PROCESS SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+1 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(AUMLN,U)_" ",80)
+2 IF Y=-1
DO RSLT^AUM91RL1("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^AUM91RL1
+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^AUM91RL1
End DoDot:2
End DoDot:1
+40 IF $DATA(Y)
DO RSLT^AUM91RL1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+41 DO RSLT^AUM91RL1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+42 QUIT
+43 ;
ICD9OREV ;
+1 ;("ICD9OREV")
DO RSLT^AUM91RL1("ICD 9 DIAGNOSIS, OTHER MODIFIED CODE TITLES:")
+2 DO RSLT^AUM91RL1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM91RL1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+5 FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9OREV+AUMI^AUM91C),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+6 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 SET Y=$$IXDIC^AUM91RL1("^ICD9(","ILX","AB",$PIECE(AUMLN,U),80)
+8 IF Y=-1
DO RSLT^AUM91RL1("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^AUM91RL1
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/2008 entry
IF AUMX="REV"
IF (AUMLDT=3081001)
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/2008
SET X="3081001"
+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/2008 entry
IF AUMX="REV"
IF (AUMLDT=3081001)
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/2008
SET X="3081001"
+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/2008 entry
IF AUMX="REV"
IF (AUMLDT=3081001)
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/2008
SET X="3081001"
+16 ;diagnosis
SET DIC("DR")="1////"_$PIECE(AUMLN,U,2)
+17 DO ^DIC
End DoDot:1
+18 QUIT
+19 ;
+20 ;
ICD0NEW ;
+1 DO ICD0NEW^AUM91RL2
+2 QUIT
+3 ;
+4 ; -----------------------------------------------------
ICD0REV ;
+1 DO ICD0REV^AUM91RL2
+2 QUIT
ICD0INAC ;
+1 DO ICD0INAC^AUM91RL2
+2 QUIT
ICD0OREV ;
+1 DO ICD0OREV^AUM91RL2
+2 QUIT
