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