LEXTOKN2 ;ISL/KER - Parse term into words - Special Case ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
;
; Global Variables
; None
;
; External References
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXLOW Set of lower case is needed (LEXNDX2)
;
Q
SW(X) ; Special Case Word Swap
;
; This sub-routine swaps one word for another
; This swap must apply to both Lookup and Indexing
; This swap only applies to uppercase text
; These words cannot be Replacement Words in file 757.05
;
N LEXTXT S (X,LEXTXT)=$G(X) Q:'$L(LEXTXT) X
I '$D(LEXLOW) D Q X
. S (X,LEXTXT)=$$UP^XLFSTR(X) N LEXI
. F LEXI="X-RAY","X RAY" D
. . I LEXTXT[LEXI S LEXTXT=$$SWAP(LEXTXT,LEXI,"XRAY")
. F LEXI="E.COLI","E COLI","E. COLI" D
. . I LEXTXT[LEXI S LEXTXT=$$SWAP(LEXTXT,LEXI,"ECOLI")
. S X=$G(LEXTXT)
I $D(LEXLOW) D
. S (X,LEXTXT)=X N LEXI
. F LEXI="X-RAY","X RAY","X-Ray","X Ray","X-ray","X ray","x-ray","x ray" D
. . I LEXTXT[LEXI S LEXTXT=$$SWAP(LEXTXT,LEXI,"XRay")
. F LEXI="E COLI","E. COLI","E.COLI","ECOLI","E Coli","E. Coli","E.Coli","EColi" D
. . I LEXTXT[LEXI S LEXTXT=$$SWAP(LEXTXT,LEXI,"EColi")
. F LEXI="E coli","E. coli","E.coli","Ecoli","e coli","e. coli","e.coli","ecoli" D
. . I LEXTXT[LEXI S LEXTXT=$$SWAP(LEXTXT,LEXI,"EColi")
S X=LEXTXT
Q X
SWAP(X,LEX1,LEX2) ; Swap text LEX1 for LEX2 in X
;
; Input
;
; X Text string
; LEX1 Word to remove in string (replace)
; LEX2 Word to insert in string (with)
;
; Output
;
; X Text string without LEX1
;
N LEXTXT,LEXNOT,LEXC,LEXLC,LEXTC S (X,LEXTXT)=$G(X) Q:'$L(LEXTXT) X S LEX1=$G(LEX1)
Q:'$L(LEX1) X S LEX2=$G(LEX2) Q:'$L(LEX2) X Q:LEXTXT'[LEX1 X
S LEXNOT="~!@#$%^&*()_+`{}|[]\:;'<>?,./" I LEXTXT=LEX1 S X=LEX2 Q X
I $E(LEXTXT,1,$L(LEX1))=LEX1 D
. N LEXC S LEXC=$E(LEXTXT,($L(LEX1)+1)) Q:LEXC'=" "
. S LEXTXT=LEX2_$E(LEXTXT,($L(LEX1)+1),$L(LEXTXT))
F LEXLC=" ","-","(","<","{","[","," D
. N LEXO,LEXN F LEXTC=" ","-",")",">","}","]","," D
. . N LEXO,LEXN
. . S LEXO=LEXLC_LEX1_LEXTC,LEXN=LEXLC_LEX2_LEXTC
. . Q:LEXTXT'[LEXO
. . F Q:LEXTXT'[LEXO S LEXTXT=$P(LEXTXT,LEXO,1)_LEXN_$P(LEXTXT,LEXO,2)
. S LEXO=LEXLC_LEX1,LEXN=LEXLC_LEX2
. I LEXTXT[LEXO,$L($P(LEXTXT,LEXO,1)),'$L($P(LEXTXT,LEXO,2)) D
. . S LEXTXT=$P(LEXTXT,LEXO,1)_LEXN
S X=$G(LEXTXT)
Q X
ORD ; Arrange in Frequency Order
;
; Input
;
; ^TMP("LEXTKN",$J,#,WORD)=""
;
; Global array containing words parsed from text from
; API PTX^LEXTOKN
;
; "DIABETES MELLITUS KETOACIDOSIS" Parsed as:
;
; ^TMP("LEXTKN",$J,0)=3
; ^TMP("LEXTKN",$J,1,"DIABETES")=
; ^TMP("LEXTKN",$J,2,"MELLITUS")=
; ^TMP("LEXTKN",$J,3,"KETOACIDOSIS")=
;
; Output
;
; ^TMP("LEXTKN",$J,#,WORD)=FREQ
;
; Global array containing words parsed from text arranged
; in order of the frequency of use, the least used word is
; first and the most frequently used word is last.
;
; "DIABETES MELLITUS KETOACIDOSIS" Reordered to:
;
; ^TMP("LEXTKN",$J,0)=3
; ^TMP("LEXTKN",$J,1,"KETOACIDOSIS")=60
; ^TMP("LEXTKN",$J,2,"MELLITUS")=811
; ^TMP("LEXTKN",$J,3,"DIABETES")=1101
;
; The Lexicon searches terms containing the least used word
; and checks to see if the remaining words are found in the
; term. Instead of checking 1101 terms for MELLITUS and
; KETOACIDOSIS, it will check 60 terms for DIABETES and MELLITUS.
;
N LEXI,LEXA,LEXC,LEXF S LEXI=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
. N LEXT S LEXT="" F S LEXT=$O(^TMP("LEXTKN",$J,LEXI,LEXT)) Q:'$L(LEXT) D
. . N LEXF S LEXF=+($O(^LEX(757.01,"ASL",LEXT,0))) Q:LEXF'>0 S LEXA(+LEXF,LEXT)=LEXF
K ^TMP("LEXTKN",$J) S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. N LEXT S LEXT="" F S LEXT=$O(LEXA(LEXI,LEXT)) Q:'$L(LEXT) D
. . N LEXC S LEXC=$O(^TMP("LEXTKN",$J," "),-1)+1,^TMP("LEXTKN",$J,LEXC,LEXT)=LEXI,^TMP("LEXTKN",$J,0)=LEXC
Q
ST ; Show ^TMP("LEXTKN")
N LEXNN,LEXNC,LEXLOW S LEXNN="^TMP(""LEXTKN"","_$J_")",LEXNC="^TMP(""LEXTKN"","_$J_","
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) W !,LEXNN,"=",@LEXNN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXTOKN2 4367 printed Nov 22, 2024@17:19:52 Page 2
LEXTOKN2 ;ISL/KER - Parse term into words - Special Case ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ;
+4 ; Global Variables
+5 ; None
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10104
+9 ;
+10 ; Local Variables NEWed or KILLed Elsewhere
+11 ; LEXLOW Set of lower case is needed (LEXNDX2)
+12 ;
+13 QUIT
SW(X) ; Special Case Word Swap
+1 ;
+2 ; This sub-routine swaps one word for another
+3 ; This swap must apply to both Lookup and Indexing
+4 ; This swap only applies to uppercase text
+5 ; These words cannot be Replacement Words in file 757.05
+6 ;
+7 NEW LEXTXT
SET (X,LEXTXT)=$GET(X)
if '$LENGTH(LEXTXT)
QUIT X
+8 IF '$DATA(LEXLOW)
Begin DoDot:1
+9 SET (X,LEXTXT)=$$UP^XLFSTR(X)
NEW LEXI
+10 FOR LEXI="X-RAY","X RAY"
Begin DoDot:2
+11 IF LEXTXT[LEXI
SET LEXTXT=$$SWAP(LEXTXT,LEXI,"XRAY")
End DoDot:2
+12 FOR LEXI="E.COLI","E COLI","E. COLI"
Begin DoDot:2
+13 IF LEXTXT[LEXI
SET LEXTXT=$$SWAP(LEXTXT,LEXI,"ECOLI")
End DoDot:2
+14 SET X=$GET(LEXTXT)
End DoDot:1
QUIT X
+15 IF $DATA(LEXLOW)
Begin DoDot:1
+16 SET (X,LEXTXT)=X
NEW LEXI
+17 FOR LEXI="X-RAY","X RAY","X-Ray","X Ray","X-ray","X ray","x-ray","x ray"
Begin DoDot:2
+18 IF LEXTXT[LEXI
SET LEXTXT=$$SWAP(LEXTXT,LEXI,"XRay")
End DoDot:2
+19 FOR LEXI="E COLI","E. COLI","E.COLI","ECOLI","E Coli","E. Coli","E.Coli","EColi"
Begin DoDot:2
+20 IF LEXTXT[LEXI
SET LEXTXT=$$SWAP(LEXTXT,LEXI,"EColi")
End DoDot:2
+21 FOR LEXI="E coli","E. coli","E.coli","Ecoli","e coli","e. coli","e.coli","ecoli"
Begin DoDot:2
+22 IF LEXTXT[LEXI
SET LEXTXT=$$SWAP(LEXTXT,LEXI,"EColi")
End DoDot:2
End DoDot:1
+23 SET X=LEXTXT
+24 QUIT X
SWAP(X,LEX1,LEX2) ; Swap text LEX1 for LEX2 in X
+1 ;
+2 ; Input
+3 ;
+4 ; X Text string
+5 ; LEX1 Word to remove in string (replace)
+6 ; LEX2 Word to insert in string (with)
+7 ;
+8 ; Output
+9 ;
+10 ; X Text string without LEX1
+11 ;
+12 NEW LEXTXT,LEXNOT,LEXC,LEXLC,LEXTC
SET (X,LEXTXT)=$GET(X)
if '$LENGTH(LEXTXT)
QUIT X
SET LEX1=$GET(LEX1)
+13 if '$LENGTH(LEX1)
QUIT X
SET LEX2=$GET(LEX2)
if '$LENGTH(LEX2)
QUIT X
if LEXTXT'[LEX1
QUIT X
+14 SET LEXNOT="~!@#$%^&*()_+`{}|[]\:;'<>?,./"
IF LEXTXT=LEX1
SET X=LEX2
QUIT X
+15 IF $EXTRACT(LEXTXT,1,$LENGTH(LEX1))=LEX1
Begin DoDot:1
+16 NEW LEXC
SET LEXC=$EXTRACT(LEXTXT,($LENGTH(LEX1)+1))
if LEXC'=" "
QUIT
+17 SET LEXTXT=LEX2_$EXTRACT(LEXTXT,($LENGTH(LEX1)+1),$LENGTH(LEXTXT))
End DoDot:1
+18 FOR LEXLC=" ","-","(","<","{","[",","
Begin DoDot:1
+19 NEW LEXO,LEXN
FOR LEXTC=" ","-",")",">","}","]",","
Begin DoDot:2
+20 NEW LEXO,LEXN
+21 SET LEXO=LEXLC_LEX1_LEXTC
SET LEXN=LEXLC_LEX2_LEXTC
+22 if LEXTXT'[LEXO
QUIT
+23 FOR
if LEXTXT'[LEXO
QUIT
SET LEXTXT=$PIECE(LEXTXT,LEXO,1)_LEXN_$PIECE(LEXTXT,LEXO,2)
End DoDot:2
+24 SET LEXO=LEXLC_LEX1
SET LEXN=LEXLC_LEX2
+25 IF LEXTXT[LEXO
IF $LENGTH($PIECE(LEXTXT,LEXO,1))
IF '$LENGTH($PIECE(LEXTXT,LEXO,2))
Begin DoDot:2
+26 SET LEXTXT=$PIECE(LEXTXT,LEXO,1)_LEXN
End DoDot:2
End DoDot:1
+27 SET X=$GET(LEXTXT)
+28 QUIT X
ORD ; Arrange in Frequency Order
+1 ;
+2 ; Input
+3 ;
+4 ; ^TMP("LEXTKN",$J,#,WORD)=""
+5 ;
+6 ; Global array containing words parsed from text from
+7 ; API PTX^LEXTOKN
+8 ;
+9 ; "DIABETES MELLITUS KETOACIDOSIS" Parsed as:
+10 ;
+11 ; ^TMP("LEXTKN",$J,0)=3
+12 ; ^TMP("LEXTKN",$J,1,"DIABETES")=
+13 ; ^TMP("LEXTKN",$J,2,"MELLITUS")=
+14 ; ^TMP("LEXTKN",$J,3,"KETOACIDOSIS")=
+15 ;
+16 ; Output
+17 ;
+18 ; ^TMP("LEXTKN",$J,#,WORD)=FREQ
+19 ;
+20 ; Global array containing words parsed from text arranged
+21 ; in order of the frequency of use, the least used word is
+22 ; first and the most frequently used word is last.
+23 ;
+24 ; "DIABETES MELLITUS KETOACIDOSIS" Reordered to:
+25 ;
+26 ; ^TMP("LEXTKN",$J,0)=3
+27 ; ^TMP("LEXTKN",$J,1,"KETOACIDOSIS")=60
+28 ; ^TMP("LEXTKN",$J,2,"MELLITUS")=811
+29 ; ^TMP("LEXTKN",$J,3,"DIABETES")=1101
+30 ;
+31 ; The Lexicon searches terms containing the least used word
+32 ; and checks to see if the remaining words are found in the
+33 ; term. Instead of checking 1101 terms for MELLITUS and
+34 ; KETOACIDOSIS, it will check 60 terms for DIABETES and MELLITUS.
+35 ;
+36 NEW LEXI,LEXA,LEXC,LEXF
SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+37 NEW LEXT
SET LEXT=""
FOR
SET LEXT=$ORDER(^TMP("LEXTKN",$JOB,LEXI,LEXT))
if '$LENGTH(LEXT)
QUIT
Begin DoDot:2
+38 NEW LEXF
SET LEXF=+($ORDER(^LEX(757.01,"ASL",LEXT,0)))
if LEXF'>0
QUIT
SET LEXA(+LEXF,LEXT)=LEXF
End DoDot:2
End DoDot:1
+39 KILL ^TMP("LEXTKN",$JOB)
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+40 NEW LEXT
SET LEXT=""
FOR
SET LEXT=$ORDER(LEXA(LEXI,LEXT))
if '$LENGTH(LEXT)
QUIT
Begin DoDot:2
+41 NEW LEXC
SET LEXC=$ORDER(^TMP("LEXTKN",$JOB," "),-1)+1
SET ^TMP("LEXTKN",$JOB,LEXC,LEXT)=LEXI
SET ^TMP("LEXTKN",$JOB,0)=LEXC
End DoDot:2
End DoDot:1
+42 QUIT
ST ; Show ^TMP("LEXTKN")
+1 NEW LEXNN,LEXNC,LEXLOW
SET LEXNN="^TMP(""LEXTKN"","_$JOB_")"
SET LEXNC="^TMP(""LEXTKN"","_$JOB_","
+2 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
WRITE !,LEXNN,"=",@LEXNN
+3 QUIT
