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
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,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
Q
;
ANY ;EP
D ASKANY
D EOJ
Q
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
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)
Q
;
ZTM ;ENTRY POINT FOR TASKMAN
D DFNS
D CALLDIK
;K ^TMP("ATXTAX",ATXX)
;I $D(ZTQUEUED) S ZTREQ="@"
;D EOJ
Q
;
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
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 ;
D EN^XBVK("ATX")
Q
;
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 ;
