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

APCLTAXT.m

Go to the documentation of this file. 
  1. APCLTAXT ; IHS/CMI/LAB - DISPLAY TAX ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;; ;
  1. EP ;EP - CALLED FROM OPTION
  1.  D EN
  1.  Q
  1.  ;; ;
  1. EN ;EP -- main entry point for 
  1.  D EN^VALM("APCL TAXONOMY GENERIC LIST")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  K APCLLIST,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(APCLTAXT,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 APCLFILE=60 D LABINIT Q
  1.  K APCLLIST S APCLHIGH="",C=0
  1.  S J=0 F  S J=$O(^ATXAX(J)) Q:J'=+J  D
  1.  .I $P(^ATXAX(J,0),U,15)'=APCLFILE Q
  1.  .S C=C+1
  1.  .S D=$P(^ATXAX(J,0),U,2)
  1.  .S APCLLIST(C,0)=C_")  "_$P(^ATXAX(J,0),U),$E(APCLLIST(C,0),38)=D,$E(APCLLIST(C,0),70)=APCLFILE
  1.  .S APCLLIST("IDX",C,C)=J
  1.  .Q
  1.  S (VALMCNT,APCLHIGH)=C
  1.  Q
  1. LABINIT ;
  1.  K APCLLIST S APCLHIGH="",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 APCLLIST(C,0)=C_")  "_$P(^ATXLAB(J,0),U),$E(APCLLIST(C,0),38)=D,$E(APCLLIST(C,0),70)=APCLFILE
  1.  .S APCLLIST("IDX",C,C)=J
  1.  .Q
  1.  S (VALMCNT,APCLHIGH)=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:"_APCLHIGH,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 APCLTAXI=$P(APCLLIST("IDX",Y,Y),U,1),APCLTAXN=$S(APCLFILE=60:$P(^ATXLAB(APCLTAXI,0),U),1:$P(^ATXAX(APCLTAXI,0),U))
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  D EP^APCLTAXE
  1. ADDX ;
  1.  D BACK
  1.  Q
  1. ADDNEW ;EP  add new taxonomy of this type
  1.  I APCLFILE=60 D LABADD G ADDNEWX
  1.  S ATXADD=1,ATXFLG=1
  1.  K DIC
  1.  S DIC="^ATXAX(",DIC("DR")=".02",DIC(0)="AEMLQ" D ^DIC K DIC
  1.  I Y=-1 G ADDNEWX
  1.  S APCLTAXI=+Y
  1.  S DA=APCLTAXI,DIE="^ATXAX("
  1.  S DR=".09////"_DT_";.12////"_$P(^ATXTYPE(APCLTAXT,0),U,3)_";.13////"_$S(APCLFILE=80:1,APCLFILE=80.1:1,APCLFILE=81:1,1:"")_";.15////"_$P(^ATXTYPE(APCLTAXT,0),U,2)
  1.  D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !!,"error creating taxonomy........" S DA=APCLTAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX
  1.  S APCLTAXN=$P(^ATXAX(APCLTAXI,0),U)
  1.  D EP^APCLTAXE
  1. ADDNEWX ;
  1.  D BACK
  1.  Q
  1. LABADD ;
  1.  K DIC
  1.  S DIC="^ATXLAB(",DIC("DR")=".02",DIC(0)="AEMLQ" D ^DIC K DIC
  1.  I Y=-1 G ADDNEWX
  1.  S APCLTAXI=+Y
  1.  S DA=APCLTAXI,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=APCLTAXI,DIK="^ATXAX(" D ^DIK K DIK,DA D PAUSE G ADDNEWX
  1.  S APCLTAXN=$P(^ATXLAB(APCLTAXI,0),U)
  1.  D EP^APCLTAXE
  1.  G ADDNEWX