LEXTOKN ;ISL/KER - Parse term into words ; 04/21/2014
;;2.0;LEXICON UTILITY;**80,150**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; DBIA #10104
;
; External References
; $$SW^LEXTOKN2
; ORD^LEXTOKN2
; ST^LEXTOKN2
; $$UP^XLFSTR
;
; Lexicon files accessed
; ^LEX(757.01 Expression File
; ^LEX(757.04 Excluded Words
; ^LEX(757.05 Replacement Words
;
; Local Variables NEWed or KILLed Elsewhere
; DA Set and Killed by Fileman
; LEXIDX Set if parsing for indexing logic (LEXNDX*)
; LEXLOOK Set if parsing for Lookup logic (LEXA)
; LEXLOW Set of lower case is needed (LEXNDX2)
;
; Returns ^TMP("LEXTKN",$J,#,WORD) containing words
;
; Special variables:
;
; LEXIDX If set, then the Excluded Words file is used
; to selectively exclude words from the indexing
; process and both singular and plural forms are
; indexed.
;
; LEXLOOK If set, then the Excluded Words file is used
; to selectively exclude words from the look-up
; process and only singular forms are used when
; one is found.
;
; If LEXIDX or LEXLOOK exist, then LEXLOW is ignored.
;
; If LEXIDX and LEXLOOK do not exist then ALL words are
; parsed and returned in the global array.
;
PT ; Entry point where DA is defined and X is unknown
Q:'$D(DA) S X=^LEX(757.01,DA,0)
PTX ; Entry point to parse string (X must exist)
N LEXOK,LEXTOKS,LEXTOKS2,LEXTOKI,LEXTOKW,LEXTOLKN
N LEXOKC,LEXOKN,LEXOKP,LEXTOKAA,LEXTOKAB,LEXTOKAC
; Prevent lowercase indexing and lookup
I $D(LEXIDX)!($D(LEXLOOK)) K LEXLOW
K ^TMP("LEXTKN",$J) Q:'$L($G(X)) S X=$$SW^LEXTOKN2($G(X))
S LEXTOKS=$TR(X,"-"," "),LEXTOKS=$TR(LEXTOKS,$C(9)," ")
; Remove leading blanks from string
F LEXOKP=1:1:$L(LEXTOKS) Q:$E(LEXTOKS,LEXOKP)'[" "
S LEXTOKS=$E(LEXTOKS,LEXOKP,$L(LEXTOKS))
; Remove trailing blanks from string
F LEXOKP=$L(LEXTOKS):-1:1 Q:$E(LEXTOKS,LEXOKP)'[" "
S LEXTOKS=$E(LEXTOKS,1,LEXOKP)
; Remove Punctuation (less slashes)
S LEXTOKS=$TR(LEXTOKS,"?`~!@#$%^&*()_-+={}[]\:;,<>"," ")
; Conditionally remove slashes
S:$D(LEXIDX) LEXTOKS=$TR(LEXTOKS,"/"," ")
S:$E($P(LEXTOKS,".",2),1)'?1(1N,1U) LEXTOKS=$TR(LEXTOKS,"."," ")
S LEXTOKS=$TR(LEXTOKS,"""","")
; Swtich to UPPERCASE (lower case is not specified by LEXLOW)
S:'$D(LEXLOW) LEXTOKS=$$UP^XLFSTR(LEXTOKS)
; Store in temporary array (based on space character)
S LEXOKC=0 F LEXTOKI=1:1:$L(LEXTOKS," ") D
. N LEXTOKW S LEXTOKW=$P(LEXTOKS," ",LEXTOKI) Q:LEXTOKW=""
. I LEXTOKW'["/" D
. . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=LEXTOKW
. . S LEXTOLKN(0)=LEXOKC
. I LEXTOKW["/"&('$D(^LEX(757.05,"B",LEXTOKW))) D Q
. . N LEXP S LEXP=0 F S LEXP=LEXP+1 Q:$P(LEXTOKW,"/",LEXP)="" D
. . . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=$P(LEXTOKW,"/",LEXP)
. . . S LEXTOLKN(0)=LEXOKC
. I LEXTOKW["/"&($D(^LEX(757.05,"B",LEXTOKW))) D
. . N LEXOKR S LEXOKR=$O(^LEX(757.05,"B",LEXTOKW,0))
. . I $P($G(^LEX(757.05,LEXOKR,0)),U,3)="R" D
. . . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=LEXTOKW
. . . S LEXTOLKN(0)=LEXOKC
K LEXOKC,LEXOKR
I +($G(LEXTOLKN(0)))=0 K LEXTOLKN S ^TMP("LEXTKN",$J,0)=0 G EXIT
S LEXTOKW="",LEXOKN=0 F LEXTOKI=1:1:LEXTOLKN(0) D
. S LEXTOKW=$G(LEXTOLKN(LEXTOKI))
. ; Remove leading blanks
. F LEXOKP=1:1:$L(LEXTOKW) Q:$E(LEXTOKW,LEXOKP)'[" "
. S LEXTOKW=$E(LEXTOKW,LEXOKP,$L(LEXTOKW))
. ; Remove trailing blanks
. F LEXOKP=$L(LEXTOKW):-1:1 Q:$E(LEXTOKW,LEXOKP)'[" "
. S LEXTOKW=$E(LEXTOKW,1,LEXOKP)
. ; Apostrophy "S"
. I $E(LEXTOKW,($L(LEXTOKW)-1),$L(LEXTOKW))["'S" S LEXTOKW=$E(LEXTOKW,1,($L(LEXTOKW)-2))
. ; Apostrophies and spaces
. S LEXTOKW=$TR(LEXTOKW,"'",""),LEXTOKW=$TR(LEXTOKW," ","")
. ; Excluded Words
. ; Exclude from Indexing
. I $D(LEXIDX) D
. . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"I")) LEXTOKW=""
. . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"B")) LEXTOKW=""
. ; Exclude from Lookup
. I $D(LEXLOOK) D
. . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"L")) LEXTOKW=""
. . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"B")) LEXTOKW=""
. I $D(LEXOKN),$L($G(LEXTOKW)) D
. . ; Replacement Words
. . I $P($G(^LEX(757.05,+($O(^LEX(757.05,"B",LEXTOKW,0))),0)),"^",3)="R" D REP(LEXTOKW) Q
. . I '$D(^TMP("LEXTKN",$J,"B",LEXTOKW)) D
. . . S LEXOKN=$O(^TMP("LEXTKN",$J," "),-1)+1
. . . S ^TMP("LEXTKN",$J,LEXOKN,LEXTOKW)=""
. . . S ^TMP("LEXTKN",$J,"B",LEXTOKW)=""
. S LEXTOKW=""
S LEXOKC=0 F S LEXOKC=$O(^TMP("LEXTKN",$J,LEXOKC)) Q:+LEXOKC'>0 D
. S LEXTOKW="" F S LEXTOKW=$O(^TMP("LEXTKN",$J,LEXOKC,LEXTOKW)) Q:'$L(LEXTOKW) D
. . N LEXSIN S LEXSIN=$$SIN(LEXTOKW) Q:'$L(LEXSIN)
. . I $D(LEXIDX) D
. . . S LEXI=$O(^TMP("LEXTKN",$J," "),-1)+1
. . . S ^TMP("LEXTKN",$J,LEXI,LEXSIN)="",^TMP("LEXTKN",$J,"B",LEXSIN)=""
. . I $D(LEXLOOK) D
. . . K ^TMP("LEXTKN",$J,LEXOKC,LEXTOKW),^TMP("LEXTKN",$J,"B",LEXTOKW)
. . . S ^TMP("LEXTKN",$J,LEXOKC,LEXSIN)="",^TMP("LEXTKN",$J,"B",LEXSIN)=""
S (LEXOKN,LEXOKC)=0 F S LEXOKC=$O(^TMP("LEXTKN",$J,LEXOKC)) Q:+LEXOKC'>0 S LEXOKN=LEXOKN+1
S ^TMP("LEXTKN",$J,0)=LEXOKN
K ^TMP("LEXTKN",$J,"B")
EXIT ; Clean up and quit PTX
K LEXOK,LEXTOKI,LEXOKN,LEXOKP,LEXOKR,LEXTOKS,LEXTOKS2,LEXTOKW,LEXTOLKN
Q
;
; Miscellaneous
ORD ; Reorder Global Array
D ORD^LEXTOKN2
Q
REP(X) ; Replace
N LEXREP,LEXTXT,LEXREF,LEXFLG,LEXARY,LEXIN,LEXWITH,LEXI,LEXO
S (LEXO,LEXFLG)=0,LEXIN=$G(X) Q:'$L(LEXIN)
S:$D(LEXIDX)&'$D(LEXLOOK) LEXFLG=1
S:'$D(LEXIDX)&$D(LEXLOOK) LEXFLG=2
S:$D(LEXIDX)&$D(LEXLOOK) LEXFLG=3
S LEXTXT=$P($G(^LEX(757.05,+($O(^LEX(757.05,"B",LEXIN,0))),0)),"^",2)
S LEXWITH=$$WITH(LEXTXT,.LEXARY,LEXFLG)
I LEXFLG=1 D
. Q:$D(LEXLOOK) Q:'$L(LEXIN)
. I '$D(^TMP("LEXTKN",$J,"B",LEXIN)) D
. . S LEXOKN=+($G(LEXOKN))+1
. . S ^TMP("LEXTKN",$J,LEXOKN,LEXIN)="",LEXO=1
. . S ^TMP("LEXTKN",$J,"B",LEXIN)=""
I LEXWITH>0 D
. N LEXI,LEXW S LEXI=0 F S LEXI=$O(LEXARY(LEXI)) Q:+LEXI'>0 D
. . S LEXW=$G(LEXARY(LEXI)) Q:'$L(LEXW)
. . I '$D(^TMP("LEXTKN",$J,"B",LEXW)) D
. . . S LEXOKN=+($G(LEXOKN))+1
. . . S ^TMP("LEXTKN",$J,LEXOKN,LEXW)="",LEXO=1
. . . S ^TMP("LEXTKN",$J,"B",LEXW)=""
Q LEXO
WITH(X,LEX,Y) ; Parse Replacement Words (replace with)
N LEXBEG,LEXEND,LEXCHR,LEXI,LEXNUM,LEXTXT,LEXWRD,LEXFLG
S LEXTXT=$$UP^XLFSTR(X) S LEXFLG=+($G(Y))
K LEX S LEXBEG=1 F LEXEND=1:1:$L(LEXTXT)+1 D
. S LEXCHR=$E(LEXTXT,LEXEND)
. I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR D
. . S LEXWRD=$E(LEXTXT,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1
. . I $L(LEXWRD)>1,$L(LEXWRD)<31,'$$EWD(LEXWRD,LEXFLG) D
. . . N LEXI S LEXI=$O(LEX(" "),-1)+1
. . . S LEX(LEXI)=LEXWRD,LEX(0)=LEXI
Q $G(LEX(0))
EWD(X,Y) ; Exclude from Replacement Words
N LEXW,LEXF,LEXO S LEXW=$G(X),LEXF=+($G(Y)),LEXO=0
I LEXF=1 S:$D(^LEX(757.04,"ACTION",LEXW,"I")) LEXO=1
I LEXF=2 S:$D(^LEX(757.04,"ACTION",LEXW,"L")) LEXO=1
I LEXF=3 D
. S:$D(^LEX(757.04,"ACTION",LEXW,"I")) LEXO=1
. S:$D(^LEX(757.04,"ACTION",LEXW,"L")) LEXO=1
I LEXF>0 S:$D(^LEX(757.04,"ACTION",LEXW,"B")) LEXO=1
Q LEXO
SIN(X) ; Singular
N LEXTMP,LEXI,LEXPW,LEXPC,LEXNW,LEXNC,LEXT
N LEXT S LEXT=$G(X) Q:$L(LEXT)'>4 "" Q:$E(LEXT,$L(LEXT))'="S" ""
S (X,LEXTMP)=$E(LEXT,1,($L(LEXT)-1)) Q:$D(LEXIDX) X S X="",LEXTMP=$E(LEXT,1,($L(LEXT)-1))
S LEXPW=$O(^LEX(757.01,"AWRD",LEXTMP),-1) S LEXNW=$O(^LEX(757.01,"AWRD",LEXTMP))
S LEXPC="" I $E(LEXPW,$L(LEXTMP))=$E(LEXTMP,$L(LEXTMP)) S LEXPC=$E(LEXPW,($L(LEXTMP)+1))
S LEXNC="" I $E(LEXNW,$L(LEXTMP))=$E(LEXTMP,$L(LEXTMP)) S LEXNC=$E(LEXNW,($L(LEXTMP)+1))
S X="" I $L((LEXPC_LEXNC)),((LEXPC="S")!(LEXNC="S")) S X=LEXTMP
I $L(LEXT)>4,$E(LEXT,$L(LEXT))="S",$E(LEXT,($L(LEXT)-1))'="S",$D(LEXLOOK) D
. N LEXTMP S LEXTMP=$E(LEXT,1,($L(LEXT)-1))
. I $L($G(LEXNW))>0,$L($G(LEXNW))=$L($G(LEXT)),$D(^LEX(757.01,"AWRD",LEXNW)) Q
. S:$D(^LEX(757.01,"AWRD",LEXTMP)) X=LEXTMP
Q X
ST ; Show ^TMP global array
N DA,LEXIDX,LEXLOOK,LEXLOW D ST^LEXTOKN2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXTOKN 8233 printed Jan 18, 2025@03:10:39 Page 2
LEXTOKN ;ISL/KER - Parse term into words ; 04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80,150**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; DBIA #10104
+8 ;
+9 ; External References
+10 ; $$SW^LEXTOKN2
+11 ; ORD^LEXTOKN2
+12 ; ST^LEXTOKN2
+13 ; $$UP^XLFSTR
+14 ;
+15 ; Lexicon files accessed
+16 ; ^LEX(757.01 Expression File
+17 ; ^LEX(757.04 Excluded Words
+18 ; ^LEX(757.05 Replacement Words
+19 ;
+20 ; Local Variables NEWed or KILLed Elsewhere
+21 ; DA Set and Killed by Fileman
+22 ; LEXIDX Set if parsing for indexing logic (LEXNDX*)
+23 ; LEXLOOK Set if parsing for Lookup logic (LEXA)
+24 ; LEXLOW Set of lower case is needed (LEXNDX2)
+25 ;
+26 ; Returns ^TMP("LEXTKN",$J,#,WORD) containing words
+27 ;
+28 ; Special variables:
+29 ;
+30 ; LEXIDX If set, then the Excluded Words file is used
+31 ; to selectively exclude words from the indexing
+32 ; process and both singular and plural forms are
+33 ; indexed.
+34 ;
+35 ; LEXLOOK If set, then the Excluded Words file is used
+36 ; to selectively exclude words from the look-up
+37 ; process and only singular forms are used when
+38 ; one is found.
+39 ;
+40 ; If LEXIDX or LEXLOOK exist, then LEXLOW is ignored.
+41 ;
+42 ; If LEXIDX and LEXLOOK do not exist then ALL words are
+43 ; parsed and returned in the global array.
+44 ;
PT ; Entry point where DA is defined and X is unknown
+1 if '$DATA(DA)
QUIT
SET X=^LEX(757.01,DA,0)
PTX ; Entry point to parse string (X must exist)
+1 NEW LEXOK,LEXTOKS,LEXTOKS2,LEXTOKI,LEXTOKW,LEXTOLKN
+2 NEW LEXOKC,LEXOKN,LEXOKP,LEXTOKAA,LEXTOKAB,LEXTOKAC
+3 ; Prevent lowercase indexing and lookup
+4 IF $DATA(LEXIDX)!($DATA(LEXLOOK))
KILL LEXLOW
+5 KILL ^TMP("LEXTKN",$JOB)
if '$LENGTH($GET(X))
QUIT
SET X=$$SW^LEXTOKN2($GET(X))
+6 SET LEXTOKS=$TRANSLATE(X,"-"," ")
SET LEXTOKS=$TRANSLATE(LEXTOKS,$CHAR(9)," ")
+7 ; Remove leading blanks from string
+8 FOR LEXOKP=1:1:$LENGTH(LEXTOKS)
if $EXTRACT(LEXTOKS,LEXOKP)'[" "
QUIT
+9 SET LEXTOKS=$EXTRACT(LEXTOKS,LEXOKP,$LENGTH(LEXTOKS))
+10 ; Remove trailing blanks from string
+11 FOR LEXOKP=$LENGTH(LEXTOKS):-1:1
if $EXTRACT(LEXTOKS,LEXOKP)'[" "
QUIT
+12 SET LEXTOKS=$EXTRACT(LEXTOKS,1,LEXOKP)
+13 ; Remove Punctuation (less slashes)
+14 SET LEXTOKS=$TRANSLATE(LEXTOKS,"?`~!@#$%^&*()_-+={}[]\:;,<>"," ")
+15 ; Conditionally remove slashes
+16 if $DATA(LEXIDX)
SET LEXTOKS=$TRANSLATE(LEXTOKS,"/"," ")
+17 if $EXTRACT($PIECE(LEXTOKS,".",2),1)'?1(1N,1U)
SET LEXTOKS=$TRANSLATE(LEXTOKS,"."," ")
+18 SET LEXTOKS=$TRANSLATE(LEXTOKS,"""","")
+19 ; Swtich to UPPERCASE (lower case is not specified by LEXLOW)
+20 if '$DATA(LEXLOW)
SET LEXTOKS=$$UP^XLFSTR(LEXTOKS)
+21 ; Store in temporary array (based on space character)
+22 SET LEXOKC=0
FOR LEXTOKI=1:1:$LENGTH(LEXTOKS," ")
Begin DoDot:1
+23 NEW LEXTOKW
SET LEXTOKW=$PIECE(LEXTOKS," ",LEXTOKI)
if LEXTOKW=""
QUIT
+24 IF LEXTOKW'["/"
Begin DoDot:2
+25 SET LEXOKC=LEXOKC+1
SET LEXTOLKN(LEXOKC)=LEXTOKW
+26 SET LEXTOLKN(0)=LEXOKC
End DoDot:2
+27 IF LEXTOKW["/"&('$DATA(^LEX(757.05,"B",LEXTOKW)))
Begin DoDot:2
+28 NEW LEXP
SET LEXP=0
FOR
SET LEXP=LEXP+1
if $PIECE(LEXTOKW,"/",LEXP)=""
QUIT
Begin DoDot:3
+29 SET LEXOKC=LEXOKC+1
SET LEXTOLKN(LEXOKC)=$PIECE(LEXTOKW,"/",LEXP)
+30 SET LEXTOLKN(0)=LEXOKC
End DoDot:3
End DoDot:2
QUIT
+31 IF LEXTOKW["/"&($DATA(^LEX(757.05,"B",LEXTOKW)))
Begin DoDot:2
+32 NEW LEXOKR
SET LEXOKR=$ORDER(^LEX(757.05,"B",LEXTOKW,0))
+33 IF $PIECE($GET(^LEX(757.05,LEXOKR,0)),U,3)="R"
Begin DoDot:3
+34 SET LEXOKC=LEXOKC+1
SET LEXTOLKN(LEXOKC)=LEXTOKW
+35 SET LEXTOLKN(0)=LEXOKC
End DoDot:3
End DoDot:2
End DoDot:1
+36 KILL LEXOKC,LEXOKR
+37 IF +($GET(LEXTOLKN(0)))=0
KILL LEXTOLKN
SET ^TMP("LEXTKN",$JOB,0)=0
GOTO EXIT
+38 SET LEXTOKW=""
SET LEXOKN=0
FOR LEXTOKI=1:1:LEXTOLKN(0)
Begin DoDot:1
+39 SET LEXTOKW=$GET(LEXTOLKN(LEXTOKI))
+40 ; Remove leading blanks
+41 FOR LEXOKP=1:1:$LENGTH(LEXTOKW)
if $EXTRACT(LEXTOKW,LEXOKP)'[" "
QUIT
+42 SET LEXTOKW=$EXTRACT(LEXTOKW,LEXOKP,$LENGTH(LEXTOKW))
+43 ; Remove trailing blanks
+44 FOR LEXOKP=$LENGTH(LEXTOKW):-1:1
if $EXTRACT(LEXTOKW,LEXOKP)'[" "
QUIT
+45 SET LEXTOKW=$EXTRACT(LEXTOKW,1,LEXOKP)
+46 ; Apostrophy "S"
+47 IF $EXTRACT(LEXTOKW,($LENGTH(LEXTOKW)-1),$LENGTH(LEXTOKW))["'S"
SET LEXTOKW=$EXTRACT(LEXTOKW,1,($LENGTH(LEXTOKW)-2))
+48 ; Apostrophies and spaces
+49 SET LEXTOKW=$TRANSLATE(LEXTOKW,"'","")
SET LEXTOKW=$TRANSLATE(LEXTOKW," ","")
+50 ; Excluded Words
+51 ; Exclude from Indexing
+52 IF $DATA(LEXIDX)
Begin DoDot:2
+53 IF LEXTOKW'=""
if $DATA(^LEX(757.04,"ACTION",LEXTOKW,"I"))
SET LEXTOKW=""
+54 IF LEXTOKW'=""
if $DATA(^LEX(757.04,"ACTION",LEXTOKW,"B"))
SET LEXTOKW=""
End DoDot:2
+55 ; Exclude from Lookup
+56 IF $DATA(LEXLOOK)
Begin DoDot:2
+57 IF LEXTOKW'=""
if $DATA(^LEX(757.04,"ACTION",LEXTOKW,"L"))
SET LEXTOKW=""
+58 IF LEXTOKW'=""
if $DATA(^LEX(757.04,"ACTION",LEXTOKW,"B"))
SET LEXTOKW=""
End DoDot:2
+59 IF $DATA(LEXOKN)
IF $LENGTH($GET(LEXTOKW))
Begin DoDot:2
+60 ; Replacement Words
+61 IF $PIECE($GET(^LEX(757.05,+($ORDER(^LEX(757.05,"B",LEXTOKW,0))),0)),"^",3)="R"
DO REP(LEXTOKW)
QUIT
+62 IF '$DATA(^TMP("LEXTKN",$JOB,"B",LEXTOKW))
Begin DoDot:3
+63 SET LEXOKN=$ORDER(^TMP("LEXTKN",$JOB," "),-1)+1
+64 SET ^TMP("LEXTKN",$JOB,LEXOKN,LEXTOKW)=""
+65 SET ^TMP("LEXTKN",$JOB,"B",LEXTOKW)=""
End DoDot:3
End DoDot:2
+66 SET LEXTOKW=""
End DoDot:1
+67 SET LEXOKC=0
FOR
SET LEXOKC=$ORDER(^TMP("LEXTKN",$JOB,LEXOKC))
if +LEXOKC'>0
QUIT
Begin DoDot:1
+68 SET LEXTOKW=""
FOR
SET LEXTOKW=$ORDER(^TMP("LEXTKN",$JOB,LEXOKC,LEXTOKW))
if '$LENGTH(LEXTOKW)
QUIT
Begin DoDot:2
+69 NEW LEXSIN
SET LEXSIN=$$SIN(LEXTOKW)
if '$LENGTH(LEXSIN)
QUIT
+70 IF $DATA(LEXIDX)
Begin DoDot:3
+71 SET LEXI=$ORDER(^TMP("LEXTKN",$JOB," "),-1)+1
+72 SET ^TMP("LEXTKN",$JOB,LEXI,LEXSIN)=""
SET ^TMP("LEXTKN",$JOB,"B",LEXSIN)=""
End DoDot:3
+73 IF $DATA(LEXLOOK)
Begin DoDot:3
+74 KILL ^TMP("LEXTKN",$JOB,LEXOKC,LEXTOKW),^TMP("LEXTKN",$JOB,"B",LEXTOKW)
+75 SET ^TMP("LEXTKN",$JOB,LEXOKC,LEXSIN)=""
SET ^TMP("LEXTKN",$JOB,"B",LEXSIN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+76 SET (LEXOKN,LEXOKC)=0
FOR
SET LEXOKC=$ORDER(^TMP("LEXTKN",$JOB,LEXOKC))
if +LEXOKC'>0
QUIT
SET LEXOKN=LEXOKN+1
+77 SET ^TMP("LEXTKN",$JOB,0)=LEXOKN
+78 KILL ^TMP("LEXTKN",$JOB,"B")
EXIT ; Clean up and quit PTX
+1 KILL LEXOK,LEXTOKI,LEXOKN,LEXOKP,LEXOKR,LEXTOKS,LEXTOKS2,LEXTOKW,LEXTOLKN
+2 QUIT
+3 ;
+4 ; Miscellaneous
ORD ; Reorder Global Array
+1 DO ORD^LEXTOKN2
+2 QUIT
REP(X) ; Replace
+1 NEW LEXREP,LEXTXT,LEXREF,LEXFLG,LEXARY,LEXIN,LEXWITH,LEXI,LEXO
+2 SET (LEXO,LEXFLG)=0
SET LEXIN=$GET(X)
if '$LENGTH(LEXIN)
QUIT
+3 if $DATA(LEXIDX)&'$DATA(LEXLOOK)
SET LEXFLG=1
+4 if '$DATA(LEXIDX)&$DATA(LEXLOOK)
SET LEXFLG=2
+5 if $DATA(LEXIDX)&$DATA(LEXLOOK)
SET LEXFLG=3
+6 SET LEXTXT=$PIECE($GET(^LEX(757.05,+($ORDER(^LEX(757.05,"B",LEXIN,0))),0)),"^",2)
+7 SET LEXWITH=$$WITH(LEXTXT,.LEXARY,LEXFLG)
+8 IF LEXFLG=1
Begin DoDot:1
+9 if $DATA(LEXLOOK)
QUIT
if '$LENGTH(LEXIN)
QUIT
+10 IF '$DATA(^TMP("LEXTKN",$JOB,"B",LEXIN))
Begin DoDot:2
+11 SET LEXOKN=+($GET(LEXOKN))+1
+12 SET ^TMP("LEXTKN",$JOB,LEXOKN,LEXIN)=""
SET LEXO=1
+13 SET ^TMP("LEXTKN",$JOB,"B",LEXIN)=""
End DoDot:2
End DoDot:1
+14 IF LEXWITH>0
Begin DoDot:1
+15 NEW LEXI,LEXW
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXARY(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+16 SET LEXW=$GET(LEXARY(LEXI))
if '$LENGTH(LEXW)
QUIT
+17 IF '$DATA(^TMP("LEXTKN",$JOB,"B",LEXW))
Begin DoDot:3
+18 SET LEXOKN=+($GET(LEXOKN))+1
+19 SET ^TMP("LEXTKN",$JOB,LEXOKN,LEXW)=""
SET LEXO=1
+20 SET ^TMP("LEXTKN",$JOB,"B",LEXW)=""
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT LEXO
WITH(X,LEX,Y) ; Parse Replacement Words (replace with)
+1 NEW LEXBEG,LEXEND,LEXCHR,LEXI,LEXNUM,LEXTXT,LEXWRD,LEXFLG
+2 SET LEXTXT=$$UP^XLFSTR(X)
SET LEXFLG=+($GET(Y))
+3 KILL LEX
SET LEXBEG=1
FOR LEXEND=1:1:$LENGTH(LEXTXT)+1
Begin DoDot:1
+4 SET LEXCHR=$EXTRACT(LEXTXT,LEXEND)
+5 IF "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR
Begin DoDot:2
+6 SET LEXWRD=$EXTRACT(LEXTXT,LEXBEG,LEXEND-1)
SET LEXBEG=LEXEND+1
+7 IF $LENGTH(LEXWRD)>1
IF $LENGTH(LEXWRD)<31
IF '$$EWD(LEXWRD,LEXFLG)
Begin DoDot:3
+8 NEW LEXI
SET LEXI=$ORDER(LEX(" "),-1)+1
+9 SET LEX(LEXI)=LEXWRD
SET LEX(0)=LEXI
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT $GET(LEX(0))
EWD(X,Y) ; Exclude from Replacement Words
+1 NEW LEXW,LEXF,LEXO
SET LEXW=$GET(X)
SET LEXF=+($GET(Y))
SET LEXO=0
+2 IF LEXF=1
if $DATA(^LEX(757.04,"ACTION",LEXW,"I"))
SET LEXO=1
+3 IF LEXF=2
if $DATA(^LEX(757.04,"ACTION",LEXW,"L"))
SET LEXO=1
+4 IF LEXF=3
Begin DoDot:1
+5 if $DATA(^LEX(757.04,"ACTION",LEXW,"I"))
SET LEXO=1
+6 if $DATA(^LEX(757.04,"ACTION",LEXW,"L"))
SET LEXO=1
End DoDot:1
+7 IF LEXF>0
if $DATA(^LEX(757.04,"ACTION",LEXW,"B"))
SET LEXO=1
+8 QUIT LEXO
SIN(X) ; Singular
+1 NEW LEXTMP,LEXI,LEXPW,LEXPC,LEXNW,LEXNC,LEXT
+2 NEW LEXT
SET LEXT=$GET(X)
if $LENGTH(LEXT)'>4
QUIT ""
if $EXTRACT(LEXT,$LENGTH(LEXT))'="S"
QUIT ""
+3 SET (X,LEXTMP)=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))
if $DATA(LEXIDX)
QUIT X
SET X=""
SET LEXTMP=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))
+4 SET LEXPW=$ORDER(^LEX(757.01,"AWRD",LEXTMP),-1)
SET LEXNW=$ORDER(^LEX(757.01,"AWRD",LEXTMP))
+5 SET LEXPC=""
IF $EXTRACT(LEXPW,$LENGTH(LEXTMP))=$EXTRACT(LEXTMP,$LENGTH(LEXTMP))
SET LEXPC=$EXTRACT(LEXPW,($LENGTH(LEXTMP)+1))
+6 SET LEXNC=""
IF $EXTRACT(LEXNW,$LENGTH(LEXTMP))=$EXTRACT(LEXTMP,$LENGTH(LEXTMP))
SET LEXNC=$EXTRACT(LEXNW,($LENGTH(LEXTMP)+1))
+7 SET X=""
IF $LENGTH((LEXPC_LEXNC))
IF ((LEXPC="S")!(LEXNC="S"))
SET X=LEXTMP
+8 IF $LENGTH(LEXT)>4
IF $EXTRACT(LEXT,$LENGTH(LEXT))="S"
IF $EXTRACT(LEXT,($LENGTH(LEXT)-1))'="S"
IF $DATA(LEXLOOK)
Begin DoDot:1
+9 NEW LEXTMP
SET LEXTMP=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))
+10 IF $LENGTH($GET(LEXNW))>0
IF $LENGTH($GET(LEXNW))=$LENGTH($GET(LEXT))
IF $DATA(^LEX(757.01,"AWRD",LEXNW))
QUIT
+11 if $DATA(^LEX(757.01,"AWRD",LEXTMP))
SET X=LEXTMP
End DoDot:1
+12 QUIT X
ST ; Show ^TMP global array
+1 NEW DA,LEXIDX,LEXLOOK,LEXLOW
DO ST^LEXTOKN2
+2 QUIT
