LEXAB ;ISL/KER - Look-up Exact Match "B" index ;04/21/2014
;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^TMP("LEXFND" SACC 2.3.2.5.1
; ^TMP("LEXSCH" SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10104
;
; Exact match S X=$$EN^LEXAB("LEXSCH",LEXVDT)
;
; INPUT
; LEXSCH User input string to search for
; LEXVDT Date used to screen out inactive codes
;
; Notes:
;
; 1. If an exact match is found, it is placed at
; the top of the selection list at
; ^TMP("LEXFND",$J)
;
; 2. Returns
;
; 0 - Exact match not found
; 1 - Exact match found
;
EN(LEXSCH,LEXVDT) ; Check "B" index for exact match
Q:'$L(LEXSCH) 0
N LEXLKGL,LEXEM,LEXEMC,LEXLKT S LEXLKT="AB",LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)),LEXEMC=0
Q:$G(LEXLKGL)'["757.01" 0
D VDT^LEXU N LEXSHOW S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
N LEXO,LEXE,LEXOK,LEXDES,LEXDSP
S (LEXE,LEXOK)=0,LEXO=$$SCH(LEXSCH)
F S LEXO=$O(^LEX(757.01,"B",LEXO)) Q:LEXO=""!(LEXSCH'[LEXO) D
. S (LEXE,LEXOK)=0
. F S LEXE=$O(^LEX(757.01,"B",LEXO,LEXE)) Q:+LEXE=0 D
. . Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
. . I $$UP^XLFSTR(LEXSCH)=$$UP^XLFSTR($G(^LEX(757.01,LEXE,0))) D
. . . S LEXEMC=+($G(LEXEMC)),LEXEMC=LEXEMC+1,LEXEM=LEXE
S:+($G(LEXEMC))=1 LEXOK=$G(LEXEM) S:+($G(LEXEMC))'=1 LEXOK=0
; Exact Match Found
I +LEXOK>0 D
. S LEXE=LEXOK
. ; Filter
. S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
. ; Deactivated
. Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
. S LEXDES=$$DES(LEXE)
. S LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
. D ADDE^LEXAL(LEXE,LEXDES,LEXDSP)
. S ^TMP("LEXSCH",$J,"EXM",0)=LEXE
. S ^TMP("LEXSCH",$J,"EXM",1)=$G(^LEX(757.01,+LEXE,0))
. I '$D(^LEX(757,"B",LEXE)) D
. . N LEXME,LEXM S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
. . S LEXME=+($G(^LEX(757,LEXM,0))) Q:LEXM=0 Q:LEXE=LEXME
. . I +($G(^LEX(757.01,LEXME,1)))=LEXM D
. . . S LEXDES=$$DES(LEXME),LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
. . . D ADDEM^LEXAL(LEXME,LEXDES,LEXDSP)
. . . S ^TMP("LEXSCH",$J,"EXC",0)=LEXME
. . . S ^TMP("LEXSCH",$J,"EXC",1)=$G(^LEX(757.01,+LEXME,0))
Q:$D(^TMP("LEXFND",$J)) 1
Q 0
DES(LEXX) ; Get description flag
N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
S LEXX=$G(LEXDES) Q LEXX
TERM(LEXX) ; Get expression
Q $G(^LEX(757.01,LEXX,0))
DSP(LEXX,LEXDSP,LEXVDT) ; Return displayable text
N LEXMCE S LEXMCE=+($G(^LEX(757,+($G(^LEX(757.01,LEXX,1))),0)))
I +LEXMCE>0,$D(^LEX(757.01,+LEXMCE,0)) S LEXX=$$SO^LEXASO(+LEXMCE,LEXDSP,1,$G(LEXVDT)) Q LEXX
S LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT)) Q LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
S LEXX=$$UP^XLFSTR($E(LEXX,1,63)) N LEXIGN
S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
LEXAB ;ISL/KER - Look-up Exact Match "B" index ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+5 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10104
+9 ;
+10 ; Exact match S X=$$EN^LEXAB("LEXSCH",LEXVDT)
+11 ;
+12 ; INPUT
+13 ; LEXSCH User input string to search for
+14 ; LEXVDT Date used to screen out inactive codes
+15 ;
+16 ; Notes:
+17 ;
+18 ; 1. If an exact match is found, it is placed at
+19 ; the top of the selection list at
+20 ; ^TMP("LEXFND",$J)
+21 ;
+22 ; 2. Returns
+23 ;
+24 ; 0 - Exact match not found
+25 ; 1 - Exact match found
+26 ;
EN(LEXSCH,LEXVDT) ; Check "B" index for exact match
+1 IF '$LENGTH(LEXSCH)
QUIT 0
+2 NEW LEXLKGL,LEXEM,LEXEMC,LEXLKT
SET LEXLKT="AB"
SET LEXLKGL=$GET(^TMP("LEXSCH",$JOB,"GBL",0))
SET LEXEMC=0
+3 IF $GET(LEXLKGL)'["757.01"
QUIT 0
+4 DO VDT^LEXU
NEW LEXSHOW
SET LEXSHOW=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
+5 NEW LEXO,LEXE,LEXOK,LEXDES,LEXDSP
+6 SET (LEXE,LEXOK)=0
SET LEXO=$$SCH(LEXSCH)
+7 FOR
SET LEXO=$ORDER(^LEX(757.01,"B",LEXO))
IF LEXO=""!(LEXSCH'[LEXO)
QUIT
Begin DoDot:1
+8 SET (LEXE,LEXOK)=0
+9 FOR
SET LEXE=$ORDER(^LEX(757.01,"B",LEXO,LEXE))
IF +LEXE=0
QUIT
Begin DoDot:2
+10 IF '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+11 IF $$UP^XLFSTR(LEXSCH)=$$UP^XLFSTR($GET(^LEX(757.01,LEXE,0)))
Begin DoDot:3
+12 SET LEXEMC=+($GET(LEXEMC))
SET LEXEMC=LEXEMC+1
SET LEXEM=LEXE
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF +($GET(LEXEMC))=1
SET LEXOK=$GET(LEXEM)
IF +($GET(LEXEMC))'=1
SET LEXOK=0
+14 ; Exact Match Found
+15 IF +LEXOK>0
Begin DoDot:1
+16 SET LEXE=LEXOK
+17 ; Filter
+18 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),LEXE)
IF LEXFILR=0
QUIT
+19 ; Deactivated
+20 IF '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+21 SET LEXDES=$$DES(LEXE)
+22 SET LEXDSP=""
IF $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+23 DO ADDE^LEXAL(LEXE,LEXDES,LEXDSP)
+24 SET ^TMP("LEXSCH",$JOB,"EXM",0)=LEXE
+25 SET ^TMP("LEXSCH",$JOB,"EXM",1)=$GET(^LEX(757.01,+LEXE,0))
+26 IF '$DATA(^LEX(757,"B",LEXE))
Begin DoDot:2
+27 NEW LEXME,LEXM
SET LEXM=+($GET(^LEX(757.01,LEXE,1)))
IF LEXM=0
QUIT
+28 SET LEXME=+($GET(^LEX(757,LEXM,0)))
IF LEXM=0
QUIT
IF LEXE=LEXME
QUIT
+29 IF +($GET(^LEX(757.01,LEXME,1)))=LEXM
Begin DoDot:3
+30 SET LEXDES=$$DES(LEXME)
SET LEXDSP=""
IF $LENGTH($GET(LEXSHOW))
SET LEXDSP=$$DSP(LEXE,$GET(LEXSHOW),$GET(LEXVDT))
+31 DO ADDEM^LEXAL(LEXME,LEXDES,LEXDSP)
+32 SET ^TMP("LEXSCH",$JOB,"EXC",0)=LEXME
+33 SET ^TMP("LEXSCH",$JOB,"EXC",1)=$GET(^LEX(757.01,+LEXME,0))
End DoDot:3
End DoDot:2
End DoDot:1
+34 IF $DATA(^TMP("LEXFND",$JOB))
QUIT 1
+35 QUIT 0
DES(LEXX) ; Get description flag
+1 NEW LEXDES,LEXE,LEXM
SET LEXDES=""
SET LEXE=+LEXX
+2 SET LEXM=$PIECE($GET(^LEX(757.01,+($GET(LEXX)),1)),"^",1)
+3 SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
+4 IF $DATA(^LEX(757.01,LEXM,3))
SET LEXDES="*"
+5 SET LEXX=$GET(LEXDES)
QUIT LEXX
TERM(LEXX) ; Get expression
+1 QUIT $GET(^LEX(757.01,LEXX,0))
DSP(LEXX,LEXDSP,LEXVDT) ; Return displayable text
+1 NEW LEXMCE
SET LEXMCE=+($GET(^LEX(757,+($GET(^LEX(757.01,LEXX,1))),0)))
+2 IF +LEXMCE>0
IF $DATA(^LEX(757.01,+LEXMCE,0))
SET LEXX=$$SO^LEXASO(+LEXMCE,LEXDSP,1,$GET(LEXVDT))
QUIT LEXX
+3 SET LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$GET(LEXVDT))
QUIT LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
+1 SET LEXX=$$UP^XLFSTR($EXTRACT(LEXX,1,63))
NEW LEXIGN
+2 SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~"
QUIT LEXX
