AUMICD2.m

AUMICD2 ;IHS/ASDST/DMJ - INSTALL NEW CODES FOR 2001  [ 11/08/2000  12:16 PM ]

 ;;01.1;ICD UPDATES;;NOV 03, 2000

START ;START

 K ^DD(80.1,0,"DIC")

 D ICD0

 D REV

 S ^DD(80.1,0,"DIC")="AICDKWI0"

 Q

ICD0 ;install new icd0 codes

 F AUMI=124:1:132 D

 .S AUMLN=$T(@AUMI)

 .F AUMJ=2:1:8 S AUM(AUMJ)=$P(AUMLN,";",AUMJ)

 .S Y=$O(^ICD0("AB",AUM(2),0))

 .I 'Y D

 ..S DIC="^ICD0("

 ..S DIC(0)="LX"

 ..S X=AUM(2)

 ..D ^DIC

 .Q:+Y<0  S DA=+Y

 .S ^ICD0(DA,1)=AUM(3)

 .S:AUM(4)'="" $P(^ICD0(DA,0),"^",10)=AUM(4)

 .S $P(^ICD0(DA,9999999),"^",4)=3001000

 .D MDC

 .S DIK="^ICD0(" D IX1^DIK

 Q

MDC ;update MDC multiple

 F AUMI2=1:1 S AUMLN=$T(@AUMI+AUMI2) Q:+AUMLN  D

 .S AUMMDC=$P(AUMLN,";",2)

 .S AUMDRG=$P(AUMLN,";",3)

 .S ^ICD0(DA,"MDC",AUMMDC,0)=AUMMDC

 .S ^ICD0(DA,"MDC",AUMMDC,"DRG")=AUMDRG

 S:+AUMLN'=999 ^ICD0(DA,"MDC",0)="^80.12PA^"_AUMMDC_"^"_(AUMI2-1)

 K AUMI2,AUMMDC,AUMDRG

 Q

REV ;revised descriptions

 S AUM(1)="AUTOLOGOUS BONE MARROW TRANSPLANT WITHOUT PURGING"

 S AUM(2)="AUTOLOGOUS HEMATOPOIETIC STEM CELL TRANSPLANT WITHOUT PURGING"

 S AUM(3)="ALLOGENEIC HEMATOPOIETIC STEM CELL TRANSPLANT WITHOUT PURGING"

 S AUM(4)="CLOSURE OF SKIN AND SUBCUTANEOUS TISSUE OTHER SITES"

 S AUMCT=0

 F I=41.01,41.04,41.05,86.59 D

 .S AUMCT=AUMCT+1

 .S DA=$O(^ICD0("AB",I,0))

 .Q:'DA

 .S ^ICD0(DA,1)=AUM(AUMCT)

 .S DIK="^ICD0(" D IX1^DIK

 .Q:I=86.59

 .K ^ICD0(DA,"MDC")

 .S ^ICD0(DA,"MDC",0)="^80.12PA^16^1"

 .S ^ICD0(DA,"MDC",16,0)=16

 .S ^ICD0(DA,"MDC",16,"DRG")=481

 Q

 ;new codes

124 ;39.71;ENDOVASCULAR IMPLANTATION OF GRAFT IN ABDOMINAL AORTA;

 ;5;110^111

 ;11;315

 ;21;442^443

 ;24;486

125 ;39.79;OTHER ENDOVASCULAR GRAFT REPAIR OF ANEURYSM;

 ;1;1^2^3

 ;5;110^111

 ;11;315

 ;21;442^443

 ;24;486

126 ;41.07;AUTOLOGOUS HEMATOPOIETIC STEM CELL TRANSPLANT WITH PURGING;

 ;16;481

127 ;41.08;ALLOGENEIC HEMATOPOIETIC STEM CELL TRANSPLANT WITH PURGING;

 ;16;481

128 ;41.09;AUTOLOGOUS BONE MARROW TRANSPLANT WITH PURGING;

 ;16;481

129 ;46.97;TRANSPLANT OF INTESTINE;

 ;6;148^149

 ;7;201

 ;17;400^406^407

 ;21;442^443

 ;24;486

130 ;60.96;TRANSURETHRAL DESTRUCTION OF PROSTATE TISSUE BY MICROWAVE THERMOTHERAPY;M

 ;11;306^307

 ;12;336^337

131 ;60.97;OTHER TRANSURETHRAL DESTRUCTION OF PROSTATE TISSUE BY OTHER THERMOTHERAPY;M

 ;11;306^307

 ;12;336^337

132 ;99.75;ADMINISTRATION OF NEUROPROTECTIVE AGENT;

999 ;end

AUMICD2   ;IHS/ASDST/DMJ - INSTALL NEW CODES FOR 2001  [ 11/08/2000  12:16 PM ]

 +1       ;;01.1;ICD UPDATES;;NOV 03, 2000

START     ;START

 +1        KILL ^DD(80.1,0,"DIC")

 +2        DO ICD0

 +3        DO REV

 +4        SET ^DD(80.1,0,"DIC")="AICDKWI0"

 +5        QUIT 

ICD0      ;install new icd0 codes

 +1        FOR AUMI=124:1:132

               Begin DoDot:1

 +2                SET AUMLN=$TEXT(@AUMI)

 +3                FOR AUMJ=2:1:8

                       SET AUM(AUMJ)=$PIECE(AUMLN,";",AUMJ)

 +4                SET Y=$ORDER(^ICD0("AB",AUM(2),0))

 +5                IF 'Y

                       Begin DoDot:2

 +6                        SET DIC="^ICD0("

 +7                        SET DIC(0)="LX"

 +8                        SET X=AUM(2)

 +9                        DO ^DIC

                       End DoDot:2

 +10               IF +Y<0

                       QUIT 

                   SET DA=+Y

 +11               SET ^ICD0(DA,1)=AUM(3)

 +12               IF AUM(4)'=""

                       SET $PIECE(^ICD0(DA,0),"^",10)=AUM(4)

 +13               SET $PIECE(^ICD0(DA,9999999),"^",4)=3001000

 +14               DO MDC

 +15               SET DIK="^ICD0("

                   DO IX1^DIK

               End DoDot:1

 +16       QUIT 

MDC       ;update MDC multiple

 +1        FOR AUMI2=1:1

               SET AUMLN=$TEXT(@AUMI+AUMI2)

               IF +AUMLN

                   QUIT 

               Begin DoDot:1

 +2                SET AUMMDC=$PIECE(AUMLN,";",2)

 +3                SET AUMDRG=$PIECE(AUMLN,";",3)

 +4                SET ^ICD0(DA,"MDC",AUMMDC,0)=AUMMDC

 +5                SET ^ICD0(DA,"MDC",AUMMDC,"DRG")=AUMDRG

               End DoDot:1

 +6        IF +AUMLN'=999

               SET ^ICD0(DA,"MDC",0)="^80.12PA^"_AUMMDC_"^"_(AUMI2-1)

 +7        KILL AUMI2,AUMMDC,AUMDRG

 +8        QUIT 

REV       ;revised descriptions

 +1        SET AUM(1)="AUTOLOGOUS BONE MARROW TRANSPLANT WITHOUT PURGING"

 +2        SET AUM(2)="AUTOLOGOUS HEMATOPOIETIC STEM CELL TRANSPLANT WITHOUT PURGING"

 +3        SET AUM(3)="ALLOGENEIC HEMATOPOIETIC STEM CELL TRANSPLANT WITHOUT PURGING"

 +4        SET AUM(4)="CLOSURE OF SKIN AND SUBCUTANEOUS TISSUE OTHER SITES"

 +5        SET AUMCT=0

 +6        FOR I=41.01,41.04,41.05,86.59

               Begin DoDot:1

 +7                SET AUMCT=AUMCT+1

 +8                SET DA=$ORDER(^ICD0("AB",I,0))

 +9                IF 'DA

                       QUIT 

 +10               SET ^ICD0(DA,1)=AUM(AUMCT)

 +11               SET DIK="^ICD0("

                   DO IX1^DIK

 +12               IF I=86.59

                       QUIT 

 +13               KILL ^ICD0(DA,"MDC")

 +14               SET ^ICD0(DA,"MDC",0)="^80.12PA^16^1"

 +15               SET ^ICD0(DA,"MDC",16,0)=16

 +16               SET ^ICD0(DA,"MDC",16,"DRG")=481

               End DoDot:1

 +17       QUIT 

 +18      ;new codes

124       ;39.71;ENDOVASCULAR IMPLANTATION OF GRAFT IN ABDOMINAL AORTA;

 +1       ;5;110^111

 +2       ;11;315

 +3       ;21;442^443

 +4       ;24;486

125       ;39.79;OTHER ENDOVASCULAR GRAFT REPAIR OF ANEURYSM;

 +1       ;1;1^2^3

 +2       ;5;110^111

 +3       ;11;315

 +4       ;21;442^443

 +5       ;24;486

126       ;41.07;AUTOLOGOUS HEMATOPOIETIC STEM CELL TRANSPLANT WITH PURGING;

 +1       ;16;481

127       ;41.08;ALLOGENEIC HEMATOPOIETIC STEM CELL TRANSPLANT WITH PURGING;

 +1       ;16;481

128       ;41.09;AUTOLOGOUS BONE MARROW TRANSPLANT WITH PURGING;

 +1       ;16;481

129       ;46.97;TRANSPLANT OF INTESTINE;

 +1       ;6;148^149

 +2       ;7;201

 +3       ;17;400^406^407

 +4       ;21;442^443

 +5       ;24;486

130       ;60.96;TRANSURETHRAL DESTRUCTION OF PROSTATE TISSUE BY MICROWAVE THERMOTHERAPY;M

 +1       ;11;306^307

 +2       ;12;336^337

131       ;60.97;OTHER TRANSURETHRAL DESTRUCTION OF PROSTATE TISSUE BY OTHER THERMOTHERAPY;M

 +1       ;11;306^307

 +2       ;12;336^337

132       ;99.75;ADMINISTRATION OF NEUROPROTECTIVE AGENT;

999       ;end