AUM101R2 ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2010 ; [ 08/18/2003 11:02 AM ]
;;10.2;TABLE MAINTENANCE;;MAR 09, 2010
;
ICD0NEW ;
D RSLT^AUM101R1("ICD OPERATION/PROCEDURE, NEW PROCEDURE CODES:") ;ICD9PNEW
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(ICD9PNEW+AUMI^AUM101D),";;",2) Q:AUMLN="END" D
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$P(AUMLN,U))
.I Y=-1 D RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q
.S (DA,AUMIEN)=+Y
.S DR="4///"_$P(AUMLN,U,2) ;operation/procedure
.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_";12///3091001" ;activation date
.;
.S DR=DR_";9.5///"_$P(AUMLN,U,4) ;use with sex
.S DIE="^ICD0("
.S AUMDA=DA
.D DIE^AUM101R1
.;
.;effective date multiple
.K AUMFLG
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,66,"B",9999999),-1) ;get last date in multiple
.I +AUMLDT>0 D ;entry exists; check if status is correct (active)
..S AUMMIEN=$O(^ICD0(AUMIEN,66,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry for some reason
..I AUMLDT=3091001 Q ;already has 10/01/2009 entry
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",66,"
..S DIC("P")=$P(^DD(80.1,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
.;
.;operation/proc multiple
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,67,"B",9999999),-1) ;get last entry
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,67,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry
..I AUMLDT=3091001 Q ;already has 10/01/2009 entry
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",67,"
..S DIC("P")=$P(^DD(80.1,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) ;oper/proc
..D ^DIC
.;
.;description multiple
.S AUMODESC=""
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,68,"B",9999999),-1)
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,68,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q
..I AUMLDT=3091001 Q ;already has 10/01/2009 entry
..I $G(^ICD0(AUMIEN,68,AUMMIEN,1))=$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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",68,"
..S DIC("P")=$P(^DD(80.1,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
.;
.; loads MDC and DRGs if any
.S (AUMMANDD,AUMMDC,AUMDRGS)=""
.S AUMMANDD=$P(AUMLN,U,5)
.F AUMK=1:1:$L(AUMMANDD,"-") D
..S AUMREC=""
..S AUMREC=$P(AUMMANDD,"~",AUMK)
..S AUMMDC=$P(AUMREC,"-")
..S AUMDRGS=$P(AUMREC,"-",2)
..I $G(AUMMDC)'="" D
...K DIC,X,Y,DA
...S DA(1)=AUMDA
...S DIC="^ICD0("_DA(1)_",""MDC"","
...S DIC("P")=$P(^DD(80.1,7,0),U,2)
...S DIC(0)="LXI"
...S DLAYGO=80.1
...S X=AUMMDC
...D ^DIC
...I AUMDRGS="" K Y
...K DIC,DIE,X,DA
...I +$G(Y)>0,$G(AUMDRGS)'="" D
....F AUMJ=1:1:$L(AUMDRGS,",") D
.....S AUMDRG=$P(AUMDRGS,",",AUMJ)
.....S DR=AUMJ_"////"_AUMDRG
.....S DA(1)=AUMDA
.....S DA=AUMMDC
.....S DIE="^ICD0("_DA(1)_",""MDC"","
.....D DIE^AUM101R1
.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
;
; -----------------------------------------------------
ICD0REV ;
D RSLT^AUM101R1("ICD OPERATION/PROCEDURE, REVISED CODES:") ;("ICD9PREV")
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(ICD9PREV+AUMI^AUM101B),";;",2) Q:AUMLN="END" D ;IHS/SD/SDR 11/30/09 HEAT8884
F AUMI=1:1 S AUMLN=$P($T(ICD9PREV+AUMI^AUM101E),";;",2) Q:AUMLN="END" D ;IHS/SD/SDR 11/30/09 HEAT8884
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$P(AUMLN,U))
.I Y=-1 D RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q
.S DA=+Y
.S DR="4///"_$P(AUMLN,U,2) ;operation/procedure
.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 DIE="^ICD0("
.S AUMDA=DA
.D DIE^AUM101R1
.;
.;effective date multiple
.K AUMFLG
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,66,"B",9999999),-1) ;get last date in multiple
.I +AUMLDT>0 D ;entry exists; check if status is correct (active)
..S AUMMIEN=$O(^ICD0(AUMIEN,66,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry for some reason
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",66,"
..S DIC("P")=$P(^DD(80.1,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
..I Y<0 S AUMFLG=1
.;
.;operation/proc multiple
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,67,"B",9999999),-1) ;get last entry
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,67,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",67,"
..S DIC("P")=$P(^DD(80.1,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) ;oper/proc
..D ^DIC
..I Y<0 S AUMFLG=1
.;
.;description multiple
.S AUMODESC=""
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,68,"B",9999999),-1)
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,68,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",68,"
..S DIC("P")=$P(^DD(80.1,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
..I Y<0 S AUMFLG=1
.;
.;loads MDC and DRGs if any
.K ^ICD0(AUMDA,"MDC") ;clear existing entries
.S (AUMMANDD,AUMMDC,AUMDRGS)=""
.S AUMMANDD=$P(AUMLN,U,5)
.F AUMK=1:1:$L(AUMMANDD,"-") D
..S AUMREC=""
..S AUMREC=$P(AUMMANDD,"~",AUMK)
..S AUMMDC=$P(AUMREC,"-")
..S AUMDRGS=$P(AUMREC,"-",2)
..I $G(AUMMDC)'="" D
...S DIC="^ICD0("_AUMDA_",""MDC"","
...S DIC("P")=$P(^DD(80.1,7,0),U,2)
...S DA(1)=AUMDA
...S DIC(0)="LXI"
...S DLAYGO=80.1
...S X=AUMMDC
...D ^DIC
...I AUMDRGS="" K Y
...I +$G(Y)>0,$G(AUMDRGS)'="" D
....F AUMJ=1:1:$L(AUMDRGS,",") D
.....S AUMDRG=$P(AUMDRGS,",",AUMJ)
.....S DR=AUMJ_"///"_AUMDRG
.....S DA=AUMMDC
.....S DIE="^ICD0("_AUMDA_",""MDC"","
.....D DIE^AUM101R1
.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
ICD0INAC ;
D RSLT^AUM101R1("ICD 9 PROCEDURE, INACTIVE CODES:") ;("ICD9PINA")
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(ICD9PINA+AUMI^AUM101E),";;",2) Q:X="END" D
.S Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$P(X,U))
.I Y=-1 D RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).") Q
.S DA=+Y
.S DIE="^ICD0("
.S DR="102///3091001" ;inactive flag
.S AUMDA=DA
.D DIE^AUM101R1
.;
.K DIC,DIE,DA,X,Y
.S DA(1)=AUMIEN
.S DIC="^ICD0("_DA(1)_",66,"
.S DIC("P")=$P(^DD(80.1,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 Y<0 D RSLT^AUM101R1("ERROR: Edit of INACTIVE DATE field for CODE '"_$P(X,U,1)_"' FAILED.") Q
.D RSLT^AUM101R1($J("",8)_$P(^ICD0(AUMDA,0),U,1)_$J("",4)_$E($P(^ICD0(AUMDA,0),U,4),1,30))
.Q
Q
ICD0OREV ;
D RSLT^AUM101R1("ICD OPERATION/PROCEDURE, OTHER REVISED CODES:") ;("ICD0OREV")
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(ICD0OREV+AUMI^AUM101C),";;",2) Q:AUMLN="END" D
.S AUMLN=$TR(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.S Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$P(AUMLN,U))
.I Y=-1 D RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$P(AUMLN,U)_"' FAILED.") Q
.S DA=+Y
.S DR="4///"_$P(AUMLN,U,2) ;operation/procedure
.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 DIE="^ICD0("
.S AUMDA=DA
.D DIE^AUM101R1
.;
.;effective date multiple
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,66,"B",9999999),-1) ;get last date in multiple
.I +AUMLDT>0 D ;entry exists; check if status is correct (active)
..S AUMMIEN=$O(^ICD0(AUMIEN,66,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry for some reason
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",66,"
..S DIC("P")=$P(^DD(80.1,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
.;
.;operation/proc multiple
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,67,"B",9999999),-1) ;get last entry
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,67,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q ;quit if incomplete entry
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",67,"
..S DIC("P")=$P(^DD(80.1,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) ;oper/proc
..D ^DIC
.;
.;description multiple
.S AUMODESC=""
.S AUMLDT=0
.S AUMLDT=$O(^ICD0(AUMIEN,68,"B",9999999),-1)
.I +AUMLDT>0 D ;there is an entry
..S AUMMIEN=$O(^ICD0(AUMIEN,68,"B",AUMLDT,0))
..I +AUMMIEN=0 S AUMLDT=0 Q
..I $P($G(^ICD0(AUMIEN,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)=AUMIEN
..S DIC="^ICD0("_DA(1)_",68,"
..S DIC("P")=$P(^DD(80.1,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
.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
Q
AUM101R2 ;IHS/SD/DMJ,SDR - ICD 9 CODES FOR FY 2010 ; [ 08/18/2003 11:02 AM ]
+1 ;;10.2;TABLE MAINTENANCE;;MAR 09, 2010
+2 ;
ICD0NEW ;
+1 ;ICD9PNEW
DO RSLT^AUM101R1("ICD OPERATION/PROCEDURE, NEW PROCEDURE 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(ICD9PNEW+AUMI^AUM101D),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+6 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 SET Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$PIECE(AUMLN,U))
+8 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+9 SET (DA,AUMIEN)=+Y
+10 ;operation/procedure
SET DR="4///"_$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 ;
+16 ;date added
SET DR=DR_";9999999.04///3091001"
+17 ;activation date
SET DR=DR_";12///3091001"
+18 ;
+19 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+20 SET DIE="^ICD0("
+21 SET AUMDA=DA
+22 DO DIE^AUM101R1
+23 ;
+24 ;effective date multiple
+25 KILL AUMFLG
+26 SET AUMLDT=0
+27 ;get last date in multiple
SET AUMLDT=$ORDER(^ICD0(AUMIEN,66,"B",9999999),-1)
+28 ;entry exists; check if status is correct (active)
IF +AUMLDT>0
Begin DoDot:2
+29 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,66,"B",AUMLDT,0))
+30 ;quit if incomplete entry for some reason
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+31 ;already has 10/01/2009 entry
IF AUMLDT=3091001
QUIT
+32 ;already active
IF $PIECE($GET(^ICD0(AUMIEN,66,AUMMIEN,0)),U,2)=1
QUIT
+33 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+34 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+35 KILL DIC,DIE,DA,X,Y
+36 SET DA(1)=AUMIEN
+37 SET DIC="^ICD0("_DA(1)_",66,"
+38 SET DIC("P")=$PIECE(^DD(80.1,66,0),U,2)
+39 SET DIC(0)="L"
+40 ;use active date of 10/01/2009
SET X="3091001"
+41 SET DIC("DR")=".02////1"
+42 DO ^DIC
End DoDot:2
+43 ;
+44 ;operation/proc multiple
+45 SET AUMLDT=0
+46 ;get last entry
SET AUMLDT=$ORDER(^ICD0(AUMIEN,67,"B",9999999),-1)
+47 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+48 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,67,"B",AUMLDT,0))
+49 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+50 ;already has 10/01/2009 entry
IF AUMLDT=3091001
QUIT
+51 IF $PIECE($GET(^ICD0(AUMIEN,67,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+52 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+53 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+54 KILL DIC,DIE,DA,X,Y
+55 SET DA(1)=AUMIEN
+56 SET DIC="^ICD0("_DA(1)_",67,"
+57 SET DIC("P")=$PIECE(^DD(80.1,67,0),U,2)
+58 SET DIC(0)="L"
+59 ;use active date of 10/01/2009
SET X="3091001"
+60 ;oper/proc
SET DIC("DR")="1////"_$PIECE(AUMLN,U,2)
+61 DO ^DIC
End DoDot:2
+62 ;
+63 ;description multiple
+64 SET AUMODESC=""
+65 SET AUMLDT=0
+66 SET AUMLDT=$ORDER(^ICD0(AUMIEN,68,"B",9999999),-1)
+67 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+68 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,68,"B",AUMLDT,0))
+69 IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+70 ;already has 10/01/2009 entry
IF AUMLDT=3091001
QUIT
+71 IF $GET(^ICD0(AUMIEN,68,AUMMIEN,1))=$PIECE(AUMLN,U,3)
QUIT
+72 SET AUMLDT=0
End DoDot:2
+73 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+74 KILL DIC,DIE,DA,X,Y
+75 SET DA(1)=AUMIEN
+76 SET DIC="^ICD0("_DA(1)_",68,"
+77 SET DIC("P")=$PIECE(^DD(80.1,68,0),U,2)
+78 SET DIC(0)="L"
+79 ;use active date of 10/01/2009
SET X="3091001"
+80 ;description
SET DIC("DR")="1////"_$PIECE(AUMLN,U,3)
+81 DO ^DIC
End DoDot:2
+82 ;
+83 ; loads MDC and DRGs if any
+84 SET (AUMMANDD,AUMMDC,AUMDRGS)=""
+85 SET AUMMANDD=$PIECE(AUMLN,U,5)
+86 FOR AUMK=1:1:$LENGTH(AUMMANDD,"-")
Begin DoDot:2
+87 SET AUMREC=""
+88 SET AUMREC=$PIECE(AUMMANDD,"~",AUMK)
+89 SET AUMMDC=$PIECE(AUMREC,"-")
+90 SET AUMDRGS=$PIECE(AUMREC,"-",2)
+91 IF $GET(AUMMDC)'=""
Begin DoDot:3
+92 KILL DIC,X,Y,DA
+93 SET DA(1)=AUMDA
+94 SET DIC="^ICD0("_DA(1)_",""MDC"","
+95 SET DIC("P")=$PIECE(^DD(80.1,7,0),U,2)
+96 SET DIC(0)="LXI"
+97 SET DLAYGO=80.1
+98 SET X=AUMMDC
+99 DO ^DIC
+100 IF AUMDRGS=""
KILL Y
+101 KILL DIC,DIE,X,DA
+102 IF +$GET(Y)>0
IF $GET(AUMDRGS)'=""
Begin DoDot:4
+103 FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")
Begin DoDot:5
+104 SET AUMDRG=$PIECE(AUMDRGS,",",AUMJ)
+105 SET DR=AUMJ_"////"_AUMDRG
+106 SET DA(1)=AUMDA
+107 SET DA=AUMMDC
+108 SET DIE="^ICD0("_DA(1)_",""MDC"","
+109 DO DIE^AUM101R1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+110 IF $GET(AUMFLG)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+111 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+112 QUIT
End DoDot:1
+113 QUIT
+114 ;
+115 ; -----------------------------------------------------
ICD0REV ;
+1 ;("ICD9PREV")
DO RSLT^AUM101R1("ICD OPERATION/PROCEDURE, REVISED CODES:")
+2 DO RSLT^AUM101R1($JUSTIFY("",8)_"CODE DESCRIPTION")
+3 DO RSLT^AUM101R1($JUSTIFY("",8)_"---- -----------")
+4 NEW AUMDA,AUMI,AUMLN,DA,DIE,DR
+5 ;F AUMI=1:1 S AUMLN=$P($T(ICD9PREV+AUMI^AUM101B),";;",2) Q:AUMLN="END" D ;IHS/SD/SDR 11/30/09 HEAT8884
+6 ;IHS/SD/SDR 11/30/09 HEAT8884
FOR AUMI=1:1
SET AUMLN=$PIECE($TEXT(ICD9PREV+AUMI^AUM101E),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+7 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+8 SET Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$PIECE(AUMLN,U))
+9 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+10 SET DA=+Y
+11 ;operation/procedure
SET DR="4///"_$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 ;
+17 ;date updated
SET DR=DR_";2100000///"_DT
+18 ;
+19 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+20 SET DIE="^ICD0("
+21 SET AUMDA=DA
+22 DO DIE^AUM101R1
+23 ;
+24 ;effective date multiple
+25 KILL AUMFLG
+26 SET AUMLDT=0
+27 ;get last date in multiple
SET AUMLDT=$ORDER(^ICD0(AUMIEN,66,"B",9999999),-1)
+28 ;entry exists; check if status is correct (active)
IF +AUMLDT>0
Begin DoDot:2
+29 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,66,"B",AUMLDT,0))
+30 ;quit if incomplete entry for some reason
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+31 ;already active
IF $PIECE($GET(^ICD0(AUMIEN,66,AUMMIEN,0)),U,2)=1
QUIT
+32 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+33 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+34 KILL DIC,DIE,DA,X,Y
+35 SET DA(1)=AUMIEN
+36 SET DIC="^ICD0("_DA(1)_",66,"
+37 SET DIC("P")=$PIECE(^DD(80.1,66,0),U,2)
+38 SET DIC(0)="L"
+39 ;use active date of 10/01/2009
SET X="3091001"
+40 SET DIC("DR")=".02////1"
+41 DO ^DIC
+42 IF Y<0
SET AUMFLG=1
End DoDot:2
+43 ;
+44 ;operation/proc multiple
+45 SET AUMLDT=0
+46 ;get last entry
SET AUMLDT=$ORDER(^ICD0(AUMIEN,67,"B",9999999),-1)
+47 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+48 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,67,"B",AUMLDT,0))
+49 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+50 IF $PIECE($GET(^ICD0(AUMIEN,67,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+51 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+52 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+53 KILL DIC,DIE,DA,X,Y
+54 SET DA(1)=AUMIEN
+55 SET DIC="^ICD0("_DA(1)_",67,"
+56 SET DIC("P")=$PIECE(^DD(80.1,67,0),U,2)
+57 SET DIC(0)="L"
+58 ;use active date of 10/01/2009
SET X="3091001"
+59 ;oper/proc
SET DIC("DR")="1////"_$PIECE(AUMLN,U,2)
+60 DO ^DIC
+61 IF Y<0
SET AUMFLG=1
End DoDot:2
+62 ;
+63 ;description multiple
+64 SET AUMODESC=""
+65 SET AUMLDT=0
+66 SET AUMLDT=$ORDER(^ICD0(AUMIEN,68,"B",9999999),-1)
+67 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+68 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,68,"B",AUMLDT,0))
+69 IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+70 IF $PIECE($GET(^ICD0(AUMIEN,68,AUMMIEN,0)),U)=$PIECE(AUMLN,U,3)
QUIT
+71 SET AUMLDT=0
End DoDot:2
+72 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+73 KILL DIC,DIE,DA,X,Y
+74 SET DA(1)=AUMIEN
+75 SET DIC="^ICD0("_DA(1)_",68,"
+76 SET DIC("P")=$PIECE(^DD(80.1,68,0),U,2)
+77 SET DIC(0)="L"
+78 ;use active date of 10/01/2009
SET X="3091001"
+79 ;description
SET DIC("DR")="1////"_$PIECE(AUMLN,U,3)
+80 DO ^DIC
+81 IF Y<0
SET AUMFLG=1
End DoDot:2
+82 ;
+83 ;loads MDC and DRGs if any
+84 ;clear existing entries
KILL ^ICD0(AUMDA,"MDC")
+85 SET (AUMMANDD,AUMMDC,AUMDRGS)=""
+86 SET AUMMANDD=$PIECE(AUMLN,U,5)
+87 FOR AUMK=1:1:$LENGTH(AUMMANDD,"-")
Begin DoDot:2
+88 SET AUMREC=""
+89 SET AUMREC=$PIECE(AUMMANDD,"~",AUMK)
+90 SET AUMMDC=$PIECE(AUMREC,"-")
+91 SET AUMDRGS=$PIECE(AUMREC,"-",2)
+92 IF $GET(AUMMDC)'=""
Begin DoDot:3
+93 SET DIC="^ICD0("_AUMDA_",""MDC"","
+94 SET DIC("P")=$PIECE(^DD(80.1,7,0),U,2)
+95 SET DA(1)=AUMDA
+96 SET DIC(0)="LXI"
+97 SET DLAYGO=80.1
+98 SET X=AUMMDC
+99 DO ^DIC
+100 IF AUMDRGS=""
KILL Y
+101 IF +$GET(Y)>0
IF $GET(AUMDRGS)'=""
Begin DoDot:4
+102 FOR AUMJ=1:1:$LENGTH(AUMDRGS,",")
Begin DoDot:5
+103 SET AUMDRG=$PIECE(AUMDRGS,",",AUMJ)
+104 SET DR=AUMJ_"///"_AUMDRG
+105 SET DA=AUMMDC
+106 SET DIE="^ICD0("_AUMDA_",""MDC"","
+107 DO DIE^AUM101R1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+108 IF $GET(AUMFLG)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+109 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+110 QUIT
End DoDot:1
+111 QUIT
ICD0INAC ;
+1 ;("ICD9PINA")
DO RSLT^AUM101R1("ICD 9 PROCEDURE, 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(ICD9PINA+AUMI^AUM101E),";;",2)
IF X="END"
QUIT
Begin DoDot:1
+6 SET Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$PIECE(X,U))
+7 IF Y=-1
DO RSLT^AUM101R1(" CODE '"_X_"' not found (that's OK).")
QUIT
+8 SET DA=+Y
+9 SET DIE="^ICD0("
+10 ;inactive flag
SET DR="102///3091001"
+11 SET AUMDA=DA
+12 DO DIE^AUM101R1
+13 ;
+14 KILL DIC,DIE,DA,X,Y
+15 SET DA(1)=AUMIEN
+16 SET DIC="^ICD0("_DA(1)_",66,"
+17 SET DIC("P")=$PIECE(^DD(80.1,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 ;
+23 IF Y<0
DO RSLT^AUM101R1("ERROR: Edit of INACTIVE DATE field for CODE '"_$PIECE(X,U,1)_"' FAILED.")
QUIT
+24 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(^ICD0(AUMDA,0),U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(^ICD0(AUMDA,0),U,4),1,30))
+25 QUIT
End DoDot:1
+26 QUIT
ICD0OREV ;
+1 ;("ICD0OREV")
DO RSLT^AUM101R1("ICD OPERATION/PROCEDURE, OTHER REVISED 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(ICD0OREV+AUMI^AUM101C),";;",2)
IF AUMLN="END"
QUIT
Begin DoDot:1
+6 SET AUMLN=$TRANSLATE(AUMLN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 SET Y=$$IXDIC^AUM101R1("^ICD0(","ILX","AB",$PIECE(AUMLN,U))
+8 IF Y=-1
DO RSLT^AUM101R1("ERROR: Lookup/Add of CODE '"_$PIECE(AUMLN,U)_"' FAILED.")
QUIT
+9 SET DA=+Y
+10 ;operation/procedure
SET DR="4///"_$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 ;
+16 ;date updated
SET DR=DR_";2100000///"_DT
+17 ;use with sex
SET DR=DR_";9.5///"_$PIECE(AUMLN,U,4)
+18 SET DIE="^ICD0("
+19 SET AUMDA=DA
+20 DO DIE^AUM101R1
+21 ;
+22 ;effective date multiple
+23 SET AUMLDT=0
+24 ;get last date in multiple
SET AUMLDT=$ORDER(^ICD0(AUMIEN,66,"B",9999999),-1)
+25 ;entry exists; check if status is correct (active)
IF +AUMLDT>0
Begin DoDot:2
+26 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,66,"B",AUMLDT,0))
+27 ;quit if incomplete entry for some reason
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+28 ;already active
IF $PIECE($GET(^ICD0(AUMIEN,66,AUMMIEN,0)),U,2)=1
QUIT
+29 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+30 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+31 KILL DIC,DIE,DA,X,Y
+32 SET DA(1)=AUMIEN
+33 SET DIC="^ICD0("_DA(1)_",66,"
+34 SET DIC("P")=$PIECE(^DD(80.1,66,0),U,2)
+35 SET DIC(0)="L"
+36 ;use active date of 10/01/2009
SET X="3091001"
+37 SET DIC("DR")=".02////1"
+38 DO ^DIC
End DoDot:2
+39 ;
+40 ;operation/proc multiple
+41 SET AUMLDT=0
+42 ;get last entry
SET AUMLDT=$ORDER(^ICD0(AUMIEN,67,"B",9999999),-1)
+43 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+44 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,67,"B",AUMLDT,0))
+45 ;quit if incomplete entry
IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+46 IF $PIECE($GET(^ICD0(AUMIEN,67,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)
QUIT
+47 ;set date to zero so it will add entry
SET AUMLDT=0
End DoDot:2
+48 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+49 KILL DIC,DIE,DA,X,Y
+50 SET DA(1)=AUMIEN
+51 SET DIC="^ICD0("_DA(1)_",67,"
+52 SET DIC("P")=$PIECE(^DD(80.1,67,0),U,2)
+53 SET DIC(0)="L"
+54 ;use active date of 10/01/2009
SET X="3091001"
+55 ;oper/proc
SET DIC("DR")="1////"_$PIECE(AUMLN,U,2)
+56 DO ^DIC
End DoDot:2
+57 ;
+58 ;description multiple
+59 SET AUMODESC=""
+60 SET AUMLDT=0
+61 SET AUMLDT=$ORDER(^ICD0(AUMIEN,68,"B",9999999),-1)
+62 ;there is an entry
IF +AUMLDT>0
Begin DoDot:2
+63 SET AUMMIEN=$ORDER(^ICD0(AUMIEN,68,"B",AUMLDT,0))
+64 IF +AUMMIEN=0
SET AUMLDT=0
QUIT
+65 IF $PIECE($GET(^ICD0(AUMIEN,68,AUMMIEN,0)),U)=$PIECE(AUMLN,U,3)
QUIT
+66 SET AUMLDT=0
End DoDot:2
+67 ;no entry or needs a new entry
IF +AUMLDT=0
Begin DoDot:2
+68 KILL DIC,DIE,DA,X,Y
+69 SET DA(1)=AUMIEN
+70 SET DIC="^ICD0("_DA(1)_",68,"
+71 SET DIC("P")=$PIECE(^DD(80.1,68,0),U,2)
+72 SET DIC(0)="L"
+73 ;use active date of 10/01/2009
SET X="3091001"
+74 ;description
SET DIC("DR")="1////"_$PIECE(AUMLN,U,3)
+75 DO ^DIC
End DoDot:2
+76 IF $DATA(Y)
DO RSLT^AUM101R1("ERROR: Edit of fields for CODE '"_$PIECE(AUMLN,U,1)_"' FAILED.")
QUIT
+77 DO RSLT^AUM101R1($JUSTIFY("",8)_$PIECE(AUMLN,U,1)_$JUSTIFY("",4)_$EXTRACT($PIECE(AUMLN,U,2),1,30))
+78 QUIT
End DoDot:1
+79 QUIT
