source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXASO.m@ 1470

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1LEXASO ; ISL/KER Look-up Display String (Sources) ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**25,32**;Sep 23, 1996
3 ;
4 ; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
5 ;
6 ; IEN is an internal entry number in file 757.01
7 ; representing an expression
8 ;
9 ; SAB is the source abbreviation of the classification
10 ; coding system, i.e., ICD, CPT, DSM, etc.
11 ;
12 ; ALL is a flag
13 ;
14 ; 0 - do not display all codes associated of the
15 ; major concept, display the codes only for the
16 ; expression
17 ;
18 ; 1 - display all codes associated for the major
19 ; concept
20 ;
21 ; DATE is used to screen out inactive codes
22 ;
23 ; LEXCC( Array of classification codes
24 ;
25 ; LEXA Flag - 1 All codes, 0 only the expression codes
26 ; LEXM Flag - M Major Concept
27 ;
28 ; LEXC Counter, # $Piece of string LEXSA (SAB)
29 ;
30 ; LEXMC IEN in file 757 Major Concept
31 ; LEXME IEN in file 757.01 Major Concept Expression
32 ; LEXEX IEN in file 757.01 Expression
33 ; LEXSO IEN in file 757.02 Sources
34 ;
35 ; LEXSA Source Abbreviation i.e., ICD or ICD/CPT
36 ; LEXSC Source Classification Code
37 ; LEXSR Source Abbreviation single only i.e., ICD, CPT
38 ; LEXST String of classification sources and codes
39 ;
40 ; LEXX Return value
41 ;
42SO(LEXX,LEXSA,LEXA,LEXVDT) ; Return string of source codes for LEXX SAB
43 Q:+($G(LEXX))=0!('$L($G(LEXSA))) ""
44 Q:'$L($G(^LEX(757.01,LEXX,0))) ""
45 ;
46 N LEXCC,LEXM,LEXC,LEXMC,LEXME,LEXEX,LEXSO,LEXSC,LEXSR,LEXST
47 ;
48 S LEXEX=+LEXX,LEXX="",LEXA=+($G(LEXA)),LEXMC=0
49 S LEXM=$P($G(^LEX(757.01,LEXEX,1)),"^",2),LEXST=""
50 ; Codes for an expression D EXP
51 I LEXM'=1!(+($G(LEXA))=0) D EXP G EXIT
52 ; Codes for a major concept D MAJ
53 I LEXM=1 S LEXMC=LEXEX D MAJ
54EXIT ; Clean up and quit
55 Q LEXX
56EXP ; Source string for an expression
57 I LEXSA'["/" D CODES(LEXEX,LEXSA,$G(LEXVDT)) S LEXX=$$ASSEM Q
58 I LEXSA["/" D S LEXX=$$ASSEM
59 . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
60 . . D CODES(LEXEX,$P(LEXSA,"/",LEXC),$G(LEXVDT))
61 Q
62MAJ ; Source string for a major concept
63 S LEXMC=$P($G(^LEX(757.01,LEXEX,1)),"^",1),LEXEX=0
64 S LEXEX=0 F S LEXEX=$O(^LEX(757.02,"AMC",LEXMC,LEXEX)) Q:+LEXEX=0 D
65 . N LEXME S LEXME=+($G(^LEX(757.02,LEXEX,0)))
66 . I LEXSA'["/" D CODES(LEXME,LEXSA,$G(LEXVDT)) Q
67 . I LEXSA["/" D Q
68 . . N LEXC F LEXC=1:1:$L(LEXSA,"/") D
69 . . . D CODES(LEXME,$P(LEXSA,"/",LEXC),$G(LEXVDT))
70 S LEXX=$$ASSEM
71 Q
72CODES(LEXEX,LEXSA,LEXVDT) ; Get Source Codes
73 Q:$L($G(LEXSA))'=3 N LEXSO,LEXSR,LEXST,LEXSTA,LEXCD S LEXST=""
74 S LEXSO=0 F S LEXSO=$O(^LEX(757.02,"B",LEXEX,LEXSO)) Q:+LEXSO=0 D
75 . S LEXCD=$P($G(^LEX(757.02,LEXSO,0)),"^",2) Q:'$L(LEXCD)
76 . S LEXSTA=$$STATCHK^LEXSRC2(LEXCD,$G(LEXVDT)) Q:+LEXSTA'>0
77 . I $E($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),1,3)=LEXSA D
78 . . S LEXSR=$P($G(^LEX(757.03,$P($G(^LEX(757.02,LEXSO,0)),"^",3),0)),"^",2)
79 . . S LEXCC(LEXSR,(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
80 . . ; Primary Code Saved - p32
81 . . S:$P($G(^LEX(757.02,LEXSO,0)),"^",7)=1 LEXCC(LEXSR,"P",(($P($G(^LEX(757.02,LEXSO,0)),"^",2))_" "))=""
82 Q
83ASSEM(LEXX) ; Assemble display string (SOURCE CODE/CODE/CODE)
84 Q:'$D(LEXCC) ""
85 Q:$O(LEXCC(""))="" ""
86 N LEXSR,LEXST S LEXSR=""
87 F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
88 . N LEXSC S LEXSC="",LEXST="("_LEXSR_" "
89 . ; Primary Code listed first - p32
90 . I $D(LEXCC(LEXSR,"P")) D
91 . . N LEXSC S LEXSC=$O(LEXCC(LEXSR,"P",""))
92 . . S:$L(LEXSC) LEXST=LEXST_$$TRIM(LEXSC)_"/"
93 . . K LEXCC(LEXSR,"P") K:$L(LEXSC) LEXCC(LEXSR,LEXSC)
94 . S LEXSC="" F S LEXSC=$O(LEXCC(LEXSR,LEXSC)) Q:LEXSC="" D
95 . . S LEXST=LEXST_$$TRIM(LEXSC)_"/"
96 . . K LEXCC(LEXSR,LEXSC)
97 . S LEXCC(LEXSR)=$E(LEXST,1,($L(LEXST)-1))_")"
98 S (LEXST,LEXSR)=""
99 F S LEXSR=$O(LEXCC(LEXSR)) Q:LEXSR="" D
100 . S LEXST=LEXST_" "_LEXCC(LEXSR)
101 F Q:$E(LEXST,1)'=" " S LEXST=$E(LEXST,2,$L(LEXST))
102 S LEXX=LEXST Q LEXX
103TRIM(LEXX) ; Trim spaces
104 F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
105 F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
106 Q LEXX
Note: See TracBrowser for help on using the repository browser.