source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR5.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1LEXAR5 ; ISL/KER - Look-up Response (Select Entry) ; 02/02/2006
2 ;;2.0;LEXICON UTILITY;**14,25,26,38**;Sep 23, 1996;Build 1
3 ;
4 ; External References
5 ; DBIA 10104 $$UP^XLFSTR
6 ; DBIA 10103 $$DT^XLFDT
7 ; DBIA 3992 $$STATCHK^ICDAPIU
8 ; DBIA 1997 $$STATCHK^ICPTAPIU
9 ; DBIA 1612 ^YSD(627.7,
10 ;
11SETEXP(LEXX) ; Set LEX("SEL","EXP")
12 S LEXX=+($G(LEXX)) Q:LEXX'>0 Q:'$D(^LEX(757.01,LEXX,0))
13 N LEXYPE S LEXYPE=$$TYPE(LEXX)
14 N LEXC S LEXC=+($G(LEX("SEL","EXP",0))),LEXC=LEXC+1
15 S LEX("SEL","EXP",LEXC)=LEXX_"^"_^LEX(757.01,LEXX,0),LEX("SEL","EXP",0)=LEXC
16 S LEX("SEL","EXP","B",LEXX,LEXC)=""
17 S:LEXYPE'="" LEX("SEL","EXP","C",LEXYPE,LEXC)=""
18 Q
19TYPE(LEXX) ; Expression Type
20 N LEXYPE S LEXYPE=$P($G(^LEX(757.01,LEXX,1)),"^",2)
21 I +LEXYPE'>0!('$D(^LEX(757.011,+LEXYPE,0))) S LEXYPE="OTH"
22 I +LEXYPE>0,$D(^LEX(757.011,+LEXYPE,0)) D
23 . S LEXYPE=$P($G(^LEX(757.011,+LEXYPE,0)),"^",1)
24 . S:$L(LEXYPE)<3 LEXYPE="OTH"
25 . S LEXYPE=$$UP^XLFSTR($E(LEXYPE,1,3))
26 S LEXX=LEXYPE Q LEXX
27SETDEF(LEXX) ; Set LEX("SEL","SIG")
28 S LEXX=+($G(LEXX)) Q:LEXX=0
29 Q:'$D(^LEX(757.01,LEXX,3,1,0))
30 N LEXC,LEXR S LEXR=0
31 F S LEXR=$O(^LEX(757.01,LEXX,3,LEXR)) Q:+LEXR=0 D
32 . S LEXC=+($G(LEX("SEL","SIG",0))),LEXC=LEXC+1
33 . S LEX("SEL","SIG",LEXC)=$G(^LEX(757.01,LEXX,3,LEXR,0))
34 . S LEX("SEL","SIG",0)=LEXC
35 Q
36SETSTY(LEXX) ; Set LEX("SEL","STY")
37 S LEXX=+($G(LEXX)) Q:LEXX=0
38 Q:'$D(^LEX(757.1,"B",LEXX))
39 N LEXC,LEXR,LEXSC,LEXST S LEXR=0
40 F S LEXR=$O(^LEX(757.1,"B",LEXX,LEXR)) Q:+LEXR=0 D
41 . S LEXSC=+($P($G(^LEX(757.1,LEXR,0)),"^",2)) Q:LEXSC=0 Q:'$D(^LEX(757.11,LEXSC))
42 . S LEXSC=$P($G(^LEX(757.11,LEXSC,0)),"^",2) Q:'$L(LEXSC)
43 . S LEXST=+($P($G(^LEX(757.1,LEXR,0)),"^",3)) Q:LEXST=0 Q:'$D(^LEX(757.12,LEXST))
44 . S LEXST=$P($G(^LEX(757.12,LEXST,0)),"^",2) Q:'$L(LEXST)
45 . S LEXC=+($G(LEX("SEL","STY",0))),LEXC=LEXC+1
46 . S LEX("SEL","STY",LEXC)=LEXSC_"^"_LEXST
47 . S LEX("SEL","STY",0)=LEXC
48 Q
49SETSRC(LEXX,LEXVDT) ; Set LEX("SEL","SRC")
50 N LEXSO,LEXSRC,LEXS,LEXC,LEXLD,LEXLS S LEXS=0
51 F S LEXS=$O(^LEX(757.02,"B",LEXX,LEXS)) Q:+LEXS=0 D
52 . S LEXSO=$P(^LEX(757.02,LEXS,0),"^",2)
53 . Q:+$$STATCHK^LEXSRC2(LEXSO,LEXVDT)=0
54 . Q:'$D(^LEX(757.02,"AVA",(LEXSO_" "),LEXX))
55 . S LEXSRC=+($P(^LEX(757.02,LEXS,0),"^",3)) Q:LEXSRC=0
56 . S LEXSRC=$P(^LEX(757.03,LEXSRC,0),"^",2) Q:'$L(LEXSRC)
57 . S LEXC=+($G(LEX("SEL","SRC",0))),LEXC=LEXC+1
58 . S LEX("SEL","SRC",LEXC)=LEXSRC_"^"_LEXSO_"^"_LEXX
59 . S LEX("SEL","SRC","B",LEXSRC,LEXC)=""
60 . S LEX("SEL","SRC","C",LEXSO,LEXC)=""
61 . S LEX("SEL","SRC","D",LEXX,LEXC)=""
62 . S LEX("SEL","SRC",0)=LEXC
63 D SETVAS(LEXX,+($G(LEXVDT)))
64 Q
65SETVAS(LEXX,LEXVDT) ; Find VA sources for LEX("SEL","VAS")
66 N LEXSAB,LEXRTN,LEXR,LEXVP S LEXVDT=$S(+($G(LEXVDT))>0:+($G(LEXVDT)),1:$$DT^XLFDT)
67 F LEXSAB="ICD","ICP","CPT","DS4" D
68 . K LEXSRC S LEXRTN=LEXSAB_"^LEXAR5"
69 . D ALL^LEXSRC(LEXX,LEXSAB,LEXVDT) I +($G(LEXSRC(0)))>0 D @LEXRTN
70 Q
71ICD ; Intl' Classification of Diseases (diagnosis)
72 N LEXO,LEXI,LEXSO,LEXR,LEXVP S LEXI=0 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
73 . S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO=""
74 . S LEXO=$$STATCHK^ICDAPIU(LEXSO,+($G(LEXVDT))) Q:+LEXO'>0
75 . S LEXO=+($P(LEXO,"^",2)) Q:+LEXO'>0 S LEXC=+($G(LEX("SEL","VAS",0)))+1
76 . S LEXVP=+LEXO_";ICD9(" D VAS("80",LEXSO,LEXX,LEXVP,LEXC)
77 Q
78ICP ; Intl' Classification of Diseases (procedures)
79 N LEXI,LEXSO,LEXR,LEXVP S LEXI=0 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
80 . S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO=""
81 . S LEXO=$$STATCHK^ICDAPIU(LEXSO,+($G(LEXVDT))) Q:+LEXO'>0
82 . S LEXO=+($P(LEXO,"^",2)) Q:+LEXO'>0 S LEXC=+($G(LEX("SEL","VAS",0)))+1
83 . S LEXVP=+LEXO_";ICD0(" D VAS("80.1",LEXSO,LEXX,LEXVP,LEXC)
84 Q
85CPT ; Current Procedural Terminology
86 N LEXI,LEXSO,LEXR,LEXVP S LEXI=0 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
87 . S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO=""
88 . S LEXO=$$STATCHK^ICPTAPIU(LEXSO,+($G(LEXVDT))) Q:+LEXO'>0
89 . S LEXO=+($P(LEXO,"^",2)) Q:+LEXO'>0 S LEXC=+($G(LEX("SEL","VAS",0)))+1
90 . S LEXVP=+LEXO_";ICPT(" D VAS("81",LEXSO,LEXX,LEXVP,LEXC)
91 Q
92DS4 ; Diagnostic and Statistical Manual of Mental Disorders
93 Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
94 N LEXEXP,LEXR,LEXVP,LEXI,LEXSO,LEXVA,LEXIEN,LEXC S LEXEXP=$G(^LEX(757.01,LEXX,0)) Q:'$L(LEXEXP)
95 S LEXI=0 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
96 . S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO="" Q:'$D(^YSD(627.7,"B",LEXSO)) N LEXVA,LEXIEN S (LEXIEN,LEXVA)=0
97 . F S LEXVA=$O(^YSD(627.7,"B",LEXSO,LEXVA)) Q:+LEXVA=0 D
98 . . I $$UP($G(^YSD(627.7,LEXVA,"D")))=$$UP(LEXEXP) S LEXIEN=LEXVA
99 . Q:LEXIEN=0 S LEXR=LEXIEN,LEXC=+($G(LEX("SEL","VAS",0))),LEXC=LEXC+1
100 . Q:+LEXR'>0 S LEXVP=LEXR_";YSD(627.7," D VAS("627.7",LEXSO,LEXX,LEXVP,LEXC)
101 Q
102VAS(LEXFI,LEXSO,LEXIEN,LEXV,LEXCNT) ; Set LEX("SEL","VAS")
103 S LEX("SEL","VAS",LEXCNT)=LEXFI_"^"_LEXV_"^"_LEXSO_"^"_LEXIEN
104 S LEX("SEL","VAS","B",LEXFI,LEXCNT)=""
105 S LEX("SEL","VAS","C",LEXSO,LEXCNT)=""
106 S LEX("SEL","VAS","D",LEXIEN,LEXCNT)=""
107 S LEX("SEL","VAS","V",LEXV,LEXCNT)=""
108 S LEX("SEL","VAS",0)=LEXCNT
109 Q
110UP(X) ; Uppercase
111 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.