source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX2.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1LEXNDX2 ; ISL Set/kill indexes (Part 2) ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4SS ; Get (unique) text for an expression in the Subset file
5 Q:'$D(X)!('$D(DA))
6 N LEXEXP,LEXMC,LEXTEXP,LEXOLDX S LEXOLDX=X
7 S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
8 S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
9 . S X=^LEX(757.01,LEXTEXP,0) D SS2
10 S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP Q
11SS2 ; Parse text and set node for each word
12 N LEXYPE,LEXT,LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
13 S LEXYPE=+($P($G(^LEX(757.01,LEXTEXP,1)),U,2)) Q:LEXYPE'>0
14 S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),"^",2)) Q:LEXT=0
15 S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
16 D PTX^LEXTOLKN
17 I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="" F LEXJ=1:1:^TMP("LEXTKN",$J,0) D
18 . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,""))
19 . S:'$D(^LEX(757.21,LEXSIDX,LEXI,DA)) ^LEX(757.21,LEXSIDX,LEXI,DA)=""
20 K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
21SK ; Get (all) text for an expression in the Subset file
22 Q:'$D(X)!('$D(DA))
23 N LEXEXP,LEXMC,LEXTEXP,LEXOLDX S LEXOLDX=X
24 S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
25 S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
26 . S X=^LEX(757.01,LEXTEXP,0) D SK2
27 S X=LEXOLDX K LEXOLDX,LEXEXP,LEXMC,LEXTEXP Q
28SK2 ; Parse text and kill node for each word
29 N LEXSIDX,LEXIDX,LEXD,LEXJ,LEXI S LEXIDX=""
30 S LEXSIDX="A"_$P(^LEXT(757.2,LEXOLDX,0),U,2)
31 D PTX^LEXTOLKN
32 I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 S LEXI="" F LEXJ=1:1:^TMP("LEXTKN",$J,0) D
33 . S LEXI=$O(^TMP("LEXTKN",$J,LEXJ,""))
34 . K ^LEX(757.21,LEXSIDX,LEXI,DA)
35 K LEXSIDX,LEXIDX,LEXD,LEXI,LEXJ,^TMP("LEXTKN",$J,0),^TMP("LEXTKN",$J) Q
36SET ; Given DIC and DA set indexes
37 Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
38 N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
39 S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
40 S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
41 . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
42 . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
43 . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
44 . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
45 . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
46 . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,1)
47 . . I DA>$P($G(@("^"_LEXRT_"("_LEXFN_",0)")),"^",3) S $P(@("^"_LEXRT_"("_LEXFN_",0)"),"^",3)=DA
48 K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
49 Q
50KILL ; Given DIC and DA kill indexes
51 Q:$D(DIC)#2=0!('$D(DA)) Q:DIC'["LEX("&(DIC'["LEX(")
52 N LEXRT,LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
53 S LEXFN=+($P(DIC,"(",2)),LEXRT=$TR($P(DIC,"(",1),"^","")
54 S LEXFL=0 F S LEXFL=$O(^DD(LEXFN,LEXFL)) Q:+LEXFL=0 D
55 . S LEXN=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",1)
56 . S LEXP=$P($P(^DD(LEXFN,LEXFL,0),U,4),";",2),LEXRIDX=0
57 . F S LEXRIDX=$O(^DD(LEXFN,LEXFL,1,LEXRIDX)) Q:+LEXRIDX=0 D
58 . . I $L($P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)) D
59 . . . S X=$P($G(@("^"_LEXRT_"("_LEXFN_","_DA_","_LEXN_")")),U,LEXP)
60 . . . X:X'="" ^DD(LEXFN,LEXFL,1,LEXRIDX,2)
61 K LEXFN,LEXFL,LEXRIDX,LEXN,LEXP,X
62 Q
63SAPP ; Set application subset definition index
64 I X'="" D
65 . N LEXIDX S LEXIDX=$P(^LEXT(757.2,DA,0),U,2) I LEXIDX'="" D
66 . . K ^LEXT(757.2,"AA",LEXIDX) S $P(^LEXT(757.2,DA,0),U,2)="" K LEXIDX
67 . S ^LEXT(757.2,"AB",X,DA)=""
68 Q
69KAPP ; Kill application subset definition index
70 K ^LEXT(757.2,"AB",X,DA) Q
71SSM ; Set index for Subset Mnemonic
72 S ^LEXT(757.2,"AA",X,DA)="" N LEXX,LEXLOW
73 S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
74 S:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA)="",^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)=""
75 I $L(LEXX) D
76 . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOLKN
77 . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
78 . . S ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)=""
79 . . S ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)=""
80 Q
81KSM ; Kill index for Subset Mnemonic
82 K ^LEXT(757.2,"AA",X,DA) N LEXX,LEXLOW
83 S LEXX=$P($G(^LEXT(757.2,DA,0)),U,1)
84 K:$L(LEXX) ^LEXT(757.2,"AA",LEXX,DA),^LEXT(757.2,"AA",$$UP^XLFSTR(LEXX),DA)
85 I $L(LEXX) D
86 . N X,LEXI S X=LEXX,LEXLOW="" D PTX^LEXTOLKN
87 . I +($G(^TMP("LEXTKN",$J,0)))>0 F LEXI=1:1:+($G(^TMP("LEXTKN",$J,0))) D
88 . . K ^LEXT(757.2,"AA",$O(^TMP("LEXTKN",$J,LEXI,"")),DA)
89 . . K ^LEXT(757.2,"AA",$$UP^XLFSTR($O(^TMP("LEXTKN",$J,LEXI,""))),DA)
90 Q
Note: See TracBrowser for help on using the repository browser.