ATXDELA.m

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

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 W !!,"Delete a taxonomy created by any user.",!!

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

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

 F ATXL=0:0 D START Q:ATXSTP

 D EOJ

 Q

 ;

START ;

 D ASK Q:ATXSTP

 Q

 ;

ASK ;

 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 ASK

 I %=-1 S ATXSTP=1 Q

 Q

 ;

TSKMN ;

 W !!,"deleting taxonomy...hold on"

 D DFNS

 D CALLDIK

 K ^TMP("ATXTAX",ATXX)

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

 K ATXLOV,ATXHIVO,ATXHI,ATXDFN,ATXQT,ATXX,ATXSS

 Q

 ;

DFNS ;GET LO AND HIGH DFNS FOR THIS TAXONOMY

 Q:$P(^ATXAX(ATXX,0),U,15)'=80

 ;S ATXSS=0 F ATXL=0:0 S ATXSS=$O(^ATXAX(ATXX,21,ATXSS)) Q:ATXSS'=+ATXSS  S ATXLOV=$P(^(ATXSS,0),U)_" ",ATXHIV=$P(^(0),U,2)_" " D GETVAL

 S ATXSS=0 F ATXL=0:0 S ATXSS=$O(^ATXAX(ATXX,21,ATXSS)) Q:ATXSS'=+ATXSS  S ATXLOV=$P(^(ATXSS,0),U) S:ATXLOV'[" " ATXLOV=ATXLOV_" " S ATXHIV=$P(^(0),U,2) S:ATXHIV'[" " ATXHIV=ATXHIV_" " D GETVAL

 Q

 ;

GETVAL ;GET RANGE OF DFNS

 S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D DIEDELT

 Q:'ATXHIV!(ATXHIV=ATXLOV)

 F  S ATXLOV=$O(^ICD9("BA",ATXLOV)) Q:ATXLOV](ATXHIV)!(ATXLOV="")  S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D DIEDELT

 Q

 ;

DIEDELT ;

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

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

 Q

 ;

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

 Q

 ;

EOJ ;

 K ATXLOV,ATXHIV,ATXLO,ATXHI,ATXDFN,ATXL,ATXQT,ATXX,ATXDEL,ATXSS,ATXSTP,ATXFLG

 Q

 ;

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

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3        WRITE !!,"Delete a taxonomy created by any user.",!!

 +4       ;ATXDEL ALLOWS DELETING OF A TAXONOMY

           SET U="^"

           SET ATXDEL=""

           SET ATXFLG=""

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

 +6        FOR ATXL=0:0

               DO START

               IF ATXSTP

                   QUIT 

 +7        DO EOJ

 +8        QUIT 

 +9       ;

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,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      ;

TSKMN     ;

 +1        WRITE !!,"deleting taxonomy...hold on"

 +2        DO DFNS

 +3        DO CALLDIK

 +4        KILL ^TMP("ATXTAX",ATXX)

 +5        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +6        KILL ATXLOV,ATXHIVO,ATXHI,ATXDFN,ATXQT,ATXX,ATXSS

 +7        QUIT 

 +8       ;

DFNS      ;GET LO AND HIGH DFNS FOR THIS TAXONOMY

 +1        IF $PIECE(^ATXAX(ATXX,0),U,15)'=80

               QUIT 

 +2       ;S ATXSS=0 F ATXL=0:0 S ATXSS=$O(^ATXAX(ATXX,21,ATXSS)) Q:ATXSS'=+ATXSS  S ATXLOV=$P(^(ATXSS,0),U)_" ",ATXHIV=$P(^(0),U,2)_" " D GETVAL

 +3        SET ATXSS=0

           FOR ATXL=0:0

               SET ATXSS=$ORDER(^ATXAX(ATXX,21,ATXSS))

               IF ATXSS'=+ATXSS

                   QUIT 

               SET ATXLOV=$PIECE(^(ATXSS,0),U)

               IF ATXLOV'[" "

                   SET ATXLOV=ATXLOV_" "

               SET ATXHIV=$PIECE(^(0),U,2)

               IF ATXHIV'[" "

                   SET ATXHIV=ATXHIV_" "

               DO GETVAL

 +4        QUIT 

 +5       ;

GETVAL    ;GET RANGE OF DFNS

 +1        SET ATXDFN=$ORDER(^ICD9("BA",ATXLOV,""))

           DO DIEDELT

 +2        IF 'ATXHIV!(ATXHIV=ATXLOV)

               QUIT 

 +3        FOR 

               SET ATXLOV=$ORDER(^ICD9("BA",ATXLOV))

               IF ATXLOV](ATXHIV)!(ATXLOV="")

                   QUIT 

               SET ATXDFN=$ORDER(^ICD9("BA",ATXLOV,""))

               DO DIEDELT

 +4        QUIT 

 +5       ;

DIEDELT   ;

 +1        IF '$DATA(^ICD9(ATXDFN,9999999.41,ATXX,0))#2

               QUIT 

 +2        SET DIE="^ICD9("

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

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

           SET DA=ATXDFN

           DO ^DIE

           KILL DIE

 +3        QUIT 

 +4       ;

CALLDIK   ;

 +1       ;I $P(^ATXAX(ATXX,0),U,7) S DIK="^XMB(3.6,",DA=$P(^(0),U,7) D ^DIK K 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        KILL ATXLOV,ATXHIV,ATXLO,ATXHI,ATXDFN,ATXL,ATXQT,ATXX,ATXDEL,ATXSS,ATXSTP,ATXFLG

 +2        QUIT 

 +3       ;