source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX4.m@ 1704

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1LEXNDX4 ; ISL Set/kill indexes (Part 4) Link ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4LINK ; Link a Keyword to an expression
5 I $D(^LEX(757.05,DA,1,"B",1)) Q
6 W !,"LINK" S X=LEXBY D PTX^LEXTOLKN
7 I ^TMP("LEXTKN",$J,0)>0 S (LEXLINK,LEXKEY)="",LEXKEY=$O(^TMP("LEXTKN",$J,1,LEXKEY))
8 S LEXREC=0 F S LEXREC=$O(^LEX(757.01,"AWRD",LEXKEY,LEXREC)) Q:+LEXREC=0!(LEXLINK[U) D
9 . I ^TMP("LEXTKN",$J,0)=1 S LEXASK=1
10 . I ^TMP("LEXTKN",$J,0)>1 S LEXASK=1 D
11 . . F LEXA=2:1:^TMP("LEXTKN",$J,0) D
12 . . . S LEXAKEY="",LEXAKEY=$O(^TMP("LEXTKN",$J,LEXA,LEXAKEY))
13 . . . S LEXSRC=$$UP^XLFSTR(^LEX(757.01,LEXREC,0))
14 . . . I LEXSRC'[$E(LEXAKEY,1,4) S LEXASK=0
15 . S LEXLINK="" I LEXASK D
16 . . I $D(^LEX(757.05,DA,1,"B",LEXREC)) Q
17MOK . . ; Prompt to Map/Link a keyword to an expression
18 . . W !!,"Map ",^LEX(757.01,LEXREC,0),!,"To ",LEXREP,!,"OK" S %=1 D YN^DICN S LEXLINK=% I %=-1 W ! S LEXLINK=U Q
19 . . I '% W !!,"By answering ""Yes"", an index reference will be made to link the",!,"term to the key word ",LEXREP G MOK
20 . I +LEXLINK=1 D
21 . . N LEXYPE,LEXT S ^LEX(757.05,"ALINK",DA,LEXREC)=""
22 . . S LEXYPE=+($P($G(^LEX(757.01,LEXREC,1)),U,2))
23 . . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
24 . . S:+LEXT>0 ^LEX(757.01,"AWRD",LEXREP,LEXREC,"LINKED")="" W !
25 . . I $D(^LEX(757.05,DA,1,0)) D
26 . . . S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
27 . . . . S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
28 . . . I '$D(^LEX(757.05,DA,1,"B",LEXREC)) D
29 . . . . S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S LEXLNK=LEXSREC+1
30 . . . . K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=LEXREC
31 . . . . S ^LEX(757.05,DA,1,"B",LEXREC,LEXLNK)="",$P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
32 . . . . S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
33 . . I '$D(^LEX(757.05,DA,1,0)) S ^LEX(757.05,DA,1,1,0)=LEXREC,^LEX(757.05,DA,1,"B",LEXREC,1)="",^LEX(757.05,DA,1,0)="^757.53P^1^1"
34 D VERIFY K ^TMP("LEXTKN",$J),^TMP("LEXTKN",$J,0),LEXSRC,LEXKEY,LEXA,LEXAKEY,LEXREC,LEXASK,LEXLINK
35 Q
36VERIFY ; Display linkages made for user verification
37 Q:'$D(DA)
38 I '$D(^LEX(757.05,DA,1,0)) W !,"No Word Linkages Created",! Q
39 W !!,$P(^LEX(757.05,DA,0),"^",1)," has been linked to: ",!
40 N LEXSREC S LEXSREC=0
41 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
42 . W !,?4,$E(^LEX(757.01,^LEX(757.05,DA,1,LEXSREC,0),0),1,75)
43 W ! I +$$OK D K LEXSREC,LEXLNK Q
44 . S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S LEXLNK=LEXSREC+1
45 . K LEXSREC S ^LEX(757.05,DA,1,LEXLNK,0)=1,^LEX(757.05,DA,1,"B",1,LEXLNK)=""
46 . S $P(^LEX(757.05,DA,1,0),U,4)=$P(^LEX(757.05,DA,1,0),U,4)+1
47 . S $P(^LEX(757.05,DA,1,0),U,3)=LEXLNK K LEXLNK
48 D UNLINK
49 Q
50OK(LEXOK) ; Get user response
51OK1 ; Prompt "Is this correct"
52 W !,"Is this correct" S %=1 D YN^DICN
53 I %=-1!(%=2) K %,%Y Q 0
54 I %=1 K %,%Y Q 1
55 I '% D G OK1
56 . W !,"By confirming the word linkages displayed above, a look-up"
57 . W !,"conducted on ",$P(^LEX(757.05,DA,0),"^",1)
58 . W " will retrieve the linked terms."
59 Q 0
60RELINK ; Relink Keywords to expressions
61 Q:'$D(DA) Q:'$D(^LEX(757.05,DA,1,1,0))
62 D SUB N LEXMC,LEXCTR,LEXSREC,LEXERM S (LEXCTR,LEXSREC)=0,LEXERM=$P(^LEX(757.05,DA,0),"^",1)
63 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 D
64 . S LEXCTR=LEXCTR+1
65 . S ^LEX(757.05,DA,1,0)="^757.53P^"_LEXCTR_"^"_LEXCTR
66 . S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
67 . I ^LEX(757.05,DA,1,LEXSREC,0)'=1 D
68 . . S LEXMC=^LEX(757.05,DA,1,LEXSREC,0)
69 . . N LEXYPE,LEXT S LEXYPE=+($P($G(^LEX(757.01,LEXMC,1)),U,2))
70 . . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),U,2))
71 . . I +LEXT>0 D
72 . . . S ^LEX(757.01,"AWRD",LEXERM,LEXMC,"LINKED")=""
73 . . . N X S X=LEXERM D SSF^LEXNDX6
74 . . S ^LEX(757.05,"ALINK",DA,LEXMC)=""
75 K LEXSREC,LEXERM
76 Q
77UNLINK ; Unlink a Keyword from an expression
78 Q:'$D(^LEX(757.05,DA,1,0)) N LEXMC,LEXLNK
79 S LEXMC=0 F S LEXMC=$O(^LEX(757.05,DA,1,"B",LEXMC)) Q:+LEXMC=0 D
80 . S LEXLNK=0 F S LEXLNK=$O(^LEX(757.05,DA,1,"B",LEXMC,LEXLNK)) Q:+LEXLNK=0 D
81 . . S LEXWRD=$P(^LEX(757.05,DA,0),U,1)
82 . . K ^LEX(757.01,"AWRD",LEXWRD,LEXMC,"LINKED")
83 . . N X S X=LEXWRD D KSF^LEXNDX6
84 . . K ^LEX(757.05,"ALINK",DA,LEXMC)
85 . . I $D(X),X=0 K ^LEX(757.05,DA,1,LEXLNK,0),^LEX(757.05,DA,1,"B",LEXMC,LEXLNK),^LEX(757.05,DA,1,0)
86 K LEXLNK,LEXMC
87 Q
88SUB ; Index linked words in sub-file before UNLINK and RELINK
89 Q:'$D(DA) I $D(^LEX(757.05,DA,1,1,0)) N LEXSREC,LEXMC S LEXSREC=0 F S LEXSREC=$O(^LEX(757.05,DA,1,LEXSREC)) Q:+LEXSREC=0 S ^LEX(757.05,DA,1,"B",^LEX(757.05,DA,1,LEXSREC,0),LEXSREC)=""
90 Q
Note: See TracBrowser for help on using the repository browser.