source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXABC.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1LEXABC ; ISL/KER - Look-up by Code ; 02/02/2006
2 ;;2.0;LEXICON UTILITY;**4,25,26,29,38**;Sep 23, 1996
3 ;
4 ; S X=$$EN^LEXABC(CODE,LEXVDT)
5 ;
6 ; INPUT
7 ; LEXSO Code Preferred terms only
8 ; Code+ All terms
9 ; LEXVDT Version Date to screen against (default = today)
10 ;
11EN(LEXSO,LEXVDT) ; Entry from LEXA
12 S LEXSO=$G(LEXSO) Q:'$L(LEXSO) 0 Q:$L(LEXSO)>40 0 S LEXISCD=$$IS(LEXSO)
13 D BLD S:$L($G(^TMP("LEXSCH",$J,"NAR",0))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0)) Q:$D(^TMP("LEXHIT",$J)) 1 Q 0
14BLD ; Build List
15 N LEXSO2 D CLR K ^TMP("LEXSCH",$J,"LST",0),^TMP("LEXSCH",$J,"TOL",0),LEX S ^TMP("LEXSCH",$J,"NUM",0)=0,LEXSO=$G(LEXSO)
16 I $E(LEXSO,$L(LEXSO))'="+"&($L(LEXSO)'>2)!($E(LEXSO,$L(LEXSO))="+"&($L(LEXSO)'>3)) D CLR Q
17 S LEXSO2="" S:$E(LEXSO,$L(LEXSO))="+" LEXSO2=$E(LEXSO,$L(LEXSO)),LEXSO=$E(LEXSO,1,($L(LEXSO)-1)) I '(+($$IN(LEXSO))) D CLR Q
18 Q:$E(LEXSO,1,3)="U00" D FND D:$D(^TMP("LEXFND",$J)) BEG^LEXAL Q:$D(^TMP("LEXFND",$J)) D:'$D(^TMP("LEXFND",$J)) CLR
19 Q
20FND ; Find expressions
21 K ^TMP("LEXL",$J),^TMP("LEXLE",$J)
22 N LEXSIEN,LEXMIEN,LEXEIEN,LEXDESF,LEXDSPL,LEXDSPLA,LEXFORM,LEXFMTY,LEXS,LEXSAB,LEXSDATA
23 N LEXP,LEXTP,LEXTYPE,LEXFILR,LEXFORM,LEXC,LEXCSTAT,LEXDSAB,LEXSSAB
24 S LEXSSAB=$G(^TMP("LEXSCH",$J,"DIS",0)),U="^",LEXS=$$SCH(LEXSO)_" "
25 S:'$L($G(LEXFIL))&($L($G(DIC("S")))) LEXFIL=DIC("S")
26 S:'$L($G(LEXFIL))&($L($G(^TMP("LEXSCH",$J,"LEXFIL",0)))) LEXFIL=$G(^TMP("LEXSCH",$J,"LEXFIL",0))
27 F S LEXS=$O(^LEX(757.02,"AVA",LEXS)) Q:$E(LEXS,1,$L(LEXSO))'=LEXSO D
28 . S LEXEIEN=0 F S LEXEIEN=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN)) Q:+LEXEIEN=0 D
29 . . I $L($G(LEXFIL)) S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),+($G(^LEX(757,+($G(^LEX(757.01,LEXEIEN,1))),0)))) Q:LEXFILR=0
30 . . S LEXSAB="" F S LEXSAB=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB)) Q:LEXSAB="" D
31 . . . S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"AVA",LEXS,LEXEIEN,LEXSAB,LEXSIEN)) Q:+LEXSIEN=0 D
32 . . . . S LEXSDATA=$G(^LEX(757.02,LEXSIEN,0))
33 . . . . S LEXC=$P(LEXSDATA,"^",2)
34 . . . . Q:+$$STATCHK^LEXSRC2(LEXC,$G(LEXVDT))=0
35 . . . . S LEXTYPE=+$P(LEXSDATA,"^",3)
36 . . . . S LEXDSAB=$E($G(^LEX(757.03,+LEXTYPE,0)),1,3)
37 . . . . S LEXMIEN=+$P(LEXSDATA,"^",4),(LEXP,LEXTP)=+$P(LEXSDATA,"^",5)
38 . . . . Q:$$STATIEN(LEXSIEN)=0
39 . . . . S LEXDESF=$$DC(LEXEIEN,LEXTP)
40 . . . . S LEXDSPL=$$DP(LEXS,LEXTYPE)
41 . . . . S LEXDSPLA=$$DSO(+LEXEIEN,$G(LEXVDT),$G(LEXSSAB),$G(LEXDSAB))
42 . . . . S LEXDSPL=$$MDS(LEXDSPL,LEXDSPLA)
43 . . . . S LEXFORM=$$F(LEXEIEN),LEXFMTY=$P(LEXFORM,"^",1),LEXFORM=$P(LEXFORM,"^",2)
44 . . . . I LEXTYPE>3,LEXTYPE'=17 D NP Q
45 . . . . D PF
46 D:$D(^TMP("LEXL",$J)) REO^LEXABC2,ADD^LEXABC2
47 Q
48PF ; Preferred
49 S:LEXP=0 LEXTP=2 Q:LEXTP=2&($G(LEXSO2)'["+")
50 S ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM
51 S ^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
52 Q
53NP ; Not Preferred
54 N LEXICD S:LEXP=0 LEXTP=1
55 I $D(^TMP("LEXLE",$J,LEXEIEN)) D Q
56 . N LEX1,LEX2,LEX3,LEX4,LEXD,LEXDP
57 . S LEXD=^TMP("LEXLE",$J,LEXEIEN),LEX1=$P(LEXD,"^",1) Q:'$L(LEX1) S LEX2=$P(LEXD,"^",2) Q:'$L(LEX2) S LEX3=$P(LEXD,"^",3) Q:'$L(LEX3) S LEX4=$P(LEXD,"^",4) Q:'$L(LEX4)
58 . S LEXD=$G(^TMP("LEXL",$J,LEX1,LEX2,LEX3,LEX4)) Q:'$L(LEXD)
59 . S LEXDP=$P(LEXD,"^",4) S:$L(LEXDP) LEXDP=LEXDP_"/"_LEXDSPL S:'$L(LEXDP) LEXDP=LEXDSPL
60 . S $P(LEXD,"^",4)=LEXDP,^TMP("LEXL",$J,LEX1,LEX2,LEX3,LEX4)=LEXD
61 S LEXICD=$$ICDONE^LEXU(LEXEIEN)
62 I '$L(LEXICD) S ^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN Q
63 I $L(LEXICD) D Q
64 . S:$L(LEXDSPL)&(LEXSO2["+") LEXDSPL=LEXDSPL_"/ICD-9-CM "_LEXICD
65 . I LEXSO2["+",$D(^TMP("LEXL",$J,LEXS,1)) S ^TMP("LEXL",$J,LEXS,1,4,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^1^3^"_LEXSIEN Q
66 . S LEXTP=1,^TMP("LEXL",$J,LEXS,LEXTYPE,LEXTP,LEXSIEN)=LEXMIEN_"^"_LEXEIEN_"^"_LEXDESF_"^"_LEXDSPL_"^"_LEXFMTY_"^"_LEXFORM,^TMP("LEXLE",$J,LEXEIEN)=LEXS_"^"_LEXTYPE_"^"_LEXTP_"^"_LEXSIEN
67 Q
68F(LEX) ; Form
69 S LEX=+($G(LEX)),LEX=+($P($G(^LEX(757.01,LEX,1)),"^",2))
70 S LEX=$S(LEX=1:"A^Concept: ",LEX=2:"B^Synonym: ",LEX=3:"C^Variant: ",LEX=4:"D^Related: ",LEX=5:"E^Modified: ",1:"F^Other: ")
71 Q LEX
72DE(LEX) ; Deactivated 757.01
73 S LEX=+($G(LEX)) Q:'$D(^LEX(757.01,LEX,0)) 1 Q:+($P($G(^LEX(757.01,LEX,1)),"^",5))=1 1
74 S LEX=+($G(^LEX(757.01,LEX,1)))
75 Q:'$D(^LEX(757,LEX,0)) 1 S LEX=+($G(^LEX(757,LEX,0)))
76 Q:'$D(^LEX(757.01,LEX,1)) 1
77 Q:+($P($G(^LEX(757.01,LEX,1)),"^",5))=1 1
78 Q 0
79DC(LEX,LEXT) ; Description
80 N LEXD,LEXM S LEXD="",LEX=+($G(LEX)),LEXM=$P($G(^LEX(757.01,+($G(LEX)),1)),"^",1),LEXM=+($G(^LEX(757,+($G(LEXM)),0))) S:$D(^LEX(757.01,LEXM,3))&(+($G(LEXT))'=2) LEXD="*" S LEX=$G(LEXD) Q LEX
81DP(LEXS,LEXT) ; Display
82 S LEXT=+($G(LEXT)),LEXT=$P($G(^LEX(757.03,LEXT,0)),"^",2)
83 S LEXS=$G(LEXS) S:$E(LEXS,$L(LEXS))=" " LEXS=$E(LEXS,1,($L(LEXS)-1))
84 S:$L(LEXS)&($L(LEXT)) LEXS=LEXT_" "_LEXS Q:$L(LEXS)&($L(LEXT)) LEXS Q ""
85DSO(X,LEXVDT,LEXS,LEXD) ; Display Sources String
86 N LEXT,LEXIEN,LEXSAB S LEXIEN=+($G(X)) Q:+LEXIEN'>0 ""
87 S LEXT=$G(LEXS),LEXSAB=$G(LEXD) S:$L(LEXSAB)=3&(LEXT'[LEXSAB) LEXT=LEXT_"/"_LEXSAB
88 F Q:$E(LEXT,1)'="/" S LEXT=$E(LEXT,2,$L(LEXT))
89 S X=$$SO^LEXASO(LEXIEN,LEXT,1,$G(LEXVDT))
90 Q X
91MDS(LEXD,LEXA) ; Merge Display Strings
92 S LEXA=$G(LEXA) F Q:LEXA'[") (" S LEXA=$P(LEXA,") (",1)_"/"_$P(LEXA,") (",2,299)
93 S LEXA=$TR(LEXA,"(",""),LEXA=$TR(LEXA,")","")
94 Q:'$L(LEXD) LEXA
95 S:LEXA'[LEXD LEXA=LEXD_"/"_LEXA
96 Q LEXA
97CLR ; Clear
98 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXL",$J),LEX S LEX=0 Q
99IN(LEX) ; Flag in/not in file 757.02
100 Q:$O(^LEX(757.02,"AVA",(($$SCH($E(LEX,1,61)))_" ")))[LEX 1 Q 0
101SCH(LEX) ; Search
102 S LEX=$E(LEX,1,($L(LEX)-1))_$C($A($E(LEX,$L(LEX)))-1)_"~" Q LEX
103STATIEN(LEXCIEN) ; Determine status of code-expression pairing based
104 ; on code IEN
105 N STATDAT,STATIEN
106 S STATDAT=$O(^LEX(757.02,LEXCIEN,4,"B",$S($G(LEXVDT)'="":LEXVDT+1,1:"")),-1)
107 Q:STATDAT="" 0
108 S STATIEN=$O(^LEX(757.02,LEXCIEN,4,"B",STATDAT,""),-1)
109 Q +$P(^LEX(757.02,LEXCIEN,4,STATIEN,0),"^",2)
110NONPLUS(STRING) ; Remove trialing plus from a string
111 S STRING=$G(STRING)
112 I $E($RE(STRING))="+" Q $RE($E($RE(STRING),2,$L(STRING)))
113 Q STRING
114IS(X) ; Is a Code
115 N CODE,ISACODE S CODE=$G(X),ISACODE=0
116 ; If the user input is a valid code (active or inactive) ISACODE=1
117 S:$D(^ICPT("BA",(CODE_" ")))!$D(^ICD9("BA",(CODE_" ")))!$D(^ICD0("BA",(CODE_" "))) ISACODE=1 I ISACODE>0 S X="1" Q X
118 ; If the user intended to search for a code (pattern match) with a typo, then ISACODE =1
119 S:(CODE?5N)!(CODE?1A4N)!(CODE?4N1"T")!(CODE?4N1"F") ISACODE=1
120 S:(CODE?3N1"."2N)!(CODE?3N1"."1N)!(CODE?3N1".") ISACODE=1
121 S:(CODE?1"E"3N1"."2N)!(CODE?1"E"3N1"."1N)!(CODE?1"E"3N1".") ISACODE=1
122 S:(CODE?1"V"2N1"."2N)!(CODE?1"V"2N1"."1N)!(CODE?1"V"2N1".") ISACODE=1
123 S:(CODE?2N1"."2N)!(CODE?2N1"."1N)!(CODE?2N1".") ISACODE=1
124 S X=+ISACODE Q X
Note: See TracBrowser for help on using the repository browser.