LEXAM ;ISL/KER - Look-up Misc (Setup/Parse) ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^DD( ICR 345
; ^DIC( ICR 916
; ^TMP("LEXFND" SACC 2.3.2.5.1
; ^TMP("LEXHIT" SACC 2.3.2.5.1
; ^TMP("LEXSCH" SACC 2.3.2.5.1
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; None
;
SETUP(LEXSUB) ; Set up search variables
I '$L($G(LEXSUB)) D Q
. S LEX("ERR",0)=+($G(LEX("ERR",0)))+1
. S LEX("ERR",LEX("ERR",0))="Default Vocabulary missing or invalid"
S ^TMP("LEXSCH",$J,"VOC",0)=LEXSUB
I '$D(^LEXT(757.2,"AA",^TMP("LEXSCH",$J,"VOC",0))) D Q
. S LEX("ERR",0)=+($G(LEX("ERR",0)))+1
. S LEX("ERR",LEX("ERR",0))="Default Vocabulary missing or invalid"
N LEXSUBS S LEXSUBS=$O(^LEXT(757.2,"AA",^TMP("LEXSCH",$J,"VOC",0),0))
S ^TMP("LEXSCH",$J,"IDX",0)="A"_^TMP("LEXSCH",$J,"VOC",0)
I $D(^LEXT(757.2,LEXSUBS,1)) D
. S ^TMP("LEXSCH",$J,"GBL",0)=^LEXT(757.2,LEXSUBS,1)
. S ^TMP("LEXSCH",$J,"FLN",0)=+($P(^TMP("LEXSCH",$J,"GBL",0),"(",2))
. I +^TMP("LEXSCH",$J,"FLN",0)=0!('$D(^DD(+^TMP("LEXSCH",$J,"FLN",0)))) D Q
. . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1
. . S LEX("ERR",LEX("ERR",0))="File Number missing or invalid"
. I '$D(^DIC(^TMP("LEXSCH",$J,"FLN",0),0,"GL")) D Q
. . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1
. . S LEX("ERR",LEX("ERR",0))="Global Location missing or invalid"
. I $G(^DIC(^TMP("LEXSCH",$J,"FLN",0),0,"GL"))'=^TMP("LEXSCH",$J,"GBL",0) D Q
. . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1
. . S LEX("ERR",LEX("ERR",0))="Global Location missing or invalid"
. I $D(^TMP("LEXFND",$J)) D
. . N LEXI,LEXE S LEXI=-999999999,^TMP("LEXSCH",$J,"EXM",0)=""
. . F S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:LEXI=0!(^TMP("LEXSCH",$J,"EXM",0)'="") D
. . . S ^TMP("LEXSCH",$J,"EXM",0)=$O(^TMP("LEXFND",$J,LEXI,0)) S:+(^TMP("LEXSCH",$J,"EXM",0))=0 ^TMP("LEXSCH",$J,"EXM",0)=""
Q
;
; Entry D TOLKEN^LEXAM("USER INPUT")
; Returns LEXTKN(#)=TOLKEN LIST
;
; LEXFOC( Array by frequency of occurance
; LEXTKN( Array by frequency
; LEXTKNS( Array by input
;
; LEXLOOK Flag for PTX^LEXTOKN indicating parse for look-up
; LEXI Incremental counter
; LEXF Frequency of occurance
; LEXKEY Key for spell check
; LEXK Tolken
; LEXKF Tolken found
; LEXNK Next tolken
;
TOKEN(LEXX) ; Return list of tokens in ascending order of usage
Q:'$L($G(LEXX)) D PARSE,ORD K ^TMP("LEXTKN",$J) Q
PARSE ; Parse user input into tolkens
K ^TMP("LEXTKN",$J) N X,LEXLOOK S X=LEXX,LEXLOOK="" D PTX^LEXTOKN Q
ORD ; tolken list in frequency order
Q:'$D(^TMP("LEXTKN",$J,0)) K LEXFOC,LEXTKN N LEXKEY,LEXI,LEXF,LEXK,LEXCT
; Get possible key
S (LEXCT,LEXI)=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI=0 D
. S LEXK=$O(^TMP("LEXTKN",$J,LEXI,""))
. I $D(^LEX(757.01,"ASL",LEXK)) S LEXF=$O(^LEX(757.01,"ASL",LEXK,0)),LEXKEY(LEXF)=LEXK
I $D(LEXKEY) N LEXKF S LEXKF=$O(LEXKEY(0)),LEXKF=LEXKEY(LEXKF) K LEXKEY S LEXKEY=LEXKF
S:'$D(LEXKEY) LEXKEY=""
; Order by frequency
S (LEXCT,LEXI)=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI=0 D
. S LEXK=$O(^TMP("LEXTKN",$J,LEXI,""))
. I $D(^LEX(757.01,"ASL",LEXK)) D
. . N LEXNK S LEXNK=$$EXP^LEXAS6(LEXK)
. . I $D(^LEX(757.01,"ASL",LEXNK)),LEXNK[LEXK,$L(LEXNK)>$L(LEXK) S LEXK=LEXNK
. . S LEXCT=LEXCT+1,LEXF=$O(^LEX(757.01,"ASL",LEXK,0))
. . S LEXTKNS(LEXCT)=LEXK,LEXFOC(LEXF,LEXK)=""
. . S LEXTKNS(0)=LEXCT
. I '$D(^LEX(757.01,"ASL",LEXK)),$D(^LEX(757.01,"AWRD",LEXK)) D FRQ(LEXK) Q
. I '$D(^LEX(757.01,"ASL",LEXK)),'$D(^LEX(757.01,"AWRD",LEXK)) D
. . S LEXK=$$SPL^LEXAS(LEXK)
. . I LEXK["^" D Q
. . . N LEXF,LEXT S LEXF=$P(LEXK,"^",1),LEXT=$P(LEXK,"^",2)
. . . D FRQ(LEXF),FRQ(LEXT)
. . D FRQ(LEXK)
K ^TMP("LEXTKN",$J) Q:'$D(LEXFOC) S LEXI=-999999999,LEXF=0
F S LEXI=$O(LEXFOC(LEXI)) Q:+LEXI=0 D
. S LEXK="" F S LEXK=$O(LEXFOC(LEXI,LEXK)) Q:LEXK="" D
. . S LEXF=LEXF+1,LEXTKN(LEXF)=LEXK K LEXFOC(LEXI,LEXK)
S:LEXF>0 LEXTKN(0)=LEXF
Q
FRQ(LEXK) ; Frequency
I $D(^LEX(757.01,"ASL",LEXK)) D
. S LEXCT=LEXCT+1,LEXF=$O(^LEX(757.01,"ASL",LEXK,0))
. S LEXTKNS(LEXCT)=LEXK,LEXFOC(LEXF,LEXK)=""
. S LEXTKNS(0)=LEXCT
I '$D(^LEX(757.01,"ASL",LEXK)),$D(^LEX(757.01,"AWRD",LEXK)) D
. S LEXCT=LEXCT+1 N LEXC,LEXI S (LEXC,LEXI)=0
. F S LEXI=$O(^LEX(757.01,"AWRD",LEXK,LEXI)) Q:+LEXI=0 S LEXC=LEXC+1
. S LEXF=LEXC,LEXTKNS(LEXCT)=LEXK,LEXFOC(LEXF,LEXK)=""
. S LEXTKNS(0)=LEXCT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAM 4555 printed Apr 09, 2024@21:09:59 Page 2
LEXAM ;ISL/KER - Look-up Misc (Setup/Parse) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^DD( ICR 345
+5 ; ^DIC( ICR 916
+6 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+7 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
+8 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+9 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; None
+13 ;
SETUP(LEXSUB) ; Set up search variables
+1 IF '$LENGTH($GET(LEXSUB))
Begin DoDot:1
+2 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
+3 SET LEX("ERR",LEX("ERR",0))="Default Vocabulary missing or invalid"
End DoDot:1
QUIT
+4 SET ^TMP("LEXSCH",$JOB,"VOC",0)=LEXSUB
+5 IF '$DATA(^LEXT(757.2,"AA",^TMP("LEXSCH",$JOB,"VOC",0)))
Begin DoDot:1
+6 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
+7 SET LEX("ERR",LEX("ERR",0))="Default Vocabulary missing or invalid"
End DoDot:1
QUIT
+8 NEW LEXSUBS
SET LEXSUBS=$ORDER(^LEXT(757.2,"AA",^TMP("LEXSCH",$JOB,"VOC",0),0))
+9 SET ^TMP("LEXSCH",$JOB,"IDX",0)="A"_^TMP("LEXSCH",$JOB,"VOC",0)
+10 IF $DATA(^LEXT(757.2,LEXSUBS,1))
Begin DoDot:1
+11 SET ^TMP("LEXSCH",$JOB,"GBL",0)=^LEXT(757.2,LEXSUBS,1)
+12 SET ^TMP("LEXSCH",$JOB,"FLN",0)=+($PIECE(^TMP("LEXSCH",$JOB,"GBL",0),"(",2))
+13 IF +^TMP("LEXSCH",$JOB,"FLN",0)=0!('$DATA(^DD(+^TMP("LEXSCH",$JOB,"FLN",0))))
Begin DoDot:2
+14 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
+15 SET LEX("ERR",LEX("ERR",0))="File Number missing or invalid"
End DoDot:2
QUIT
+16 IF '$DATA(^DIC(^TMP("LEXSCH",$JOB,"FLN",0),0,"GL"))
Begin DoDot:2
+17 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
+18 SET LEX("ERR",LEX("ERR",0))="Global Location missing or invalid"
End DoDot:2
QUIT
+19 IF $GET(^DIC(^TMP("LEXSCH",$JOB,"FLN",0),0,"GL"))'=^TMP("LEXSCH",$JOB,"GBL",0)
Begin DoDot:2
+20 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
+21 SET LEX("ERR",LEX("ERR",0))="Global Location missing or invalid"
End DoDot:2
QUIT
+22 IF $DATA(^TMP("LEXFND",$JOB))
Begin DoDot:2
+23 NEW LEXI,LEXE
SET LEXI=-999999999
SET ^TMP("LEXSCH",$JOB,"EXM",0)=""
+24 FOR
SET LEXI=$ORDER(^TMP("LEXFND",$JOB,LEXI))
if LEXI=0!(^TMP("LEXSCH",$JOB,"EXM",0)'="")
QUIT
Begin DoDot:3
+25 SET ^TMP("LEXSCH",$JOB,"EXM",0)=$ORDER(^TMP("LEXFND",$JOB,LEXI,0))
if +(^TMP("LEXSCH",$JOB,"EXM",0))=0
SET ^TMP("LEXSCH",$JOB,"EXM",0)=""
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
+28 ; Entry D TOLKEN^LEXAM("USER INPUT")
+29 ; Returns LEXTKN(#)=TOLKEN LIST
+30 ;
+31 ; LEXFOC( Array by frequency of occurance
+32 ; LEXTKN( Array by frequency
+33 ; LEXTKNS( Array by input
+34 ;
+35 ; LEXLOOK Flag for PTX^LEXTOKN indicating parse for look-up
+36 ; LEXI Incremental counter
+37 ; LEXF Frequency of occurance
+38 ; LEXKEY Key for spell check
+39 ; LEXK Tolken
+40 ; LEXKF Tolken found
+41 ; LEXNK Next tolken
+42 ;
TOKEN(LEXX) ; Return list of tokens in ascending order of usage
+1 if '$LENGTH($GET(LEXX))
QUIT
DO PARSE
DO ORD
KILL ^TMP("LEXTKN",$JOB)
QUIT
PARSE ; Parse user input into tolkens
+1 KILL ^TMP("LEXTKN",$JOB)
NEW X,LEXLOOK
SET X=LEXX
SET LEXLOOK=""
DO PTX^LEXTOKN
QUIT
ORD ; tolken list in frequency order
+1 if '$DATA(^TMP("LEXTKN",$JOB,0))
QUIT
KILL LEXFOC,LEXTKN
NEW LEXKEY,LEXI,LEXF,LEXK,LEXCT
+2 ; Get possible key
+3 SET (LEXCT,LEXI)=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+4 SET LEXK=$ORDER(^TMP("LEXTKN",$JOB,LEXI,""))
+5 IF $DATA(^LEX(757.01,"ASL",LEXK))
SET LEXF=$ORDER(^LEX(757.01,"ASL",LEXK,0))
SET LEXKEY(LEXF)=LEXK
End DoDot:1
+6 IF $DATA(LEXKEY)
NEW LEXKF
SET LEXKF=$ORDER(LEXKEY(0))
SET LEXKF=LEXKEY(LEXKF)
KILL LEXKEY
SET LEXKEY=LEXKF
+7 if '$DATA(LEXKEY)
SET LEXKEY=""
+8 ; Order by frequency
+9 SET (LEXCT,LEXI)=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+10 SET LEXK=$ORDER(^TMP("LEXTKN",$JOB,LEXI,""))
+11 IF $DATA(^LEX(757.01,"ASL",LEXK))
Begin DoDot:2
+12 NEW LEXNK
SET LEXNK=$$EXP^LEXAS6(LEXK)
+13 IF $DATA(^LEX(757.01,"ASL",LEXNK))
IF LEXNK[LEXK
IF $LENGTH(LEXNK)>$LENGTH(LEXK)
SET LEXK=LEXNK
+14 SET LEXCT=LEXCT+1
SET LEXF=$ORDER(^LEX(757.01,"ASL",LEXK,0))
+15 SET LEXTKNS(LEXCT)=LEXK
SET LEXFOC(LEXF,LEXK)=""
+16 SET LEXTKNS(0)=LEXCT
End DoDot:2
+17 IF '$DATA(^LEX(757.01,"ASL",LEXK))
IF $DATA(^LEX(757.01,"AWRD",LEXK))
DO FRQ(LEXK)
QUIT
+18 IF '$DATA(^LEX(757.01,"ASL",LEXK))
IF '$DATA(^LEX(757.01,"AWRD",LEXK))
Begin DoDot:2
+19 SET LEXK=$$SPL^LEXAS(LEXK)
+20 IF LEXK["^"
Begin DoDot:3
+21 NEW LEXF,LEXT
SET LEXF=$PIECE(LEXK,"^",1)
SET LEXT=$PIECE(LEXK,"^",2)
+22 DO FRQ(LEXF)
DO FRQ(LEXT)
End DoDot:3
QUIT
+23 DO FRQ(LEXK)
End DoDot:2
End DoDot:1
+24 KILL ^TMP("LEXTKN",$JOB)
if '$DATA(LEXFOC)
QUIT
SET LEXI=-999999999
SET LEXF=0
+25 FOR
SET LEXI=$ORDER(LEXFOC(LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+26 SET LEXK=""
FOR
SET LEXK=$ORDER(LEXFOC(LEXI,LEXK))
if LEXK=""
QUIT
Begin DoDot:2
+27 SET LEXF=LEXF+1
SET LEXTKN(LEXF)=LEXK
KILL LEXFOC(LEXI,LEXK)
End DoDot:2
End DoDot:1
+28 if LEXF>0
SET LEXTKN(0)=LEXF
+29 QUIT
FRQ(LEXK) ; Frequency
+1 IF $DATA(^LEX(757.01,"ASL",LEXK))
Begin DoDot:1
+2 SET LEXCT=LEXCT+1
SET LEXF=$ORDER(^LEX(757.01,"ASL",LEXK,0))
+3 SET LEXTKNS(LEXCT)=LEXK
SET LEXFOC(LEXF,LEXK)=""
+4 SET LEXTKNS(0)=LEXCT
End DoDot:1
+5 IF '$DATA(^LEX(757.01,"ASL",LEXK))
IF $DATA(^LEX(757.01,"AWRD",LEXK))
Begin DoDot:1
+6 SET LEXCT=LEXCT+1
NEW LEXC,LEXI
SET (LEXC,LEXI)=0
+7 FOR
SET LEXI=$ORDER(^LEX(757.01,"AWRD",LEXK,LEXI))
if +LEXI=0
QUIT
SET LEXC=LEXC+1
+8 SET LEXF=LEXC
SET LEXTKNS(LEXCT)=LEXK
SET LEXFOC(LEXF,LEXK)=""
+9 SET LEXTKNS(0)=LEXCT
End DoDot:1
+10 QUIT
