source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXU.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1LEXU ; ISA/FJF-Miscellaneous Lexicon Utilities; 06/23/2005
2 ;;2.0;LEXICON UTILITY;**2,6,9,15,25,36**;Sep 23, 1996
3 ;
4 ; External References
5 ; DBIA 10103 $$DT^XLFDT
6 ; DBIA 3990 $$ICDDX^ICDCODE
7 ; DBIA 1995 $$CPT^ICPTCOD
8 ;
9SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
10 ; LEX IEN of file 757.01
11 ; LEXS Filter
12 ; LEXVDT Date to use for screening by codes
13 N LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC
14 S LEXRREC=LEX Q:'$D(^LEX(757.01,LEXRREC,0)) 0
15 I $L(LEXS,";")=3,$P(LEXS,";",3)'="" D I LEXINC K LEXIC,LEXEXC,LEXS,LEXEC Q LEXINC
16 . S LEXINC=0 S LEXINC=$$SO(LEXRREC,$P(LEXS,";",3),$G(LEXVDT))
17 S LEXRREC=$P(^LEX(757.01,LEXRREC,1),U,1)
18 S LEXINC=0 F LEXIC=1:1:$L($P(LEXS,";",1),"/") D
19 . I $D(^LEX(757.1,"AMCC",LEXRREC,$P($P(LEXS,";",1),"/",LEXIC)))!($D(^LEX(757.1,"AMCT",LEXRREC,$P($P(LEXS,";",1),"/",LEXIC)))) S LEXINC=1,LEXIC=$L($P(LEXS,";",1),"/")+1
20 I LEXINC=0!($P(LEXS,";",2)="") K LEXIC,LEXS,LEXEC Q LEXINC
21 S LEXEXC=0 F LEXEC=1:1:$L($P(LEXS,";",2),"/") D
22 . I $D(^LEX(757.1,"AMCC",LEXRREC,$P($P(LEXS,";",2),"/",LEXEC)))!($D(^LEX(757.1,"AMCT",LEXRREC,$P($P(LEXS,";",2),"/",LEXEC)))) S LEXEXC=1,LEXEC=$L($P(LEXS,";",2),"/")+1
23 I LEXINC,'LEXEXC K LEXIC,LEXS,LEXEC Q 1
24 K LEXIC,LEXS,LEXEC Q 0
25SO(LEX,LEXS,LEXVDT) ; Filter by Source
26 ; LEX IEN of file 757.01
27 ; LEXS Filter
28 ; LEXVDT Date to use for screening by codes
29 N LEXTREC S LEXTREC=+LEX Q:'$D(^LEX(757.01,LEXTREC,0)) 0
30 N LEXFND S LEXFND=0,LEXTREC=+LEXTREC Q:'$D(^LEX(757.01,LEXTREC)) LEXFND
31 N LEXCODE,LEXSOID,LEXCREC,LEXSAB,LEXMC,LEXN0,LEXSO,LEXSTA
32 S LEXMC=$P(^LEX(757.01,LEXTREC,1),U,1)
33 S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXTREC,1),U,1)),0))
34 I LEXTREC=LEXMCE D G SOQ
35 . S LEXFND=0 F LEXSOID=1:1:$L(LEXS,"/") Q:LEXFND D
36 . . S LEXCODE=$P(LEXS,"/",LEXSOID),LEXCREC=0
37 . . F S LEXCREC=$O(^LEX(757.02,"AMC",LEXMC,LEXCREC)) Q:+LEXCREC=0!(LEXFND) D
38 . . . S LEXN0=$G(^LEX(757.02,LEXCREC,0))
39 . . . S LEXSAB=+($P(LEXN0,U,3)),LEXSO=$P(LEXN0,U,2)
40 . . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT)) Q:+LEXSTA'>0
41 . . . Q:'$D(^LEX(757.03,LEXSAB,0))
42 . . . S LEXSAB=$E(^LEX(757.03,LEXSAB,0),1,3)
43 . . . I LEXSAB=LEXCODE S LEXFND=1
44SOQ ; Quit Source Filter
45 K LEX,LEXTREC,LEXMC,LEXS,LEXCODE,LEXMCE,LEXSOID Q LEXFND
46SRC(LEX,LEXS) ; Filter by Expression Source
47 ; LEX IEN of file 757.01
48 ; LEXS Filter
49 S LEX=+($G(LEX)),LEXS=+($G(LEXS))
50 Q:LEX=0 0 Q:LEXS=0 0 Q:'$D(^LEX(757.01,LEX,0)) 0 Q:'$D(^LEX(757.14,LEXS,0)) 0
51 S LEXSR=$P($G(^LEX(757.01,LEX,1)),U,12) Q:LEXSR=LEXS 1
52 N LEXSR,LEXMC,LEXMCE S LEXMC=+($G(^LEX(757.01,LEX,1))),LEXMCE=+($G(^LEX(757,+LEXMC,0)))
53 S LEXSR=$P($G(^LEX(757.01,LEXMCE,1)),U,12) Q:LEXSR=LEXS 1
54 Q 0
55DEF(LEX) ; Display expression definition
56 ; LEX IEN of file 757.01
57 I $D(^LEX(757.01,LEX,3,0)) D
58 . N LEXLN F LEXLN=1:1:$P(^LEX(757.01,LEX,3,0),U,4) D
59 . . I $D(^LEX(757.01,LEX,3,LEXLN,0)) W !,?2,^LEX(757.01,LEX,3,LEXLN,0)
60 . K LEX,LEXLN W !
61 Q
62ID(LEX) ; ICD Diagnosis retained - ICD procedures ignored
63 ; LEX Code
64 Q:'$L($G(LEX)) "" Q:$L($P(LEX,".",1))<3 "" Q:'$D(^LEX(757.02,"AVA",(LEX_" "))) ""
65 N LEXO,LEXR S (LEXO,LEXR)=0 F S LEXR=$O(^LEX(757.02,"AVA",(LEX_" "),LEXR)) Q:+LEXR=0 D Q:LEXO=1
66 . I $D(^LEX(757.02,"AVA",(LEX_" "),LEXR,"ICD")) S LEXO=1
67 Q:'LEXO "" Q LEX
68ICDONE(LEX,LEXVDT) ; Return one ICD code for an expression
69 ; LEX IEN of file 757.01
70 ; LEXVDT Date to use for screening by codes
71 N LEXICD
72 S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
73 S LEX=$$ONE^LEXSRC(LEX,"ICD",LEXVDT)
74 Q:LEX="" ""
75 S LEXICD=$$ICDDX^ICDCODE(LEX,LEXVDT)
76 Q:$P(LEXICD,"^",2)="INVALID CODE" ""
77 Q LEX
78ICD(LEX,LEXVDT) ; Return all ICD codes for an expression
79 ; LEX IEN of file 757.01
80 ; LEXVDT Date to use for screening by codes
81 S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
82 N LEXSRC,LEXICD
83 D ALL^LEXSRC(LEX,"ICD",LEXVDT) Q:+$G(LEXSRC(0))'>0 ""
84 N LEXI,LEXT,LEXS S LEXI=0,LEXT=""
85 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
86 . S LEXS=LEXSRC(LEXI)
87 . S LEXICD=$$ICDDX^ICDCODE(LEXS,LEXVDT)
88 . Q:$P(LEXICD,"^",2)="INVALID CODE"
89 . Q:(LEXT_";")[(";"_LEXS_";") S LEXT=LEXT_";"_LEXS
90 S:$E(LEXT,1)=";" LEXT=$E(LEXT,2,$L(LEXT)) S LEX=LEXT Q LEX
91CPTONE(LEX,LEXVDT) ; Return one CPT code for an expression
92 ; LEX IEN of file 757.01
93 ; LEXVDT Date to use for screening by codes
94 S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
95 N LEXCPT
96 S LEX=$$ONE^LEXSRC(LEX,"CPT",LEXVDT)
97 Q:LEX="" ""
98 S LEXCPT=$$CPT^ICPTCOD(LEX,LEXVDT)
99 Q:$P(LEXCPT,"^",2)="NO SUCH ENTRY" ""
100 I +$P(LEXCPT,"^",7)=0 S LEX=""
101 Q LEX
102CPCONE(LEX,LEXVDT) ; Return one HCPCS code for an expression
103 ; LEX IEN of file 757.01
104 ; LEXVDT Date to use for screening by codes
105 S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
106 N LEXCPT
107 S LEX=$$ONE^LEXSRC(LEX,"CPC",LEXVDT)
108 Q:LEX="" ""
109 S LEXCPT=$$CPT^ICPTCOD(LEX,LEXVDT)
110 Q:$P(LEXCPT,"^",2)="NO SUCH ENTRY" ""
111 I +$P(LEXCPT,"^",7)=0 S LEX=""
112 I LEX'?1U.4N S LEX=""
113 Q LEX
114DSMONE(LEX) ; Return one DSM code for an expression
115 ; LEX IEN of file 757.01
116 ; LEXVDT Date to use for screening by codes
117 ; Check for DSM-IV first
118 S LEX=$$ONE^LEXSRC(LEX,"DS4") I LEX'="" Q LEX
119 ; If not DSM-IV, then check for DSM-III
120 S LEX=$$ONE^LEXSRC(LEX,"DS3") Q LEX
121ADR(LEX) ; Mailing Address
122 N DIC,DTOUT,DUOUT,X,Y S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="FO-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
123 S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
124 Q "ISC-SLC.VA.GOV"
Note: See TracBrowser for help on using the repository browser.