source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDVOS.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1LEXDVOS ; ISL Default Vocabulary - Select ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4 ; Special Look-up in file 757.2 Subset Definitions
5 ; Entry: S X=$$EN^LEXDVOS
6 ;
7 ; Function returns a 2 piece string
8 ;
9 ; $P 1 3 character subset mnemonic
10 ;
11 ; $P 2 Name of the subset
12 ;
13 ; LEX Array containing pointers to 757.2
14 ; LEXA Users answer to selection
15 ; LEXC Counter
16 ; LEXD Display
17 ; LEXF Re-display starting from #LEXF
18 ; LEXI Incremental Counter
19 ; LEXL Last entry displayed
20 ; LEXLN Line counter
21 ; LEXR Internal Entry Number (Record) in #757.2
22 ; LEXT Re-display up through #LEXT
23 ; LEXX Return value
24 ;
25EN(LEXX) ; Select a Vocabulary/Subset
26 N X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD D TOT
27 S LEXD="",(LEXA,LEXX,LEXC,LEXR)=0
28 F S LEXD=$O(^LEXT(757.2,"AA",LEXD)) Q:LEXD=""!(LEXA["^")!(+LEXX>0) D
29 . S LEXR=0
30 . F S LEXR=$O(^LEXT(757.2,"AA",LEXD,LEXR)) Q:+LEXR=0!(LEXA["^")!(+LEXX>0) D
31 . . Q:$P($G(^LEXT(757.2,LEXR,0)),"^",2)=""
32 . . Q:$L($P($G(^LEXT(757.2,LEXR,0)),"^",2))'=3
33 . . S LEXC=LEXC+1,LEXL=LEXC
34 . . S LEX(LEXC)=LEXR,LEX(0)=LEXC
35 . . D W(LEXC,LEXR)
36 . . D ASK
37 D ASK S LEXX=+LEXX K LEX
38 I +LEXX>0 S LEXX=$P($G(^LEXT(757.2,+LEXX,0)),"^",2)_"^"_$P($G(^LEXT(757.2,+LEXX,0)),"^",1) Q LEXX
39 S:LEXA'["^^" LEXX="^No vocabulary selected" S:LEXA["^^" LEXX="^^"
40 Q LEXX
41ASK ; Ask for user input
42 Q:+LEXX>0 Q:LEXA["^" Q:+LEXR>0&(LEXC#5'=0) Q:+LEXR=0&(LEXC#5=0)
43 D SEL Q:+LEXA'>0 Q:LEXA>LEXC S LEXX=$G(LEX(+LEXA))
44 Q
45SEL ; Select from list
46 W ! N X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
47 S DIR(0)="NAO^1:"_LEXC
48 S DIR("A")="Select SUBSET 1-"_LEXC_": "
49 S (DIR("?"),DIR("??"))="^D SH^LEXDVOS"
50 D ^DIR S LEXA=Y
51 Q
52UOUT ; Up Arrow detected
53 S:LEXA["^^" LEXX="^^"
54 S:LEXA="^" LEXX="^No vocabulary selected"
55 Q
56VAL ; No Un Arrow (value)
57 I +LEXX>0 D Q
58 . I $D(^LEX(757.41,+LEXX)) D Q
59 . . S LEXX=LEXX_"^"_$P($G(^LEX(757.41,+LEXX,0)),"^",1)
60 . S LEXX="^No vocabulary selected"
61 S LEXX="^No vocabulary selected"
62 Q
63SH ; Show help
64 N LEXR S LEXR=+($E(X,2,$L(X)))
65 I $E(X,1)="?",LEXR>0,LEXR<(LEX(0)+1) D
66 . S LEXR=LEX(LEXR) D:'$D(^LEXT(757.2,LEXR,100,1)) NODES,STD Q:'$D(^LEXT(757.2,LEXR,100,1)) D DES
67 D:$E(X,1)="?"&(LEXR<1!(LEXR>LEX(0))) STD D:$E(X,1)'="?" STD D RD
68 Q
69STD ; Standard Help
70 W !!,"Enter 1-",LEXC," to select a subset, or ""?"" for help, or ""?#"" for descriptive"
71 W !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
72 Q
73DES ; Description Help
74 N LEXLN,LEXI S (LEXLN,LEXI)=0
75 W !!,?2,$P(^LEXT(757.2,LEXR,0),"^",1),!
76 F S LEXI=$O(^LEXT(757.2,LEXR,100,LEXI)) Q:+LEXI=0 D
77 . W !,?4,^LEXT(757.2,LEXR,100,LEXI,0) S LEXLN=LEXLN+1
78 D:LEXLN>4 EOP W ! Q
79NODES ; No Description Help Available
80 W !!,?2,$P(^LEXT(757.2,LEXR,0),"^",1)," does not have a description",! Q
81RD ; Re-Display List
82 N LEXF,LEXT S LEXT=+($G(LEXL)),LEXF=(+(LEXT#5)-1)
83 S:LEXF<0 LEXF=4 S LEXF=LEXT-LEXF S LEXF=LEXF-1
84 F S LEXF=$O(LEX(LEXF)) Q:+LEXF=0!(LEXF'<(LEXT+1)) D
85 . W:LEXF=1 ! D W(LEXF,LEX(LEXF))
86 Q
87W(LEXC,LEXR) ; Write entry
88 W !,$J(LEXC,4),". ",$P(^LEXT(757.2,LEXR,0),"^",1)
89 W $S($D(^LEXT(757.2,LEXR,100,1)):" *",1:"") Q
90TOT ; Total Subsets
91 N LEXD,LEXR,LEXC S LEXD="",LEXC=0
92 F S LEXD=$O(^LEXT(757.2,"AA",LEXD)) Q:LEXD="" S LEXR=0 D
93 . F S LEXR=$O(^LEXT(757.2,"AA",LEXD,LEXR)) Q:+LEXR=0 S LEXC=LEXC+1
94 W !!,LEXC," Subsets found",!
95 Q
96EOP ; End of Page
97 W ! N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="E" D ^DIR S:X[U LEXA="^" W ! Q
Note: See TracBrowser for help on using the repository browser.