AUM91RL2.m

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

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

 ;

ICD0NEW ;

 D RSLT^AUM91RL1("ICD OPERATION/PROCEDURE, NEW PROCEDURE CODES:")  ;ICD9PNEW

 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(ICD9PNEW+AUMI^AUM91D),";;",2) Q:AUMLN="END"  D

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

 .S Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$P(AUMLN,U))

 .I Y=-1 D RSLT^AUM91RL1("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///3081001"   ;date added

 .S DR=DR_";12///3081001"  ;activation date

 .;

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

 .S DIE="^ICD0("

 .S AUMDA=DA

 .D DIE^AUM91RL1

 .;

 .;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=3081001 Q  ;already has 10/01/2008 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="3081001"  ;use active date of 10/01/2008

 ..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=3081001 Q  ;already has 10/01/2008 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="3081001"  ;use active date of 10/01/2008

 ..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=3081001 Q  ;already has 10/01/2008 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="3081001"  ;use active date of 10/01/2008

 ..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^AUM91RL1

 .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

 ;

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

ICD0REV ;

 D RSLT^AUM91RL1("ICD OPERATION/PROCEDURE, REVISED CODES:")  ;("ICD9PREV")

 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(ICD9PREV+AUMI^AUM91B),";;",2) Q:AUMLN="END"  D

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

 .S Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$P(AUMLN,U))

 .I Y=-1 D RSLT^AUM91RL1("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^AUM91RL1

 .;

 .;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="3081001"  ;use active date of 10/01/2008

 ..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="3081001"  ;use active date of 10/01/2008

 ..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="3081001"  ;use active date of 10/01/2008

 ..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^AUM91RL1

 .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

ICD0INAC ;

 D RSLT^AUM91RL1("ICD 9 PROCEDURE, INACTIVE CODES:")  ;("ICD9PINA")

 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(ICD9PINA+AUMI^AUM91E),";;",2) Q:X="END"  D

 .S Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$P(X,U))

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

 .S DA=+Y

 .S DIE="^ICD0("

 .S DR="102///3081001"  ;inactive flag

 .S AUMDA=DA

 .D DIE^AUM91RL1

 .;

 .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="3081001"  ;use active date of 10/01/2008

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

 .D ^DIC

 .;

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

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

 .Q

 Q

ICD0OREV ;

 D RSLT^AUM91RL1("ICD OPERATION/PROCEDURE, OTHER REVISED CODES:")  ;("ICD0OREV")

 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(ICD0OREV+AUMI^AUM91C),";;",2) Q:AUMLN="END"  D

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

 .S Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$P(AUMLN,U))

 .I Y=-1 D RSLT^AUM91RL1("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^AUM91RL1

 .;

 .;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="3081001"  ;use active date of 10/01/2008

 ..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="3081001"  ;use active date of 10/01/2008

 ..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="3081001"  ;use active date of 10/01/2008

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

 ..D ^DIC

 .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

 Q

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

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

 +2       ;

ICD0NEW   ;

 +1       ;ICD9PNEW

           DO RSLT^AUM91RL1("ICD OPERATION/PROCEDURE, NEW PROCEDURE CODES:")

 +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(ICD9PNEW+AUMI^AUM91D),";;",2)

               IF AUMLN="END"

                   QUIT 

               Begin DoDot:1

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

 +7                SET Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$PIECE(AUMLN,U))

 +8                IF Y=-1

                       DO RSLT^AUM91RL1("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///3081001"

 +17      ;activation date

                   SET DR=DR_";12///3081001"

 +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^AUM91RL1

 +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/2008 entry

                           IF AUMLDT=3081001

                               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/2008

                           SET X="3081001"

 +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/2008 entry

                           IF AUMLDT=3081001

                               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/2008

                           SET X="3081001"

 +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/2008 entry

                           IF AUMLDT=3081001

                               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/2008

                           SET X="3081001"

 +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^AUM91RL1

                                                   End DoDot:5

                                           End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +110              IF $GET(AUMFLG)

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

                       QUIT 

 +111              DO RSLT^AUM91RL1($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^AUM91RL1("ICD OPERATION/PROCEDURE, REVISED CODES:")

 +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(ICD9PREV+AUMI^AUM91B),";;",2)

               IF AUMLN="END"

                   QUIT 

               Begin DoDot:1

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

 +7                SET Y=$$IXDIC^AUM91RL1("^ICD0(","ILX","AB",$PIECE(AUMLN,U))

 +8                IF Y=-1

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

 +18      ;use with sex

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

 +19               SET DIE="^ICD0("

 +20               SET AUMDA=DA

 +21               DO DIE^AUM91RL1

 +22      ;

 +23      ;effective date multiple

 +24               KILL AUMFLG

 +25               SET AUMLDT=0

 +26      ;get last date in multiple

                   SET AUMLDT=$ORDER(^ICD0(AUMIEN,66,"B",9999999),-1)

 +27      ;entry exists; check if status is correct (active)

                   IF +AUMLDT>0

                       Begin DoDot:2

 +28                       SET AUMMIEN=$ORDER(^ICD0(AUMIEN,66,"B",AUMLDT,0))

 +29      ;quit if incomplete entry for some reason

                           IF +AUMMIEN=0

                               SET AUMLDT=0

                               QUIT 

 +30      ;already active

                           IF $PIECE($GET(^ICD0(AUMIEN,66,AUMMIEN,0)),U,2)=1

                               QUIT 

 +31      ;set date to zero so it will add entry

                           SET AUMLDT=0

                       End DoDot:2

 +32      ;no entry or needs a new entry

                   IF +AUMLDT=0

                       Begin DoDot:2

 +33                       KILL DIC,DIE,DA,X,Y

 +34                       SET DA(1)=AUMIEN

 +35                       SET DIC="^ICD0("_DA(1)_",66,"

 +36                       SET DIC("P")=$PIECE(^DD(80.1,66,0),U,2)

 +37                       SET DIC(0)="L"

 +38      ;use active date of 10/01/2008

                           SET X="3081001"

 +39                       SET DIC("DR")=".02////1"

 +40                       DO ^DIC

 +41                       IF Y<0

                               SET AUMFLG=1

                       End DoDot:2

 +42      ;

 +43      ;operation/proc multiple

 +44               SET AUMLDT=0

 +45      ;get last entry

                   SET AUMLDT=$ORDER(^ICD0(AUMIEN,67,"B",9999999),-1)

 +46      ;there is an entry

                   IF +AUMLDT>0

                       Begin DoDot:2

 +47                       SET AUMMIEN=$ORDER(^ICD0(AUMIEN,67,"B",AUMLDT,0))

 +48      ;quit if incomplete entry

                           IF +AUMMIEN=0

                               SET AUMLDT=0

                               QUIT 

 +49                       IF $PIECE($GET(^ICD0(AUMIEN,67,AUMMIEN,0)),U,2)=$PIECE(AUMLN,U,2)