source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXCODE.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: 3.6 KB
Line 
1LEXCODE ; ISL/KER Retrieval of IEN^Term based on Code ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
3 ;
4 ; External References
5 ; DBIA 10104 $$UP^XLFSTR
6 ;
7 Q
8 ; EN^LEXCODE(X,LEXVDT)
9 ;
10 ; X Code taken from a classification
11 ; system listed in Coding Systems
12 ; file #757.03
13 ;
14 ; LEXVDT The date against which the codes
15 ; found by the search will be compared
16 ; in order to determine whether they
17 ; are active or inactive. If null is
18 ; passed then it should default to
19 ; the current date.
20 ;
21 ; Returns Local Array
22 ; LEXS(0)=X
23 ; LEXS(SAB,0)=#
24 ; LEXS(SAB,#)=IEN^TERM
25 ;
26 ; 3 character mnemonics for SAB (Source Abbreviation)
27 ;
28 ; SAB Nomenclature Source
29 ; -----------------------------------------------------------
30 ; ICD ICD-9-CM Int'l Class of Disease (Diagnosis)
31 ; ICP ICD-9-CM Int'l Class of Disease (Procedures)
32 ; CPT CPT-4 Current Procedural Terminology
33 ; DSM DSM-IIIR Diag & Stat Manual of Mental Disorders
34 ; SNM SNOMED Systematic Nomenclature for Medicine
35 ; NAN NANDA North American Nursing Diagnosis Assoc
36 ; NIC Nursing Intervention Classification
37 ; OMA Omaha Nursing Diagnosis/Interventions
38 ; ACR American College of Radiology (Diag)
39 ; AIR AI/RHEUM National Library of Medicine source
40 ; COS COSTAR Computer Stored Ambulatory Records
41 ; CST COSTART Coding Sym Thes Adverse Reaction Terms
42 ; DXP DXPLAIN Diagnostic Prompting System
43 ; MCM McMaster University (Epidemiology)
44 ; UMD Universal Medical Device Nomemclature
45 ; CSP CRISP
46 ; UWA University of Washington (Neuronames)
47 ;
48 ; Example returned array using code 309.24
49 ;
50 ; LEXS(0)=309.24
51 ; LEXS("DSM",0)=1
52 ; LEXS("DSM",1)=3273^Adjustment disorder with anxious mood
53 ; LEXS("ICD",0)=2
54 ; LEXS("ICD",1)=268308^Adjustment reaction with anxious mood
55 ; LEXS("ICD",2)=3273^Adjustment disorder with anxious mood
56 ;
57 Q
58EN(LEX,LEXVDT) ; Get terms associated with a Code
59 K LEXS S LEX=$$UP^XLFSTR($G(LEX)) Q:'$L(LEX)
60 N LEXSRC,LEXSO,LEXO,LEXSAB,LEXDA,LEXPF,LEXINA,LEXSTA
61 S LEXS(0)=LEX,LEXO=LEX_" ",LEXDA=0 Q:'$D(^LEX(757.02,"CODE",LEXO))
62 F S LEXDA=$O(^LEX(757.02,"CODE",LEXO,LEXDA)) Q:+LEXDA=0 D CHK
63 D ASEM Q
64CHK ; Check if Valid
65 S LEXSO=$P($G(^LEX(757.02,LEXDA,0)),"^",2) Q:LEXSO'=LEX
66 S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT)) Q:+LEXSTA'>0
67 S LEXSRC=+($P($G(^LEX(757.02,LEXDA,0)),"^",3)) Q:LEXSRC'>0
68 S LEXSAB=$E($G(^LEX(757.03,+LEXSRC,0)),1,3) Q:$L(LEXSAB)'=3
69 S LEXPF=+($P($G(^LEX(757.02,LEXDA,0)),"^",5))
70 S:LEXPF=1 LEXS(LEXSAB,"PRE")=LEXDA
71 S:LEXPF'=1 LEXS(LEXSAB,"OTH",LEXDA)=""
72 Q
73ASEM ; Assemble List
74 Q:'$D(LEXS)
75 N LEXSAB,LEXCT,LEXDA,LEXEX,LEXEXP,LEXY S LEXSAB=""
76 F S LEXSAB=$O(LEXS(LEXSAB)) Q:LEXSAB="" S LEXCT=0 D
77 . I $D(LEXS(LEXSAB,"PRE")) D LEXY
78 . S LEXDA=0
79 . F S LEXDA=$O(LEXS(LEXSAB,"OTH",LEXDA)) Q:+LEXDA=0 D LEXY
80 . S:+LEXSAB'>0&(LEXSAB'="0") LEXS(LEXSAB,0)=LEXCT
81 Q
82LEXY ; Get IEN^TERM for Code X
83 S:$D(LEXS(LEXSAB,"PRE")) LEXDA=LEXS(LEXSAB,"PRE")
84 K:'$D(LEXS(LEXSAB,"PRE")) LEXS(LEXSAB,"OTH",LEXDA) K LEXS(LEXSAB,"PRE")
85 S LEXY="",LEXEX=+($P($G(^LEX(757.02,LEXDA,0)),"^",1))
86 Q:'$L($G(^LEX(757.01,+LEXEX,0)))
87 S LEXEXP=$G(^LEX(757.01,+LEXEX,0)),LEXCT=LEXCT+1,LEXY=LEXEX_"^"_LEXEXP
88 S LEXS(LEXSAB,LEXCT)=LEXY
89 Q
Note: See TracBrowser for help on using the repository browser.