source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTLKKWL2.m@ 1710

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

initial load of WorldVistAEHR

File size: 3.0 KB
RevLine 
[613]1XTLKKWL2 ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC- PART 3 OF LOOKUP CONTROL PROGRAM FOR "AND"ING INVERTED SEARCH ;07/22/93 15:47
2 ;;7.3;TOOLKIT;;Apr 25, 1995
3 ; XTLKKWCT,XTLKREF,XTLKREF2 ARE PASSED IN AND SHOULD NOT BE KILLED
4 ; THE FOLLOWING ARE PASSED OUT AND SHOULD NOT BE KILLED:
5 ; ^TMP($J,"ADFN"),^TMP($J,"AWRD"),XTLKDFN(),XTLKNUSE(),XTLKNWDS,
6 ; XTLKPRTL(),XTLKWORD()
7 ;
8PREPSCH ; PREPARE FOR SEARCH BY BUILDING WORD/DFN TABLES
9 S XTLKNWDS=0
10 G:$O(XTLKWT(""))="" PREPSCHX
11 S XTLKNWS=^DD("KWIC")_"^IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"
12 W:XTLKSAY=1 "("
13 S XTLKWD=""=0
14 F XTLKQ=0:0 S XTLKWD=$O(XTLKWT(XTLKWD)) Q:XTLKWD="" D WDCHK
15 W:XTLKSAY=1 " )",!
16PREPSCHX K XTLKWT,XTLKNWS,XTLKWD,XTLKQ
17 K XTLKEXAC,XTLKPART,XTLKSYN,XTLKINCR
18 Q
19 ;
20WDCHK ; DETERMINE IF PARTIAL OR EXACT MATCH
21 S XTLKWSAV=XTLKWD
22 S (XTLKISNT,XTLKFXAC)=0
23RECHK I $E(XTLKWD)="'" S XTLKISNT=1,XTLKWD=$E(XTLKWD,2,255) G RECHK
24 I $E(XTLKWD)="~" S XTLKFXAC=1,XTLKWD=$E(XTLKWD,2,255) G RECHK
25 I XTLKWD?1N.E!(XTLKNWS[("^"_XTLKWD_"^")) S XTLKNUSE=XTLKNUSE+1,XTLKNUSE(XTLKWD)="" G WDCHKX
26 S XTLKINCR=0,XTLKSYN=$D(^XT(8984.3,"AC",$P(XTLKREF1,U,2),XTLKWD))
27 I 'XTLKSYN D CKWD G WDCHKX
28 S XTLKWDTX=$O(^XT(8984.3,"AC",$P(XTLKREF1,U,2),XTLKWD,0))
29 S XTLKWX=XTLKWD,XTLKWDSX=0 F XTLKQ=0:0 S XTLKWDSX=$O(^XT(8984.3,XTLKWDTX,1,XTLKWDSX)) Q:'XTLKWDSX S XTLKWD=^(XTLKWDSX,0) D CKWD
30WDCHKX ;
31 S XTLKWD=XTLKWSAV
32 K XTLKWSAV,XTLKWX,XTLKISNT,XTLKFXAC,XTLKWDTX,XTLKWDSX
33 K XTLKI,XTLKJ
34 Q
35CK ;
36 Q
37CKWD ;
38 S XTLKEXAC=$S($D(@XTLKREF):1,1:0)
39 S XTLKWD2=$O(@XTLKREF)
40 S XTLKPART=('XTLKFXAC)&($L(XTLKWD)>2)&($S($E(XTLKWD2,1,$L(XTLKWD))=XTLKWD:1,1:0))
41 I 'XTLKEXAC&('XTLKPART)&($L(XTLKWD)>2) S XTLKWD=$E(XTLKWD,1,($L(XTLKWD)-1)) G CKWD
42 I 'XTLKEXAC,'XTLKPART S XTLKNUSE=XTLKNUSE+1,XTLKNUSE(XTLKWD)="" K XTLKWD2 Q
43CKNOT I XTLKISNT S XTLKINCX=XTLKINCR,XTLKNWDX=XTLKNWDS,XTLKINCR=1,XTLKNWDS=0 D CKWD2 S XTLKINCR=XTLKINCX,XTLKNWDS=XTLKNWDX K XTLKISNT,XTLKINCX,XTLKNWDX Q
44CKWD2 W:XTLKSAY=1 $S(XTLKSYN&XTLKINCR:"|",1:" ")_$S(XTLKFXAC:"~",1:"")_$S(XTLKISNT:"'",1:"")_XTLKWD ;W:PART&('FEXACT)&($E($O(@REF),1,$L(WD))=WD) "=>"
45 I 'XTLKSYN,XTLKEXAC,'XTLKPART,'XTLKISNT S XTLKNWDS=XTLKNWDS+1,XTLKPRTL(XTLKNWDS)=0,XTLKWORD(XTLKNWDS)=XTLKWD,XTLKDFN(XTLKNWDS)=$O(@XTLKREF2) Q
46 S:'XTLKINCR XTLKNWDS=XTLKNWDS+1,XTLKPRTL(XTLKNWDS)=1,XTLKWORD(XTLKNWDS)=XTLKWD
47 S XTLKWD2=XTLKWD
48 S XTLKN=0 S XTLKJ="" F XTLKQ=0:0 S XTLKJ=$O(^TMP($J,"AWRD",XTLKNWDS,XTLKJ)) Q:XTLKJ="" S XTLKN=XTLKJ
49 S XTLKN=XTLKN+1
50 I XTLKEXAC S ^TMP($J,"AWRD",XTLKNWDS,XTLKN)=XTLKWD,^TMP($J,"ADFN",XTLKNWDS,XTLKN)=$O(@XTLKREF2),XTLKN=XTLKN+1
51CKWD3 I 'XTLKFXAC F XTLKN=XTLKN:1 S XTLKWD=$O(@XTLKREF) Q:$E(XTLKWD,1,$L(XTLKWD2))'=XTLKWD2 S ^TMP($J,"AWRD",XTLKNWDS,XTLKN)=XTLKWD,^TMP($J,"ADFN",XTLKNWDS,XTLKN)=$O(@XTLKREF2) W:XTLKSAY=1 "/",XTLKWD
52 S XTLKWD=XTLKWD2
53 S XTLKN=XTLKN-1
54 S XTLKD=^TMP($J,"ADFN",XTLKNWDS,1) F XTLKI=1:1:XTLKN S:^TMP($J,"ADFN",XTLKNWDS,XTLKI)<XTLKD XTLKD=^TMP($J,"ADFN",XTLKNWDS,XTLKI)
55 S XTLKDFN(XTLKNWDS)=XTLKD
56 I 'XTLKSYN,XTLKN=1 S XTLKPRTL(XTLKNWDS)=0,XTLKWORD(XTLKNWDS)=^TMP($J,"AWRD",XTLKNWDS,1),XTLKDFN(XTLKNWDS)=^TMP($J,"ADFN",XTLKNWDS,1)
57 S XTLKINCR=1
58 K XTLKN,XTLKWD2,XTLKD
59 Q
Note: See TracBrowser for help on using the repository browser.