| [613] | 1 | LEXCODE ; ISL/KER Retrieval of IEN^Term based on Code ; 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 | 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
|
|---|
| 58 | EN(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
|
|---|
| 64 | CHK ; 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
|
|---|
| 73 | ASEM ; 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
|
|---|
| 82 | LEXY ; 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
|
|---|
