source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAB.m@ 1123

Last change on this file since 1123 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1LEXAB ; ISL/KER Look-up Exact Match "B" index ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
3 ;
4 ; External References
5 ; DBIA 10104 $$UP^XLFSTR
6 ;
7 ; Exact match S X=$$EN^LEXAB("LEXSCH",LEXVDT)
8 ;
9 ; INPUT
10 ; LEXSCH User input string to search for
11 ; LEXVDT Date used to screen out inactive codes
12 ;
13 ; Notes:
14 ;
15 ; 1. If an exact match is found, it is placed at
16 ; the top of the selection list at
17 ; ^TMP("LEXFND",$J)
18 ;
19 ; 2. Returns
20 ;
21 ; 0 - Exact match not found
22 ; 1 - Exact match found
23 ;
24EN(LEXSCH,LEXVDT) ; Check "B" index for exact match
25 Q:'$L(LEXSCH) 0
26 N LEXLKGL,LEXEM,LEXEMC S LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)),LEXEMC=0
27 Q:$G(LEXLKGL)'["757.01" 0
28 N LEXSHOW S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
29 N LEXO,LEXE,LEXOK,LEXDES,LEXDSP
30 S (LEXE,LEXOK)=0,LEXO=$$SCH(LEXSCH)
31 F S LEXO=$O(^LEX(757.01,"B",LEXO)) Q:LEXO=""!(LEXSCH'[LEXO) D
32 . S (LEXE,LEXOK)=0
33 . F S LEXE=$O(^LEX(757.01,"B",LEXO,LEXE)) Q:+LEXE=0 D
34 . . Q:+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1
35 . . I $$UP^XLFSTR(LEXSCH)=$$UP^XLFSTR($G(^LEX(757.01,LEXE,0))) D
36 . . . S LEXEMC=+($G(LEXEMC)),LEXEMC=LEXEMC+1,LEXEM=LEXE
37 S:+($G(LEXEMC))=1 LEXOK=$G(LEXEM) S:+($G(LEXEMC))'=1 LEXOK=0
38 ; Exact Match Found
39 I +LEXOK>0 D
40 . S LEXE=LEXOK
41 . ; Filter
42 . S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
43 . ; Deactivated
44 . Q:+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1
45 . S LEXDES=$$DES(LEXE)
46 . S LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
47 . D ADDE^LEXAL(LEXE,LEXDES,LEXDSP)
48 . S ^TMP("LEXSCH",$J,"EXM",0)=LEXE
49 . S ^TMP("LEXSCH",$J,"EXM",1)=$G(^LEX(757.01,+LEXE,0))
50 . I '$D(^LEX(757,"B",LEXE)) D
51 . . N LEXME,LEXM S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
52 . . S LEXME=+($G(^LEX(757,LEXM,0))) Q:LEXM=0 Q:LEXE=LEXME
53 . . I +($G(^LEX(757.01,LEXME,1)))=LEXM D
54 . . . S LEXDES=$$DES(LEXME),LEXDSP="" S:$L($G(LEXSHOW)) LEXDSP=$$DSP(LEXE,$G(LEXSHOW),$G(LEXVDT))
55 . . . D ADDEM^LEXAL(LEXME,LEXDES,LEXDSP)
56 . . . S ^TMP("LEXSCH",$J,"EXC",0)=LEXME
57 . . . S ^TMP("LEXSCH",$J,"EXC",1)=$G(^LEX(757.01,+LEXME,0))
58 Q:$D(^TMP("LEXFND",$J)) 1
59 Q 0
60DES(LEXX) ; Get description flag
61 N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
62 S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
63 S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
64 S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
65 S LEXX=$G(LEXDES) Q LEXX
66TERM(LEXX) ; Get expression
67 Q $G(^LEX(757.01,LEXX,0))
68DSP(LEXX,LEXDSP,LEXVDT) ; Return displayable text
69 N LEXMCE S LEXMCE=+($G(^LEX(757,+($G(^LEX(757.01,LEXX,1))),0)))
70 I +LEXMCE>0,$D(^LEX(757.01,+LEXMCE,0)) S LEXX=$$SO^LEXASO(+LEXMCE,LEXDSP,1,$G(LEXVDT)) Q LEXX
71 S LEXX=$$SO^LEXASO(LEXX,LEXDSP,1,$G(LEXVDT)) Q LEXX
72SCH(LEXX) ; Search for LEXX a $Orderable variable
73 S LEXX=$$UP^XLFSTR($E(LEXX,1,63))
74 S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
Note: See TracBrowser for help on using the repository browser.