Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ATXDELA

ATXDELA.m

Go to the documentation of this file.
  1. ATXDELA ; IHS/OHPRD/TMJ - ICD CODES FOR A GIVEN TAXONOMY BEFORE MODIFICATION ;
  1. ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1. ;
  1. W !!,"Delete a taxonomy created by any user.",!!
  1. S U="^",ATXDEL="",ATXFLG="" ;ATXDEL ALLOWS DELETING OF A TAXONOMY
  1. ;SINCE A DELETE NODE FOR THE TAXONOMY FILE CHECKS $D(ATXDEL)
  1. F ATXL=0:0 D START Q:ATXSTP
  1. D EOJ
  1. Q
  1. ;
  1. START ;
  1. D ASK Q:ATXSTP
  1. Q
  1. ;
  1. ASK ;
  1. S ATXSTP=0
  1. S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("DR")="",DIC("S")="I $P(^(0),U,4)=""""" D ^DIC K DIC
  1. I Y<1 S ATXSTP=1 Q
  1. W !,$C(7),"Are you sure you want to delete this entire taxonomy" S %=1 D YN^DICN
  1. I %=1 S ATXX=+Y,ATXQT="" D TSKMN Q
  1. I %=2 Q
  1. I %=0 G ASK
  1. I %=-1 S ATXSTP=1 Q
  1. Q
  1. ;
  1. TSKMN ;
  1. W !!,"deleting taxonomy...hold on"
  1. D DFNS
  1. D CALLDIK
  1. K ^TMP("ATXTAX",ATXX)
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. K ATXLOV,ATXHIVO,ATXHI,ATXDFN,ATXQT,ATXX,ATXSS
  1. Q
  1. ;
  1. DFNS ;GET LO AND HIGH DFNS FOR THIS TAXONOMY
  1. Q:$P(^ATXAX(ATXX,0),U,15)'=80
  1. ;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
  1. 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
  1. Q
  1. ;
  1. GETVAL ;GET RANGE OF DFNS
  1. S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D DIEDELT
  1. Q:'ATXHIV!(ATXHIV=ATXLOV)
  1. F S ATXLOV=$O(^ICD9("BA",ATXLOV)) Q:ATXLOV](ATXHIV)!(ATXLOV="") S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D DIEDELT
  1. Q
  1. ;
  1. DIEDELT ;
  1. Q:'$D(^ICD9(ATXDFN,9999999.41,ATXX,0))#2
  1. S DIE="^ICD9(",DR="9999999.41///"_"`"_ATXX,DR(2,80.999999941)=".01///@",DA=ATXDFN D ^DIE K DIE
  1. Q
  1. ;
  1. CALLDIK ;
  1. ;I $P(^ATXAX(ATXX,0),U,7) S DIK="^XMB(3.6,",DA=$P(^(0),U,7) D ^DIK K DIK
  1. S DIK="^ATXAX(",DA=ATXX D ^DIK K DIK
  1. S DIK="^ATXPAT(",DA=ATXX D ^DIK K DIK
  1. Q
  1. ;
  1. EOJ ;
  1. K ATXLOV,ATXHIV,ATXLO,ATXHI,ATXDFN,ATXL,ATXQT,ATXX,ATXDEL,ATXSS,ATXSTP,ATXFLG
  1. Q
  1. ;