- LEXAM ;ISL/KER - Look-up Misc (Setup/Parse) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- ;
- ; 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
- LEXAM ;ISL/KER - Look-up Misc (Setup/Parse) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- +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
