- 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
