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