Routine: ATXDEL

ATXDEL ; IHS/OHPRD/TMJ -  ICD CODES FOR A GIVEN TAXONOMY BEFORE MODIFICATION ;

 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 S U="^",ATXDEL="",ATXFLG="",ATXSTP="" ;ATXDEL ALLOWS DELETING OF A TAXONOMY

 ;SINCE A DELETE NODE FOR THE TAXONOMY FILE CHECKS $D(ATXDEL)

 D START  ;F ATXL=0:0 D START Q:ATXSTP

 D EOJ

START ;

 D ASK Q:ATXSTP

ASK ;

 S ATXSTP=0

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("DR")="",DIC("S")="I $P(^(0),U,5)=DUZ,$P(^(0),U,4)=""""" D ^DIC K DIC

 I Y<1 S ATXSTP=1 Q

 W !,$C(7),"Are you sure you want to delete this entire taxonomy" S %=1 D YN^DICN

 I %=1 S ATXX=+Y,ATXQT="" D TSKMN Q

 I %=2 Q

 I %=0 G ASK

 I %=-1 S ATXSTP=1 Q

ANY ;EP

 D ASKANY

 D EOJ

ASKANY ;

 S ATXSTP=0

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("DR")="",DIC("S")="I $P(^(0),U,4)=""""" D ^DIC K DIC

 I Y<1 S ATXSTP=1 Q

 W !,$C(7),"Are you sure you want to delete this entire taxonomy" S %=1 D YN^DICN

 I %=1 S ATXX=+Y,ATXQT="" D TSKMN Q

 I %=2 Q

 I %=0 G ASKANY

 I %=-1 S ATXSTP=1 Q

TSKMN ;

 ;S ^TMP("ATXTAX",ATXX)=" being deleted."

 ;K ZTSAVE F %="ATXX","ATXQT" S ZTSAVE(%)=""

 ;W !!,$C(7),"The taxonomy will now be deleted in background by Taskman!",!

 ;S ZTRTN="ZTM^ATXDEL",ZTDESC="DELETE TAXONOMY",ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK

 I $P(^ATXAX(ATXX,0),U,8) D ZTM Q

 S DA=ATXX,DIK="^ATXAX(" D ^DIK K DA,DIK

 ;K ^TMP("ATXTAX",ATXX)

ZTM ;ENTRY POINT FOR TASKMAN

 D DFNS

 D CALLDIK

 ;K ^TMP("ATXTAX",ATXX)

 ;I $D(ZTQUEUED) S ZTREQ="@"

 ;D EOJ

DFNS ;EP - GET LO AND HIGH DFNS FOR THIS TAXONOMY

 K ATXARR

 D BLDTAX^ATXAPI($P(^ATXAX(ATXX,0),U,1),"ATXARR",ATXX,"")

 S ATX1="",ATXQ=0 F  S ATX1=$O(ATXARR(ATX1)) Q:ATX1=""  D

 .;set icd9 41 multiple

 .Q:'$D(^ICD9(ATXX,9999999.41,ATX1,0))#2

 .S DIE="^ICD9(",DR="9999999.41///"_"`"_ATXX,DR(2,80.999999941)=".01///@",DA=ATXDFN D ^DIE K DIE

CALLDIK ;

 I $P(^ATXAX(ATXX,0),U,7) S DIK="^XMB(3.6,",DA=$P(^(0),U,7) D ^DIK K DIK

 S DIK="^ATXAX(",DA=ATXX D ^DIK K DIK

 S DIK="^ATXPAT(",DA=ATXX D ^DIK K DIK

EOJ ;

 D EN^XBVK("ATX")

ATXDEL    ; IHS/OHPRD/TMJ -  ICD CODES FOR A GIVEN TAXONOMY BEFORE MODIFICATION ;

 +1       ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48

 +2       ;

 +3       ;ATXDEL ALLOWS DELETING OF A TAXONOMY

           SET U="^"

           SET ATXDEL=""

           SET ATXFLG=""

           SET ATXSTP=""

 +4       ;SINCE A DELETE NODE FOR THE TAXONOMY FILE CHECKS $D(ATXDEL)

 +5       ;F ATXL=0:0 D START Q:ATXSTP

           DO START

 +6        DO EOJ

 +7        QUIT

 +8       ;

START     ;

 +1        DO ASK

           IF ATXSTP

               QUIT

 +2        QUIT

 +3       ;

ASK       ;

 +1        SET ATXSTP=0

 +2        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

           SET DIC("DR")=""

           SET DIC("S")="I $P(^(0),U,5)=DUZ,$P(^(0),U,4)="""""

           DO ^DIC

           KILL DIC

 +3        IF Y<1

               SET ATXSTP=1

               QUIT

 +4        WRITE !,$CHAR(7),"Are you sure you want to delete this entire taxonomy"

           SET %=1

           DO YN^DICN

 +5        IF %=1

               SET ATXX=+Y

               SET ATXQT=""

               DO TSKMN

               QUIT

 +6        IF %=2

               QUIT

 +7        IF %=0

               GOTO ASK

 +8        IF %=-1

               SET ATXSTP=1

               QUIT

 +9        QUIT

 +10      ;

ANY       ;EP

 +1        DO ASKANY

 +2        DO EOJ

 +3        QUIT

ASKANY    ;

 +1        SET ATXSTP=0

 +2        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

           SET DIC("DR")=""

           SET DIC("S")="I $P(^(0),U,4)="""""

           DO ^DIC

           KILL DIC

 +3        IF Y<1

               SET ATXSTP=1

               QUIT

 +4        WRITE !,$CHAR(7),"Are you sure you want to delete this entire taxonomy"

           SET %=1

           DO YN^DICN

 +5        IF %=1

               SET ATXX=+Y

               SET ATXQT=""

               DO TSKMN

               QUIT

 +6        IF %=2

               QUIT

 +7        IF %=0

               GOTO ASKANY

 +8        IF %=-1

               SET ATXSTP=1

               QUIT

 +9        QUIT

TSKMN     ;

 +1       ;S ^TMP("ATXTAX",ATXX)=" being deleted."

 +2       ;K ZTSAVE F %="ATXX","ATXQT" S ZTSAVE(%)=""

 +3       ;W !!,$C(7),"The taxonomy will now be deleted in background by Taskman!",!

 +4       ;S ZTRTN="ZTM^ATXDEL",ZTDESC="DELETE TAXONOMY",ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK

 +5        IF $PIECE(^ATXAX(ATXX,0),U,8)

               DO ZTM

               QUIT

 +6        SET DA=ATXX

           SET DIK="^ATXAX("

           DO ^DIK

           KILL DA,DIK

 +7       ;K ^TMP("ATXTAX",ATXX)

 +8        QUIT

 +9       ;

ZTM       ;ENTRY POINT FOR TASKMAN

 +1        DO DFNS

 +2        DO CALLDIK

 +3       ;K ^TMP("ATXTAX",ATXX)

 +4       ;I $D(ZTQUEUED) S ZTREQ="@"

 +5       ;D EOJ

 +6        QUIT

 +7       ;

DFNS      ;EP - GET LO AND HIGH DFNS FOR THIS TAXONOMY

 +1        KILL ATXARR

 +2        DO BLDTAX^ATXAPI($PIECE(^ATXAX(ATXX,0),U,1),"ATXARR",ATXX,"")

 +3        SET ATX1=""

           SET ATXQ=0

FOR

               SET ATX1=$ORDER(ATXARR(ATX1))

               IF ATX1=""

                   QUIT

               Begin DoDot:1

 +4       ;set icd9 41 multiple

 +5                IF '$DATA(^ICD9(ATXX,9999999.41,ATX1,0))#2

                       QUIT

 +6                SET DIE="^ICD9("

                   SET DR="9999999.41///"_"`"_ATXX

                   SET DR(2,80.999999941)=".01///@"

                   SET DA=ATXDFN

                   DO ^DIE

                   KILL DIE

               End DoDot:1

 +7        QUIT

 +8       ;

CALLDIK   ;

 +1        IF $PIECE(^ATXAX(ATXX,0),U,7)

               SET DIK="^XMB(3.6,"

               SET DA=$PIECE(^(0),U,7)

               DO ^DIK

               KILL DIK

 +2        SET DIK="^ATXAX("

           SET DA=ATXX

           DO ^DIK

           KILL DIK

 +3        SET DIK="^ATXPAT("

           SET DA=ATXX

           DO ^DIK

           KILL DIK

 +4        QUIT

 +5       ;

EOJ       ;

 +1        DO EN^XBVK("ATX")

 +2        QUIT

 +3       ;

ATXDEL.m