ATXTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
;;5.1;TAXONOMY;**11**;FEB 4, 1997;Build 48
;; ;
EP ;EP - CALLED FROM OPTION
D EN
Q
EOJ ;EP
D EN^XBVK("ATX")
Q
;; ;
EN ;EP -- main entry point for
D EN^VALM("ATX TAXONOMY VIEW")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ; -- header code
S VALMHDR(1)="VIEW TAXONOMIES"
Q
;
INIT ;EP -- init variables and list array
K ATXTAX,ATXALL S ATXHIGH="",C=0,J=0
S ATXT=""
F S ATXT=$O(^ATXAX("B",ATXT)) Q:ATXT="" D
.S ATXY=0 F S ATXY=$O(^ATXAX("B",ATXT,ATXY)) Q:ATXY'=+ATXY D
..S ATXALL(ATXT,ATXY)=1
S ATXT=""
F S ATXT=$O(^ATXLAB("B",ATXT)) Q:ATXT="" D
.S ATXY=0 F S ATXY=$O(^ATXLAB("B",ATXT,ATXY)) Q:ATXY'=+ATXY D
..S ATXALL(ATXT,ATXY)=2
S ATXT="" F S ATXT=$O(ATXALL(ATXT)) Q:ATXT="" D
.S ATXY=0 F S ATXY=$O(ATXALL(ATXT,ATXY)) Q:ATXY'=+ATXY D
..S Z=ATXALL(ATXT,ATXY)
..I Z=1 S ATXFILE=$P(^ATXAX(ATXY,0),U,15),ATXDESC=$P(^ATXAX(ATXY,0),U,2),J=J+1
..I Z=2 S ATXFILE=60,ATXDESC=$P(^ATXLAB(ATXY,0),U,2),J=J+1
..S ATXTAX(J,0)=J_") "_ATXT
..S $E(ATXTAX(J,0),38)=$E($$VAL^XBDIQ1($S(Z=1:9002226,1:9002228),ATXY,.15),1,15)
..S $E(ATXTAX(J,0),55)=ATXDESC
..S ATXTAX("IDX",J,J)=ATXY_U_$S(Z'=2:"T",1:"L")_U_ATXY
..S C=C+1
.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
;
DISP ;EP - add an item to the selected list - called from a protocol
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 DISPX
I $D(DIRUT) W !,"No taxonomy selected." G DISPX
;S ATXFIEN=$P(ATXTAX("IDX",Y,Y),U,3)
S ATXSEL=Y
S ATXTIEN=$P(ATXTAX("IDX",Y,Y),U,1)
S ATXTYPE=$P(ATXTAX("IDX",Y,Y),U,2)
D EP^ATXTV1(ATXTIEN,ATXTYPE)
DISPX ;
D BACK
Q
ATXTV ; IHS/CMI/LAB - DISPLAY IND LISTS 15 Dec 2010 9:42 AM ;
+1 ;;5.1;TAXONOMY;**11**;FEB 4, 1997;Build 48
+2 ;; ;
EP ;EP - CALLED FROM OPTION
+1 DO EN
+2 QUIT
EOJ ;EP
+1 DO EN^XBVK("ATX")
+2 QUIT
+3 ;; ;
EN ;EP -- main entry point for
+1 DO EN^VALM("ATX TAXONOMY VIEW")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
HDR ; -- header code
+1 SET VALMHDR(1)="VIEW TAXONOMIES"
+2 QUIT
+3 ;
INIT ;EP -- init variables and list array
+1 KILL ATXTAX,ATXALL
SET ATXHIGH=""
SET C=0
SET J=0
+2 SET ATXT=""
+3 FOR
SET ATXT=$ORDER(^ATXAX("B",ATXT))
IF ATXT=""
QUIT
Begin DoDot:1
+4 SET ATXY=0
FOR
SET ATXY=$ORDER(^ATXAX("B",ATXT,ATXY))
IF ATXY'=+ATXY
QUIT
Begin DoDot:2
+5 SET ATXALL(ATXT,ATXY)=1
End DoDot:2
End DoDot:1
+6 SET ATXT=""
+7 FOR
SET ATXT=$ORDER(^ATXLAB("B",ATXT))
IF ATXT=""
QUIT
Begin DoDot:1
+8 SET ATXY=0
FOR
SET ATXY=$ORDER(^ATXLAB("B",ATXT,ATXY))
IF ATXY'=+ATXY
QUIT
Begin DoDot:2
+9 SET ATXALL(ATXT,ATXY)=2
End DoDot:2
End DoDot:1
+10 SET ATXT=""
FOR
SET ATXT=$ORDER(ATXALL(ATXT))
IF ATXT=""
QUIT
Begin DoDot:1
+11 SET ATXY=0
FOR
SET ATXY=$ORDER(ATXALL(ATXT,ATXY))
IF ATXY'=+ATXY
QUIT
Begin DoDot:2
+12 SET Z=ATXALL(ATXT,ATXY)
+13 IF Z=1
SET ATXFILE=$PIECE(^ATXAX(ATXY,0),U,15)
SET ATXDESC=$PIECE(^ATXAX(ATXY,0),U,2)
SET J=J+1
+14 IF Z=2
SET ATXFILE=60
SET ATXDESC=$PIECE(^ATXLAB(ATXY,0),U,2)
SET J=J+1
+15 SET ATXTAX(J,0)=J_") "_ATXT
+16 SET $EXTRACT(ATXTAX(J,0),38)=$EXTRACT($$VAL^XBDIQ1($SELECT(Z=1:9002226,1:9002228),ATXY,.15),1,15)
+17 SET $EXTRACT(ATXTAX(J,0),55)=ATXDESC
+18 SET ATXTAX("IDX",J,J)=ATXY_U_$SELECT(Z'=2:"T",1:"L")_U_ATXY
+19 SET C=C+1
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET (VALMCNT,ATXHIGH)=C
+22 QUIT
+23 ;
+24 ;
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 ;
DISP ;EP - add an item to the selected list - called from a protocol
+1 WRITE !
+2 SET DIR(0)="NO^1:"_ATXHIGH
SET DIR("A")="Which Taxonomy"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !,"No taxonomy selected."
GOTO DISPX
+5 IF $DATA(DIRUT)
WRITE !,"No taxonomy selected."
GOTO DISPX
+6 ;S ATXFIEN=$P(ATXTAX("IDX",Y,Y),U,3)
+7 SET ATXSEL=Y
+8 SET ATXTIEN=$PIECE(ATXTAX("IDX",Y,Y),U,1)
+9 SET ATXTYPE=$PIECE(ATXTAX("IDX",Y,Y),U,2)
+10 DO EP^ATXTV1(ATXTIEN,ATXTYPE)
DISPX ;
+1 DO BACK
+2 QUIT
