125 lines
5.3 KiB
Mathematica
125 lines
5.3 KiB
Mathematica
LEXU ; ISA/FJF-Miscellaneous Lexicon Utilities; 06/23/2005
|
|
;;2.0;LEXICON UTILITY;**2,6,9,15,25,36**;Sep 23, 1996;Build 1
|
|
;
|
|
; External References
|
|
; DBIA 10103 $$DT^XLFDT
|
|
; DBIA 3990 $$ICDDX^ICDCODE
|
|
; DBIA 1995 $$CPT^ICPTCOD
|
|
;
|
|
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
|
|
; LEX IEN of file 757.01
|
|
; LEXS Filter
|
|
; LEXVDT Date to use for screening by codes
|
|
N LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC
|
|
S LEXRREC=LEX Q:'$D(^LEX(757.01,LEXRREC,0)) 0
|
|
I $L(LEXS,";")=3,$P(LEXS,";",3)'="" D I LEXINC K LEXIC,LEXEXC,LEXS,LEXEC Q LEXINC
|
|
. S LEXINC=0 S LEXINC=$$SO(LEXRREC,$P(LEXS,";",3),$G(LEXVDT))
|
|
S LEXRREC=$P(^LEX(757.01,LEXRREC,1),U,1)
|
|
S LEXINC=0 F LEXIC=1:1:$L($P(LEXS,";",1),"/") D
|
|
. 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
|
|
I LEXINC=0!($P(LEXS,";",2)="") K LEXIC,LEXS,LEXEC Q LEXINC
|
|
S LEXEXC=0 F LEXEC=1:1:$L($P(LEXS,";",2),"/") D
|
|
. 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
|
|
I LEXINC,'LEXEXC K LEXIC,LEXS,LEXEC Q 1
|
|
K LEXIC,LEXS,LEXEC Q 0
|
|
SO(LEX,LEXS,LEXVDT) ; Filter by Source
|
|
; LEX IEN of file 757.01
|
|
; LEXS Filter
|
|
; LEXVDT Date to use for screening by codes
|
|
N LEXTREC S LEXTREC=+LEX Q:'$D(^LEX(757.01,LEXTREC,0)) 0
|
|
N LEXFND S LEXFND=0,LEXTREC=+LEXTREC Q:'$D(^LEX(757.01,LEXTREC)) LEXFND
|
|
N LEXCODE,LEXSOID,LEXCREC,LEXSAB,LEXMC,LEXN0,LEXSO,LEXSTA
|
|
S LEXMC=$P(^LEX(757.01,LEXTREC,1),U,1)
|
|
S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXTREC,1),U,1)),0))
|
|
I LEXTREC=LEXMCE D G SOQ
|
|
. S LEXFND=0 F LEXSOID=1:1:$L(LEXS,"/") Q:LEXFND D
|
|
. . S LEXCODE=$P(LEXS,"/",LEXSOID),LEXCREC=0
|
|
. . F S LEXCREC=$O(^LEX(757.02,"AMC",LEXMC,LEXCREC)) Q:+LEXCREC=0!(LEXFND) D
|
|
. . . S LEXN0=$G(^LEX(757.02,LEXCREC,0))
|
|
. . . S LEXSAB=+($P(LEXN0,U,3)),LEXSO=$P(LEXN0,U,2)
|
|
. . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT)) Q:+LEXSTA'>0
|
|
. . . Q:'$D(^LEX(757.03,LEXSAB,0))
|
|
. . . S LEXSAB=$E(^LEX(757.03,LEXSAB,0),1,3)
|
|
. . . I LEXSAB=LEXCODE S LEXFND=1
|
|
SOQ ; Quit Source Filter
|
|
K LEX,LEXTREC,LEXMC,LEXS,LEXCODE,LEXMCE,LEXSOID Q LEXFND
|
|
SRC(LEX,LEXS) ; Filter by Expression Source
|
|
; LEX IEN of file 757.01
|
|
; LEXS Filter
|
|
S LEX=+($G(LEX)),LEXS=+($G(LEXS))
|
|
Q:LEX=0 0 Q:LEXS=0 0 Q:'$D(^LEX(757.01,LEX,0)) 0 Q:'$D(^LEX(757.14,LEXS,0)) 0
|
|
S LEXSR=$P($G(^LEX(757.01,LEX,1)),U,12) Q:LEXSR=LEXS 1
|
|
N LEXSR,LEXMC,LEXMCE S LEXMC=+($G(^LEX(757.01,LEX,1))),LEXMCE=+($G(^LEX(757,+LEXMC,0)))
|
|
S LEXSR=$P($G(^LEX(757.01,LEXMCE,1)),U,12) Q:LEXSR=LEXS 1
|
|
Q 0
|
|
DEF(LEX) ; Display expression definition
|
|
; LEX IEN of file 757.01
|
|
I $D(^LEX(757.01,LEX,3,0)) D
|
|
. N LEXLN F LEXLN=1:1:$P(^LEX(757.01,LEX,3,0),U,4) D
|
|
. . I $D(^LEX(757.01,LEX,3,LEXLN,0)) W !,?2,^LEX(757.01,LEX,3,LEXLN,0)
|
|
. K LEX,LEXLN W !
|
|
Q
|
|
ID(LEX) ; ICD Diagnosis retained - ICD procedures ignored
|
|
; LEX Code
|
|
Q:'$L($G(LEX)) "" Q:$L($P(LEX,".",1))<3 "" Q:'$D(^LEX(757.02,"AVA",(LEX_" "))) ""
|
|
N LEXO,LEXR S (LEXO,LEXR)=0 F S LEXR=$O(^LEX(757.02,"AVA",(LEX_" "),LEXR)) Q:+LEXR=0 D Q:LEXO=1
|
|
. I $D(^LEX(757.02,"AVA",(LEX_" "),LEXR,"ICD")) S LEXO=1
|
|
Q:'LEXO "" Q LEX
|
|
ICDONE(LEX,LEXVDT) ; Return one ICD code for an expression
|
|
; LEX IEN of file 757.01
|
|
; LEXVDT Date to use for screening by codes
|
|
N LEXICD
|
|
S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
|
|
S LEX=$$ONE^LEXSRC(LEX,"ICD",LEXVDT)
|
|
Q:LEX="" ""
|
|
S LEXICD=$$ICDDX^ICDCODE(LEX,LEXVDT)
|
|
Q:$P(LEXICD,"^",2)="INVALID CODE" ""
|
|
Q LEX
|
|
ICD(LEX,LEXVDT) ; Return all ICD codes for an expression
|
|
; LEX IEN of file 757.01
|
|
; LEXVDT Date to use for screening by codes
|
|
S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
|
|
N LEXSRC,LEXICD
|
|
D ALL^LEXSRC(LEX,"ICD",LEXVDT) Q:+$G(LEXSRC(0))'>0 ""
|
|
N LEXI,LEXT,LEXS S LEXI=0,LEXT=""
|
|
F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
|
|
. S LEXS=LEXSRC(LEXI)
|
|
. S LEXICD=$$ICDDX^ICDCODE(LEXS,LEXVDT)
|
|
. Q:$P(LEXICD,"^",2)="INVALID CODE"
|
|
. Q:(LEXT_";")[(";"_LEXS_";") S LEXT=LEXT_";"_LEXS
|
|
S:$E(LEXT,1)=";" LEXT=$E(LEXT,2,$L(LEXT)) S LEX=LEXT Q LEX
|
|
CPTONE(LEX,LEXVDT) ; Return one CPT code for an expression
|
|
; LEX IEN of file 757.01
|
|
; LEXVDT Date to use for screening by codes
|
|
S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
|
|
N LEXCPT
|
|
S LEX=$$ONE^LEXSRC(LEX,"CPT",LEXVDT)
|
|
Q:LEX="" ""
|
|
S LEXCPT=$$CPT^ICPTCOD(LEX,LEXVDT)
|
|
Q:$P(LEXCPT,"^",2)="NO SUCH ENTRY" ""
|
|
I +$P(LEXCPT,"^",7)=0 S LEX=""
|
|
Q LEX
|
|
CPCONE(LEX,LEXVDT) ; Return one HCPCS code for an expression
|
|
; LEX IEN of file 757.01
|
|
; LEXVDT Date to use for screening by codes
|
|
S LEXVDT=$S(+$G(LEXVDT)>0:LEXVDT,1:$$DT^XLFDT)
|
|
N LEXCPT
|
|
S LEX=$$ONE^LEXSRC(LEX,"CPC",LEXVDT)
|
|
Q:LEX="" ""
|
|
S LEXCPT=$$CPT^ICPTCOD(LEX,LEXVDT)
|
|
Q:$P(LEXCPT,"^",2)="NO SUCH ENTRY" ""
|
|
I +$P(LEXCPT,"^",7)=0 S LEX=""
|
|
I LEX'?1U.4N S LEX=""
|
|
Q LEX
|
|
DSMONE(LEX) ; Return one DSM code for an expression
|
|
; LEX IEN of file 757.01
|
|
; LEXVDT Date to use for screening by codes
|
|
; Check for DSM-IV first
|
|
S LEX=$$ONE^LEXSRC(LEX,"DS4") I LEX'="" Q LEX
|
|
; If not DSM-IV, then check for DSM-III
|
|
S LEX=$$ONE^LEXSRC(LEX,"DS3") Q LEX
|
|
ADR(LEX) ; Mailing Address
|
|
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
|
|
S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.MED.VA.GOV" D ^DIC Q:+Y>0 LEX
|
|
Q "ISC-SLC.VA.GOV"
|