XTLKKWL2 ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC- PART 3 OF LOOKUP CONTROL PROGRAM FOR "AND"ING INVERTED SEARCH ;07/22/93 15:47
;;7.3;TOOLKIT;;Apr 25, 1995
; XTLKKWCT,XTLKREF,XTLKREF2 ARE PASSED IN AND SHOULD NOT BE KILLED
; THE FOLLOWING ARE PASSED OUT AND SHOULD NOT BE KILLED:
; ^TMP($J,"ADFN"),^TMP($J,"AWRD"),XTLKDFN(),XTLKNUSE(),XTLKNWDS,
; XTLKPRTL(),XTLKWORD()
;
PREPSCH ; PREPARE FOR SEARCH BY BUILDING WORD/DFN TABLES
S XTLKNWDS=0
G:$O(XTLKWT(""))="" PREPSCHX
S XTLKNWS=^DD("KWIC")_"^IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"
W:XTLKSAY=1 "("
S XTLKWD=""=0
F XTLKQ=0:0 S XTLKWD=$O(XTLKWT(XTLKWD)) Q:XTLKWD="" D WDCHK
W:XTLKSAY=1 " )",!
PREPSCHX K XTLKWT,XTLKNWS,XTLKWD,XTLKQ
K XTLKEXAC,XTLKPART,XTLKSYN,XTLKINCR
Q
;
WDCHK ; DETERMINE IF PARTIAL OR EXACT MATCH
S XTLKWSAV=XTLKWD
S (XTLKISNT,XTLKFXAC)=0
RECHK I $E(XTLKWD)="'" S XTLKISNT=1,XTLKWD=$E(XTLKWD,2,255) G RECHK
I $E(XTLKWD)="~" S XTLKFXAC=1,XTLKWD=$E(XTLKWD,2,255) G RECHK
I XTLKWD?1N.E!(XTLKNWS[("^"_XTLKWD_"^")) S XTLKNUSE=XTLKNUSE+1,XTLKNUSE(XTLKWD)="" G WDCHKX
S XTLKINCR=0,XTLKSYN=$D(^XT(8984.3,"AC",$P(XTLKREF1,U,2),XTLKWD))
I 'XTLKSYN D CKWD G WDCHKX
S XTLKWDTX=$O(^XT(8984.3,"AC",$P(XTLKREF1,U,2),XTLKWD,0))
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
WDCHKX ;
S XTLKWD=XTLKWSAV
K XTLKWSAV,XTLKWX,XTLKISNT,XTLKFXAC,XTLKWDTX,XTLKWDSX
K XTLKI,XTLKJ
Q
CK ;
Q
CKWD ;
S XTLKEXAC=$S($D(@XTLKREF):1,1:0)
S XTLKWD2=$O(@XTLKREF)
S XTLKPART=('XTLKFXAC)&($L(XTLKWD)>2)&($S($E(XTLKWD2,1,$L(XTLKWD))=XTLKWD:1,1:0))
I 'XTLKEXAC&('XTLKPART)&($L(XTLKWD)>2) S XTLKWD=$E(XTLKWD,1,($L(XTLKWD)-1)) G CKWD
I 'XTLKEXAC,'XTLKPART S XTLKNUSE=XTLKNUSE+1,XTLKNUSE(XTLKWD)="" K XTLKWD2 Q
CKNOT I XTLKISNT S XTLKINCX=XTLKINCR,XTLKNWDX=XTLKNWDS,XTLKINCR=1,XTLKNWDS=0 D CKWD2 S XTLKINCR=XTLKINCX,XTLKNWDS=XTLKNWDX K XTLKISNT,XTLKINCX,XTLKNWDX Q
CKWD2 W:XTLKSAY=1 $S(XTLKSYN&XTLKINCR:"|",1:" ")_$S(XTLKFXAC:"~",1:"")_$S(XTLKISNT:"'",1:"")_XTLKWD ;W:PART&('FEXACT)&($E($O(@REF),1,$L(WD))=WD) "=>"
I 'XTLKSYN,XTLKEXAC,'XTLKPART,'XTLKISNT S XTLKNWDS=XTLKNWDS+1,XTLKPRTL(XTLKNWDS)=0,XTLKWORD(XTLKNWDS)=XTLKWD,XTLKDFN(XTLKNWDS)=$O(@XTLKREF2) Q
S:'XTLKINCR XTLKNWDS=XTLKNWDS+1,XTLKPRTL(XTLKNWDS)=1,XTLKWORD(XTLKNWDS)=XTLKWD
S XTLKWD2=XTLKWD
S XTLKN=0 S XTLKJ="" F XTLKQ=0:0 S XTLKJ=$O(^TMP($J,"AWRD",XTLKNWDS,XTLKJ)) Q:XTLKJ="" S XTLKN=XTLKJ
S XTLKN=XTLKN+1
I XTLKEXAC S ^TMP($J,"AWRD",XTLKNWDS,XTLKN)=XTLKWD,^TMP($J,"ADFN",XTLKNWDS,XTLKN)=$O(@XTLKREF2),XTLKN=XTLKN+1
CKWD3 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
S XTLKWD=XTLKWD2
S XTLKN=XTLKN-1
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)
S XTLKDFN(XTLKNWDS)=XTLKD
I 'XTLKSYN,XTLKN=1 S XTLKPRTL(XTLKNWDS)=0,XTLKWORD(XTLKNWDS)=^TMP($J,"AWRD",XTLKNWDS,1),XTLKDFN(XTLKNWDS)=^TMP($J,"ADFN",XTLKNWDS,1)
S XTLKINCR=1
K XTLKN,XTLKWD2,XTLKD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTLKKWL2 3149 printed Oct 16, 2024@18:42 Page 2
XTLKKWL2 ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC- PART 3 OF LOOKUP CONTROL PROGRAM FOR "AND"ING INVERTED SEARCH ;07/22/93 15:47
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 ; XTLKKWCT,XTLKREF,XTLKREF2 ARE PASSED IN AND SHOULD NOT BE KILLED
+3 ; THE FOLLOWING ARE PASSED OUT AND SHOULD NOT BE KILLED:
+4 ; ^TMP($J,"ADFN"),^TMP($J,"AWRD"),XTLKDFN(),XTLKNUSE(),XTLKNWDS,
+5 ; XTLKPRTL(),XTLKWORD()
+6 ;
PREPSCH ; PREPARE FOR SEARCH BY BUILDING WORD/DFN TABLES
+1 SET XTLKNWDS=0
+2 if $ORDER(XTLKWT(""))=""
GOTO PREPSCHX
+3 SET XTLKNWS=^DD("KWIC")_"^IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"
+4 if XTLKSAY=1
WRITE "("
+5 SET XTLKWD=""=0
+6 FOR XTLKQ=0:0
SET XTLKWD=$ORDER(XTLKWT(XTLKWD))
if XTLKWD=""
QUIT
DO WDCHK
+7 if XTLKSAY=1
WRITE " )",!
PREPSCHX KILL XTLKWT,XTLKNWS,XTLKWD,XTLKQ
+1 KILL XTLKEXAC,XTLKPART,XTLKSYN,XTLKINCR
+2 QUIT
+3 ;
WDCHK ; DETERMINE IF PARTIAL OR EXACT MATCH
+1 SET XTLKWSAV=XTLKWD
+2 SET (XTLKISNT,XTLKFXAC)=0
RECHK IF $EXTRACT(XTLKWD)="'"
SET XTLKISNT=1
SET XTLKWD=$EXTRACT(XTLKWD,2,255)
GOTO RECHK
+1 IF $EXTRACT(XTLKWD)="~"
SET XTLKFXAC=1
SET XTLKWD=$EXTRACT(XTLKWD,2,255)
GOTO RECHK
+2 IF XTLKWD?1N.E!(XTLKNWS[("^"_XTLKWD_"^"))
SET XTLKNUSE=XTLKNUSE+1
SET XTLKNUSE(XTLKWD)=""
GOTO WDCHKX
+3 SET XTLKINCR=0
SET XTLKSYN=$DATA(^XT(8984.3,"AC",$PIECE(XTLKREF1,U,2),XTLKWD))
+4 IF 'XTLKSYN
DO CKWD
GOTO WDCHKX
+5 SET XTLKWDTX=$ORDER(^XT(8984.3,"AC",$PIECE(XTLKREF1,U,2),XTLKWD,0))
+6 SET XTLKWX=XTLKWD
SET XTLKWDSX=0
FOR XTLKQ=0:0
SET XTLKWDSX=$ORDER(^XT(8984.3,XTLKWDTX,1,XTLKWDSX))
if 'XTLKWDSX
QUIT
SET XTLKWD=^(XTLKWDSX,0)
DO CKWD
WDCHKX ;
+1 SET XTLKWD=XTLKWSAV
+2 KILL XTLKWSAV,XTLKWX,XTLKISNT,XTLKFXAC,XTLKWDTX,XTLKWDSX
+3 KILL XTLKI,XTLKJ
+4 QUIT
CK ;
+1 QUIT
CKWD ;
+1 SET XTLKEXAC=$SELECT($DATA(@XTLKREF):1,1:0)
+2 SET XTLKWD2=$ORDER(@XTLKREF)
+3 SET XTLKPART=('XTLKFXAC)&($LENGTH(XTLKWD)>2)&($SELECT($EXTRACT(XTLKWD2,1,$LENGTH(XTLKWD))=XTLKWD:1,1:0))
+4 IF 'XTLKEXAC&('XTLKPART)&($LENGTH(XTLKWD)>2)
SET XTLKWD=$EXTRACT(XTLKWD,1,($LENGTH(XTLKWD)-1))
GOTO CKWD
+5 IF 'XTLKEXAC
IF 'XTLKPART
SET XTLKNUSE=XTLKNUSE+1
SET XTLKNUSE(XTLKWD)=""
KILL XTLKWD2
QUIT
CKNOT IF XTLKISNT
SET XTLKINCX=XTLKINCR
SET XTLKNWDX=XTLKNWDS
SET XTLKINCR=1
SET XTLKNWDS=0
DO CKWD2
SET XTLKINCR=XTLKINCX
SET XTLKNWDS=XTLKNWDX
KILL XTLKISNT,XTLKINCX,XTLKNWDX
QUIT
CKWD2 ;W:PART&('FEXACT)&($E($O(@REF),1,$L(WD))=WD) "=>"
if XTLKSAY=1
WRITE $SELECT(XTLKSYN&XTLKINCR:"|",1:" ")_$SELECT(XTLKFXAC:"~",1:"")_$SELECT(XTLKISNT:"'",1:"")_XTLKWD
+1 IF 'XTLKSYN
IF XTLKEXAC
IF 'XTLKPART
IF 'XTLKISNT
SET XTLKNWDS=XTLKNWDS+1
SET XTLKPRTL(XTLKNWDS)=0
SET XTLKWORD(XTLKNWDS)=XTLKWD
SET XTLKDFN(XTLKNWDS)=$ORDER(@XTLKREF2)
QUIT
+2 if 'XTLKINCR
SET XTLKNWDS=XTLKNWDS+1
SET XTLKPRTL(XTLKNWDS)=1
SET XTLKWORD(XTLKNWDS)=XTLKWD
+3 SET XTLKWD2=XTLKWD
+4 SET XTLKN=0
SET XTLKJ=""
FOR XTLKQ=0:0
SET XTLKJ=$ORDER(^TMP($JOB,"AWRD",XTLKNWDS,XTLKJ))
if XTLKJ=""
QUIT
SET XTLKN=XTLKJ
+5 SET XTLKN=XTLKN+1
+6 IF XTLKEXAC
SET ^TMP($JOB,"AWRD",XTLKNWDS,XTLKN)=XTLKWD
SET ^TMP($JOB,"ADFN",XTLKNWDS,XTLKN)=$ORDER(@XTLKREF2)
SET XTLKN=XTLKN+1
CKWD3 IF 'XTLKFXAC
FOR XTLKN=XTLKN:1
SET XTLKWD=$ORDER(@XTLKREF)
if $EXTRACT(XTLKWD,1,$LENGTH(XTLKWD2))'=XTLKWD2
QUIT
SET ^TMP($JOB,"AWRD",XTLKNWDS,XTLKN)=XTLKWD
SET ^TMP($JOB,"ADFN",XTLKNWDS,XTLKN)=$ORDER(@XTLKREF2)
if XTLKSAY=1
WRITE "/",XTLKWD
+1 SET XTLKWD=XTLKWD2
+2 SET XTLKN=XTLKN-1
+3 SET XTLKD=^TMP($JOB,"ADFN",XTLKNWDS,1)
FOR XTLKI=1:1:XTLKN
if ^TMP($JOB,"ADFN",XTLKNWDS,XTLKI)<XTLKD
SET XTLKD=^TMP($JOB,"ADFN",XTLKNWDS,XTLKI)
+4 SET XTLKDFN(XTLKNWDS)=XTLKD
+5 IF 'XTLKSYN
IF XTLKN=1
SET XTLKPRTL(XTLKNWDS)=0
SET XTLKWORD(XTLKNWDS)=^TMP($JOB,"AWRD",XTLKNWDS,1)
SET XTLKDFN(XTLKNWDS)=^TMP($JOB,"ADFN",XTLKNWDS,1)
+6 SET XTLKINCR=1
+7 KILL XTLKN,XTLKWD2,XTLKD
+8 QUIT
