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

ATXTAXT.m

Go to the documentation of this file. 
  1. ATXTAXT ; IHS/CMI/LAB - DISPLAY TAX ;
  1.  ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
  1.  ;; ;
  1. EP ;EP - CALLED FROM OPTION
  1.  D EN
  1.  Q
  1.  ;; ;
  1. EN ;EP -- main entry point for 
  1.  D EN^VALM("ATX TAXONOMY GENERIC LIST")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  K ATXLIST,J,C
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. PAUSE ;EP
  1.  Q:$E(IOST)'="C"!(IO'=IO(0))
  1.  W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. HDR ; -- header code
  1.  S VALMHDR(1)="ADD OR EDIT "_$P(^ATXTYPE(ATXTAXT,0),U)_" TAXONOMIES"
  1.  S VALMHDR(2)="TAXONOMY NAME",$E(VALMHDR(2),38)="DESCRIPTION",$E(VALMHDR(2),70)="FILE"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  I ATXFILE=60 D LABINIT Q
  1.  K ATXLIST S ATXHIGH="",C=0
  1.  S J=0 F  S J=$O(^ATXAX(J)) Q:J'=+J  D
  1.  .I $P(^ATXAX(J,0),U,15)'=ATXFILE Q
  1.  .S C=C+1
  1.  .S D=$P(^ATXAX(J,0),U,2)
  1.  .S ATXLIST(C,0)=C_")  "_$P(^ATXAX(J,0),U),$E(ATXLIST(C,0),38)=D,$E(ATXLIST(C,0),70)=ATXFILE
  1.  .S ATXLIST("IDX",C,C)=J
  1.  .Q
  1.  S (VALMCNT,ATXHIGH)=C
  1.  Q
  1. LABINIT ;
  1.  K ATXLIST S ATXHIGH="",C=0
  1.  S J=0 F  S J=$O(^ATXLAB(J)) Q:J'=+J  D
  1.  .S C=C+1
  1.  .S D=$P(^ATXLAB(J,0),U,2)
  1.  .S ATXLIST(C,0)=C_")  "_$P(^ATXLAB(J,0),U),$E(ATXLIST(C,0),38)=D,$E(ATXLIST(C,0),70)=ATXFILE
  1.  .S ATXLIST("IDX",C,C)=J
  1.  .Q
  1.  S (VALMCNT,ATXHIGH)=C
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT
  1.  D HDR
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1.  ;
  1. SEL ;EP - add an item to the selected list - called from a protocol
  1.  D FULL^VALM1
  1.  W !
  1.  S DIR(0)="NO^1:"_ATXHIGH,DIR("A")="Which Taxonomy"
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No taxonomy selected." G ADDX
  1.  I $D(DIRUT) W !,"No taxonomy selected." G ADDX
  1.  S ATXTAXI=$P(ATXLIST("IDX",Y,Y),U,1),ATXTAXN=$S(ATXFILE=60:$P(^ATXLAB(ATXTAXI,0),U),1:$P(^ATXAX(ATXTAXI,0),U))
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  D EP^ATXTAXE
  1. ADDX ;
  1.  D BACK
  1.  Q
  1. ADDNEW ;EP  add new taxonomy of this type
  1.  D FULL^VALM1
  1.  I ATXFILE=60 D LABADD G ADDNEWX
  1.  NEW ATXN,ATXF,ATXADD,ATXFLG,ATXTAXI,ATXL,ATXQ
  1.  W !
  1.  S DIR(0)="F^3:30",DIR("A")="Enter Taxonomy Name" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G ADDNEWX
  1.  I Y="" G ADDNEWX
  1.  S ATXN=Y
  1.  S ATXF=$P(^ATXTYPE(ATXTAXT,0),U,2)
  1.  S X="",Y=0
  1.  F  S X=$O(^ATXAX("B",ATXN,X)) Q:X=""  I $P(^ATXAX(X,0),U,15)=ATXF S Y=Y+1,ATXL(X)=$P(^ATXAX(X,0),U,1)_"  created by: "_$$VAL^XBDIQ1(9002226,X,.05)
  1.  I $O(ATXL(0)) S ATXQ=0 D  I ATXQ G ADDNEW
  1.  .W !!,"There ",$S(Y>1:"are ",1:"is a "),$P(^DIC(ATXF,0),U,1),$S(Y>1:" taxonmies ",1:" taxonomy ")," with that name."
  1.  .S X=0 F  S X=$O(ATXL(X)) Q:X'=+X  W !?5,ATXL(X)
  1.  .S DIR(0)="Y",DIR("A")="Are you sure you want to create another one",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S ATXQ=1 Q
  1.  .I 'Y S ATXQ=1 Q
  1.  S ATXADD=1,ATXFLG=1
  1.  K DIC
  1.  S X=ATXN,DIC="^ATXAX("
  1.  ;,DIC("DR")=".02;5101",
  1.  S DIC(0)="L",DIADD=1,DLAYGO=902226 D ^DIC K DIC,DIADD,DLAYGO
  1.  I Y=-1 G ADDNEWX
  1.  S ATXTAXI=+Y
  1.  NEW ATXT,ATXNC
  1.  S ATXT=$O(^ATXTYPE("C",ATXFILE,0)),ATXNC=$P(^ATXTYPE(ATXT,0),U,4)
  1.  S DA=ATXTAXI,DIE="^ATXAX("
  1.  S DR=".05////"_DUZ_";.09////"_DT_";.12////"_$P(^ATXTYPE(ATXTAXT,0),U,3)_";.13////"_ATXNC_";.15////"_$P(^ATXTYPE(ATXTAXT,0),U,2)
  1.  D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !!,"error creating taxonomy........" S DA=ATXTAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX
  1.  S ATXTAXN=$P(^ATXAX(ATXTAXI,0),U)
  1.  D EP^ATXTAXE
  1. ADDNEWX ;
  1.  D BACK
  1.  Q
  1. LABADD ;
  1.  NEW ATXN,ATXF,ATXADD,ATXFLG,ATXTAXI,ATXL,ATXQ
  1.  W !
  1.  S DIR(0)="F^3:30",DIR("A")="Enter Taxonomy Name" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G ADDNEWX
  1.  I Y="" G ADDNEWX
  1.  S ATXN=Y
  1.  S ATXF=$P(^ATXTYPE(ATXTAXT,0),U,2)
  1.  S X="",Y=0
  1.  F  S X=$O(^ATXAX("B",ATXN,X)) Q:X=""  I $P(^ATXAX(X,0),U,15)=ATXF S Y=Y+1,ATXL(X)=$P(^ATXAX(X,0),U,1)_"  created by: "_$$VAL^XBDIQ1(9002226,X,.05)
  1.  I $O(ATXL(0)) S ATXQ=0 D  I ATXQ G ADDNEW
  1.  .W !!,"There ",$S(Y>1:"are ",1:"is a "),$P(^DIC(ATXF,0),U,1),$S(Y>1:" taxonmies ",1:" taxonomy ")," with that name."
  1.  .S X=0 F  S X=$O(ATXL(X)) Q:X'=+X  W !?5,ATXL(X)
  1.  .S DIR(0)="Y",DIR("A")="Are you sure you want to create another one",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S ATXQ=1 Q
  1.  .I 'Y S ATXQ=1 Q
  1.  K DIC
  1.  S X=ATXN,DIADD=1,DLAYGO=9002228,DIC="^ATXLAB(",DIC("DR")=".02;.15////60",DIC(0)="L" D ^DIC K DIC,DIADD,DLAYGO
  1.  I Y=-1 G ADDNEWX
  1.  S ATXTAXI=+Y
  1.  S DA=ATXTAXI,DIE="^ATXLAB("
  1.  S DR=".09////"_DT_";.11Should this taxonomy include Panels?"
  1.  D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !!,"error creating taxonomy........" S DA=ATXTAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX
  1.  S ATXTAXN=$P(^ATXLAB(ATXTAXI,0),U)
  1.  D EP^ATXTAXE
  1.  G ADDNEWX