LEXU6 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.001) N/A
; ^TMP("LEXSCH") SACC 2.3.2.5.1
; ^TMP("LEXTKN") SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; ^DIC ICR 10006
;
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
;
; Input
;
; LEX IEN of file 757.01
; LEXS Filter
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$SC 1/0
;
N LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC,X D VDT^LEXU
S LEXRREC=LEX Q:'$D(^LEX(757.01,LEXRREC,0)) 0
I $L(LEXS,";")=3,$P(LEXS,";",3)'="" D Q:+LEXINC>0 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
. N LEXP,LEX1,LEX2 S LEXP=$P($P(LEXS,";",1),"/",LEXIC)
. S LEX1=$D(^LEX(757.1,"AMCC",LEXRREC,LEXP))
. S LEX2=$D(^LEX(757.1,"AMCT",LEXRREC,LEXP))
. I LEX1!(LEX2) D
. . 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
. N LEXP,LEX1,LEX2 S LEXP=$P($P(LEXS,";",2),"/",LEXEC)
. S LEX1=$D(^LEX(757.1,"AMCC",LEXRREC,LEXP))
. S LEX2=$D(^LEX(757.1,"AMCT",LEXRREC,LEXP))
. I LEX1!(LEX2) D
. . 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
;
; Input
;
; LEX IEN of file 757.01
; LEXS Filter
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$SO 1/0
;
N LEXABR,LEXCR,LEXF,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXSO,LEXSR,LEXSTA,LEXTR
S LEXTR=+LEX,LEXF=0 Q:'$D(^LEX(757.01,LEXTR,0)) LEXF
Q:'$D(^LEX(757.01,LEXTR)) LEXF
S LEXMC=$P(^LEX(757.01,LEXTR,1),U,1)
S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXTR,1),U,1)),0))
D VDT^LEXU I LEXTR>0,LEXMCE>0,LEXTR=LEXMCE D G SOQ
. S LEXF=0 F LEXSR=1:1:$L(LEXS,"/") D Q:LEXF>0
. . S LEXABR=$P(LEXS,"/",LEXSR),LEXCR=0
. . F S LEXCR=$O(^LEX(757.02,"AMC",LEXMC,LEXCR)) Q:+LEXCR=0 D Q:LEXF>0
. . . N LEXN0,LEXSAB,LEXQ S LEXQ=0
. . . S LEXN0=$G(^LEX(757.02,LEXCR,0))
. . . S LEXSAB=+($P(LEXN0,U,3)),LEXSO=$P(LEXN0,U,2)
. . . I $G(LEXLKT)["BC" D Q:LEXQ
. . . . N LEXNAR S LEXNAR=$G(^TMP("LEXSCH",$J,"NAR",0))
. . . . I $L($G(LEXNAR)) S:$E(LEXSO,1,$L($G(LEXNAR)))'=$G(LEXNAR) LEXQ=1
. . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSAB)
. . . Q:+LEXSTA'>0 Q:$P(LEXSTA,U,2)'=LEXCR
. . . Q:'$D(^LEX(757.03,LEXSAB,0))
. . . S LEXSAB=$E(^LEX(757.03,LEXSAB,0),1,3)
. . . I LEXSAB=LEXABR S LEXF=1
SOQ ; Quit Source Filter
K LEXCR,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXABR,LEXSO,LEXSR,LEXSTA,LEXTR
Q LEXF
SOS(X,ARY,SYN) ; Sources for Expression
;
; Input
; X Internal Entry Number Expression file #757.01
; .ARY Local Array Name passed by Reference
; SYN Include codes mapped via a Synonym
;
; Output
; ARY(IEN) IEN is from file #757.01 (same as X)
; ARY(IEN,0) Number of Codes Found
; ARY(IEN,#) # is a sequence number
;
; Equals an 13 Piece "^" delimited string
;
; 1 Code
; 2 Coding System Nomenclature
; 3 Coding System Source Abbreviation
; 4 Code Status
; 5 Code Active Date
; 6 Code Inactive Date
; 7 Expression Status
; 8 Expression Active Date
; 9 Expression Inactive Date
; 10 Expression Variable Pointer
; 11 Code Variable Pointer
; 12 Coding System Variable Pointer
; 13 National File Variable Pointer (if it exist)
;
; Array has two indexes
;
; ARY(IEN,"B",(CODE_" "),#)=Code_"^"_Nomenclature
; ARY(IEN,"C",SOURCE,#)=Code_"^"_Nomenclature
;
N LEXCT,LEXCIEN,LEXEIEN,LEXI,LEXSIEN,LEXSF S LEXCT=0,(LEXCIEN,LEXEIEN)=+($G(X)) Q:+LEXEIEN'>0 0
Q:'$D(^LEX(757.01,+($G(LEXEIEN)),0)) 0 K ARY(LEXCIEN)
Q:'$D(^LEX(757.01,+LEXEIEN,0)) 0 Q:'$D(^LEX(757.02,"B",+LEXEIEN)) 0 S LEXSIEN=0,LEXSF=+($G(SYN))
; Codes for an Expression
I +LEXSF'>0 D
. S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",+LEXEIEN,LEXSIEN)) Q:+LEXSIEN'>0 D SOSE
; Codes for an Major Concept
I +LEXSF>0 D
. N LEXTMIEN S LEXTMIEN=+($G(^LEX(757.01,+LEXEIEN,1))) S LEXSIEN=0
. F S LEXSIEN=$O(^LEX(757.02,"AMC",+LEXTMIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
. . S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0))) D SOSE
S (LEXI,LEXCT)=0 F S LEXI=$O(ARY(LEXCIEN,LEXI)) Q:+LEXI'>0 S LEXCT=LEXCT+1 S ARY(+LEXCIEN,0)=LEXCT
K ARY(LEXCIEN,"D") S X=LEXCT S:+LEXCT>0 ARY(+LEXCIEN,0)=LEXCT
Q X
SOSE ; Build array of Sources for Expression
N LEXACT,LEXCVP,LEXEVP,LEXEXA,LEXEXI,LEXEXS,LEXINA,LEXNAT,LEXNIEN,LEXNOM,LEXNUM,LEXO,LEXSAB,LEXSO,LEXSRC,LEXSTA,LEXSVP
S (LEXNAT,LEXEVP,LEXCVP,LEXSVP)="",LEXSO=$G(^LEX(757.02,+LEXSIEN,0)),LEXSRC=$P(LEXSO,"^",3)
S LEXSAB=$P($G(^LEX(757.03,+LEXSRC,0)),"^",1) Q:'$L(LEXSAB) S LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2) Q:'$L(LEXNOM)
S LEXSO=$P(LEXSO,"^",2) Q:$E(LEXSO,1,4)="U000" S:+($G(LEXEIEN))>0 LEXEVP=+($G(LEXEIEN))_";LEX(757.01,"
S:+($G(LEXSIEN))>0 LEXCVP=+($G(LEXSIEN))_";LEX(757.02," S:+($G(LEXSRC))>0 LEXSVP=+($G(LEXSRC))_";LEX(757.03,"
I LEXSRC=1!(LEXSRC=30) S LEXNIEN=$$CODEN^ICDEX(LEXSO,80) S:+LEXNIEN>0 LEXNAT=+LEXNIEN_";ICD9("
I LEXSRC=2!(LEXSRC=31) S LEXNIEN=$$CODEN^ICDEX(LEXSO,80.1) S:+LEXNIEN>0 LEXNAT=+LEXNIEN_";ICD0("
I LEXSRC=3!(LEXSRC=4) S LEXNIEN=$$CODEN^ICPTCOD(LEXSO) S:+LEXNIEN>0 LEXNAT=+LEXNIEN_";ICPT("
S LEXSTA=$$SOAI(LEXSO,LEXSRC),LEXACT=$P(LEXSTA,"^",2),LEXINA=$P(LEXSTA,"^",3),LEXSTA=+$P(LEXSTA,"^",1)
S LEXEXA=$$EXAI(LEXSIEN),LEXEXS=+($P(LEXEXA,"^",1)),LEXEXI=$P(LEXEXA,"^",3),LEXEXA=$P(LEXEXA,"^",2)
S LEXO=LEXSO_"^"_LEXNOM_"^"_LEXSAB S:$L($G(LEXSTA)) $P(LEXO,"^",4)=$G(LEXSTA)
S:$L($G(LEXACT)) $P(LEXO,"^",5)=$G(LEXACT) S:$L($G(LEXINA)) $P(LEXO,"^",6)=$G(LEXINA)
S:$L($G(LEXEXS)) $P(LEXO,"^",7)=$G(LEXEXS) S:$L($G(LEXEXA)) $P(LEXO,"^",8)=$G(LEXEXA)
S:$L($G(LEXEXI)) $P(LEXO,"^",9)=$G(LEXEXI) S:$L($G(LEXEVP)) $P(LEXO,"^",10)=$G(LEXEVP)
S:$L($G(LEXCVP)) $P(LEXO,"^",11)=$G(LEXCVP) S:$L($G(LEXSVP)) $P(LEXO,"^",12)=$G(LEXSVP)
S:$L($G(LEXNAT)) $P(LEXO,"^",13)=$G(LEXNAT)
S LEXNUM=$O(ARY(LEXCIEN,"D",LEXSIEN," "),-1)
S:LEXNUM'>0 LEXNUM=$O(ARY(LEXCIEN,"B",(LEXSO_" "),0))
S:LEXNUM'>0 LEXNUM=$O(ARY(LEXCIEN," "),-1)+1
S:'$D(ARY(LEXCIEN,+LEXNUM)) LEXCT=LEXCT+1
S ARY(LEXCIEN,+LEXNUM)=LEXO,ARY(LEXCIEN,"D",LEXSIEN,LEXNUM)=""
S ARY(LEXCIEN,"B",(LEXSO_" "),LEXNUM)=LEXSO_"^"_LEXNOM,ARY(LEXCIEN,"C",+LEXSRC,LEXNUM)=LEXSO_"^"_LEXNOM
Q
SOAI(X,Y) ; Source Status, Activation and Inactivation
N LEXACT,LEXEF,LEXINA,LEXSIEN,LEXSO,LEXSRC,LEXSTA S LEXSO=$G(X),LEXSRC=+($G(Y))
Q:'$L(LEXSO) "" Q:+LEXSRC'>0 "" Q:'$D(^LEX(757.03,+LEXSRC,0)) "" S (LEXSTA,LEXACT,LEXINA)=""
S LEXEF="" F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF)) Q:'$L(LEXEF) D
. N LEXSIEN S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF,LEXSIEN)) Q:+LEXSIEN'>0 D
. . Q:$P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)'=+LEXSRC S:'$L(LEXACT)!(LEXEF<LEXACT) LEXACT=LEXEF
S LEXEF="" F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXEF)) Q:'$L(LEXEF) D
. N LEXSIEN S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXEF,LEXSIEN)) Q:+LEXSIEN'>0 D
. . Q:$P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)'=+LEXSRC S:'$L(LEXINA)!(LEXEF>LEXINA) LEXINA=LEXEF
S:+($G(LEXACT))'>+($G(LEXINA)) LEXSTA=0 S:+($G(LEXACT))>+($G(LEXINA)) LEXINA="",LEXSTA=1
S X=LEXSTA_"^"_LEXACT_"^"_LEXINA
Q X
EXAI(X) ; Expression Activation and Inactivation
N LEXACT,LEXEF,LEXINA,LEXSIEN,LEXSTA S LEXSIEN=$G(X) Q:+LEXSIEN'>0 "" S (LEXSTA,LEXACT,LEXINA)=""
S LEXEF="" F S LEXEF=$O(^LEX(757.02,+($G(LEXSIEN)),4,"B",LEXEF)) Q:'$L(LEXEF) D
. N LEXHIS S LEXHIS=0 F S LEXHIS=$O(^LEX(757.02,+($G(LEXSIEN)),4,"B",LEXEF,LEXHIS)) Q:+LEXHIS'>0 D
. . N LEXDT,LEXND,LEXST S LEXND=$G(^LEX(757.02,+($G(LEXSIEN)),4,+LEXHIS,0)),LEXST=$P(LEXND,"^",2),LEXDT=$P(LEXND,"^",1)
. . S:LEXST=1&(+($G(LEXDT))>+($G(LEXACT))) LEXACT=+($G(LEXDT)) S:LEXST=0&(+($G(LEXDT))>+($G(LEXINA))) LEXINA=+($G(LEXDT))
S:+($G(LEXACT))'>+($G(LEXINA)) LEXSTA=0 S:+($G(LEXACT))>+($G(LEXINA)) LEXINA="",LEXSTA=1 S X=LEXSTA_"^"_LEXACT_"^"_LEXINA
Q X
EXM(X,LEX,LEXD,LEXM) ; Exact Match
;
; Input
;
; X Text to Search for (required)
; LEX Local Array Passed by Reference (will be killed)
; LEXD Boolean Flag - Deactivated Terms (optional)
; 1 Include deactivated terms
; 0 Do not include deactivated terms (default)
; LEXM Boolean Flag - Major Concepts (optional)
; 1 Include Major Concepts ONLY
; 0 Include all (default); Major Concepts, Synonyms,
; Lexical Variants and Fully Specified Names
;
; Output
;
; $$EXM Number of exact matches found
; LEX Ouput Local Array Passed by Reference
;
; LEX(0) 2 piece "^" dilimited string
; 1 Total Exact Matches found
; 2 Text Searched for
;
; LEX(#) 5 piece "^" dilimited string
; 1 IEN of Exact Match Expression
; 2 IEN of Major Concept for Expression
; 3 Type of Exact Match Expression (internal)
; 4 Deactivation Flag (internal)
; 5 Type of Exact Match Expression (external)
;
K LEX N LEXCTL,LEXIEN,LEXINC,LEXMCO,LEXORD,LEXORG,LEXTXT,LEXCT
S LEXORG=$G(X),LEXTXT=$$UP^XLFSTR(LEXORG) Q:$L(LEXTXT)<2 "" S LEXCTL=$E(LEXTXT,1,62),LEXCT=0
S LEXINC=+($G(LEXD)),LEXMCO=+($G(LEXM)),LEXORD=$E(LEXCTL,1,($L(LEXCTL)-1))_$C($A($E(LEXCTL,$L(LEXCTL)))-1)_"~"
F S LEXORD=$O(^LEX(757.01,"B",LEXORD)) Q:'$L(LEXORD) Q:$E(LEXORD,1,$L(LEXCTL))'=LEXCTL D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.01,"B",LEXORD,LEXIEN)) Q:+LEXIEN'>0 D
. . N LEXTY,LEXDF,LEXEXP,LEXMC,LEXTN,LEXI S LEXEXP=$G(^LEX(757.01,+LEXIEN,0)) Q:$$UP^XLFSTR(LEXEXP)'=LEXTXT
. . S LEXTY=$P($G(^LEX(757.01,+LEXIEN,1)),"^",2),LEXDF=$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)
. . Q:LEXTY'=1&(+($G(LEXMCO))>0) Q:LEXDF>0&(+($G(LEXINC))'>0)
. . S LEXTN=$S(LEXTY=1:"Major Concept",LEXTY=3:"Lexical Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
. . S:LEXDF>0 LEXTN="Deactivated "_LEXTN S LEXMC=+($P($G(^LEX(757.01,+LEXIEN,1)),"^",1))
. . S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=LEXIEN_"^"_LEXMC_"^"_LEXTY_"^"_LEXDF_"^"_LEXTN,LEX(0)=LEXI_"^"_LEXORG
I LEXINC>0 D
. S LEXINC=+($G(LEXD)),LEXMCO=+($G(LEXM)),LEXORD=$E(LEXCTL,1,($L(LEXCTL)-1))_$C($A($E(LEXCTL,$L(LEXCTL)))-1)_"~"
. F S LEXORD=$O(^LEX(757.01,"ADTERM",LEXORD)) Q:'$L(LEXORD) Q:$E(LEXORD,1,$L(LEXCTL))'=LEXCTL D
. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.01,"ADTERM",LEXORD,LEXIEN)) Q:+LEXIEN'>0 D
. . . N LEXTY,LEXDF,LEXEXP,LEXMC,LEXTN,LEXI S LEXEXP=$G(^LEX(757.01,+LEXIEN,0)) Q:$$UP^XLFSTR(LEXEXP)'=LEXTXT
. . . S LEXTY=$P($G(^LEX(757.01,+LEXIEN,1)),"^",2),LEXDF=$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)
. . . Q:LEXTY'=1&(+($G(LEXMCO))>0) Q:LEXDF>0&(+($G(LEXINC))'>0)
. . . S LEXTN=$S(LEXTY=1:"Major Concept",LEXTY=3:"Lexical Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
. . . S:LEXDF>0 LEXTN="Deactivated "_LEXTN S LEXMC=+($P($G(^LEX(757.01,+LEXIEN,1)),"^",1))
. . . S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=LEXIEN_"^"_LEXMC_"^"_LEXTY_"^"_LEXDF_"^"_LEXTN,LEX(0)=LEXI_"^"_LEXORG
S X=+($G(LEX(0)))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU6 12095 printed Sep 23, 2025@19:45:47 Page 2
LEXU6 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.001) N/A
+5 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+6 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$FMADD^XLFDT ICR 10103
+11 ; $$FMDIFF^XLFDT ICR 10103
+12 ; $$FMTE^XLFDT ICR 10103
+13 ; $$GET1^DIQ ICR 2056
+14 ; ^DIC ICR 10006
+15 ;
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXS Filter
+6 ; LEXVDT Date to use for screening by codes
+7 ;
+8 ; Output
+9 ;
+10 ; $$SC 1/0
+11 ;
+12 NEW LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC,X
DO VDT^LEXU
+13 SET LEXRREC=LEX
if '$DATA(^LEX(757.01,LEXRREC,0))
QUIT 0
+14 IF $LENGTH(LEXS,";")=3
IF $PIECE(LEXS,";",3)'=""
Begin DoDot:1
+15 SET LEXINC=0
SET LEXINC=$$SO(LEXRREC,$PIECE(LEXS,";",3),$GET(LEXVDT))
End DoDot:1
if +LEXINC>0
QUIT LEXINC
+16 SET LEXRREC=$PIECE(^LEX(757.01,LEXRREC,1),U,1)
+17 SET LEXINC=0
FOR LEXIC=1:1:$LENGTH($PIECE(LEXS,";",1),"/")
Begin DoDot:1
+18 NEW LEXP,LEX1,LEX2
SET LEXP=$PIECE($PIECE(LEXS,";",1),"/",LEXIC)
+19 SET LEX1=$DATA(^LEX(757.1,"AMCC",LEXRREC,LEXP))
+20 SET LEX2=$DATA(^LEX(757.1,"AMCT",LEXRREC,LEXP))
+21 IF LEX1!(LEX2)
Begin DoDot:2
+22 SET LEXINC=1
SET LEXIC=$LENGTH($PIECE(LEXS,";",1),"/")+1
End DoDot:2
End DoDot:1
+23 IF LEXINC=0!($PIECE(LEXS,";",2)="")
KILL LEXIC,LEXS,LEXEC
QUIT LEXINC
+24 SET LEXEXC=0
FOR LEXEC=1:1:$LENGTH($PIECE(LEXS,";",2),"/")
Begin DoDot:1
+25 NEW LEXP,LEX1,LEX2
SET LEXP=$PIECE($PIECE(LEXS,";",2),"/",LEXEC)
+26 SET LEX1=$DATA(^LEX(757.1,"AMCC",LEXRREC,LEXP))
+27 SET LEX2=$DATA(^LEX(757.1,"AMCT",LEXRREC,LEXP))
+28 IF LEX1!(LEX2)
Begin DoDot:2
+29 SET LEXEXC=1
SET LEXEC=$LENGTH($PIECE(LEXS,";",2),"/")+1
End DoDot:2
End DoDot:1
+30 IF LEXINC
IF 'LEXEXC
KILL LEXIC,LEXS,LEXEC
QUIT 1
+31 KILL LEXIC,LEXS,LEXEC
+32 QUIT 0
SO(LEX,LEXS,LEXVDT) ; Filter by Source
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXS Filter
+6 ; LEXVDT Date to use for screening by codes
+7 ;
+8 ; Output
+9 ;
+10 ; $$SO 1/0
+11 ;
+12 NEW LEXABR,LEXCR,LEXF,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXSO,LEXSR,LEXSTA,LEXTR
+13 SET LEXTR=+LEX
SET LEXF=0
if '$DATA(^LEX(757.01,LEXTR,0))
QUIT LEXF
+14 if '$DATA(^LEX(757.01,LEXTR))
QUIT LEXF
+15 SET LEXMC=$PIECE(^LEX(757.01,LEXTR,1),U,1)
+16 SET LEXMCE=+(^LEX(757,+($PIECE(^LEX(757.01,LEXTR,1),U,1)),0))
+17 DO VDT^LEXU
IF LEXTR>0
IF LEXMCE>0
IF LEXTR=LEXMCE
Begin DoDot:1
+18 SET LEXF=0
FOR LEXSR=1:1:$LENGTH(LEXS,"/")
Begin DoDot:2
+19 SET LEXABR=$PIECE(LEXS,"/",LEXSR)
SET LEXCR=0
+20 FOR
SET LEXCR=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXCR))
if +LEXCR=0
QUIT
Begin DoDot:3
+21 NEW LEXN0,LEXSAB,LEXQ
SET LEXQ=0
+22 SET LEXN0=$GET(^LEX(757.02,LEXCR,0))
+23 SET LEXSAB=+($PIECE(LEXN0,U,3))
SET LEXSO=$PIECE(LEXN0,U,2)
+24 IF $GET(LEXLKT)["BC"
Begin DoDot:4
+25 NEW LEXNAR
SET LEXNAR=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+26 IF $LENGTH($GET(LEXNAR))
if $EXTRACT(LEXSO,1,$LENGTH($GET(LEXNAR)))'=$GET(LEXNAR)
SET LEXQ=1
End DoDot:4
if LEXQ
QUIT
+27 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$GET(LEXVDT),,LEXSAB)
+28 if +LEXSTA'>0
QUIT
if $PIECE(LEXSTA,U,2)'=LEXCR
QUIT
+29 if '$DATA(^LEX(757.03,LEXSAB,0))
QUIT
+30 SET LEXSAB=$EXTRACT(^LEX(757.03,LEXSAB,0),1,3)
+31 IF LEXSAB=LEXABR
SET LEXF=1
End DoDot:3
if LEXF>0
QUIT
End DoDot:2
if LEXF>0
QUIT
End DoDot:1
GOTO SOQ
SOQ ; Quit Source Filter
+1 KILL LEXCR,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXABR,LEXSO,LEXSR,LEXSTA,LEXTR
+2 QUIT LEXF
SOS(X,ARY,SYN) ; Sources for Expression
+1 ;
+2 ; Input
+3 ; X Internal Entry Number Expression file #757.01
+4 ; .ARY Local Array Name passed by Reference
+5 ; SYN Include codes mapped via a Synonym
+6 ;
+7 ; Output
+8 ; ARY(IEN) IEN is from file #757.01 (same as X)
+9 ; ARY(IEN,0) Number of Codes Found
+10 ; ARY(IEN,#) # is a sequence number
+11 ;
+12 ; Equals an 13 Piece "^" delimited string
+13 ;
+14 ; 1 Code
+15 ; 2 Coding System Nomenclature
+16 ; 3 Coding System Source Abbreviation
+17 ; 4 Code Status
+18 ; 5 Code Active Date
+19 ; 6 Code Inactive Date
+20 ; 7 Expression Status
+21 ; 8 Expression Active Date
+22 ; 9 Expression Inactive Date
+23 ; 10 Expression Variable Pointer
+24 ; 11 Code Variable Pointer
+25 ; 12 Coding System Variable Pointer
+26 ; 13 National File Variable Pointer (if it exist)
+27 ;
+28 ; Array has two indexes
+29 ;
+30 ; ARY(IEN,"B",(CODE_" "),#)=Code_"^"_Nomenclature
+31 ; ARY(IEN,"C",SOURCE,#)=Code_"^"_Nomenclature
+32 ;
+33 NEW LEXCT,LEXCIEN,LEXEIEN,LEXI,LEXSIEN,LEXSF
SET LEXCT=0
SET (LEXCIEN,LEXEIEN)=+($GET(X))
if +LEXEIEN'>0
QUIT 0
+34 if '$DATA(^LEX(757.01,+($GET(LEXEIEN)),0))
QUIT 0
KILL ARY(LEXCIEN)
+35 if '$DATA(^LEX(757.01,+LEXEIEN,0))
QUIT 0
if '$DATA(^LEX(757.02,"B",+LEXEIEN))
QUIT 0
SET LEXSIEN=0
SET LEXSF=+($GET(SYN))
+36 ; Codes for an Expression
+37 IF +LEXSF'>0
Begin DoDot:1
+38 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"B",+LEXEIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
DO SOSE
End DoDot:1
+39 ; Codes for an Major Concept
+40 IF +LEXSF>0
Begin DoDot:1
+41 NEW LEXTMIEN
SET LEXTMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
SET LEXSIEN=0
+42 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AMC",+LEXTMIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+43 SET LEXEIEN=+($GET(^LEX(757.02,+LEXSIEN,0)))
DO SOSE
End DoDot:2
End DoDot:1
+44 SET (LEXI,LEXCT)=0
FOR
SET LEXI=$ORDER(ARY(LEXCIEN,LEXI))
if +LEXI'>0
QUIT
SET LEXCT=LEXCT+1
SET ARY(+LEXCIEN,0)=LEXCT
+45 KILL ARY(LEXCIEN,"D")
SET X=LEXCT
if +LEXCT>0
SET ARY(+LEXCIEN,0)=LEXCT
+46 QUIT X
SOSE ; Build array of Sources for Expression
+1 NEW LEXACT,LEXCVP,LEXEVP,LEXEXA,LEXEXI,LEXEXS,LEXINA,LEXNAT,LEXNIEN,LEXNOM,LEXNUM,LEXO,LEXSAB,LEXSO,LEXSRC,LEXSTA,LEXSVP
+2 SET (LEXNAT,LEXEVP,LEXCVP,LEXSVP)=""
SET LEXSO=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXSRC=$PIECE(LEXSO,"^",3)
+3 SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",1)
if '$LENGTH(LEXSAB)
QUIT
SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)
if '$LENGTH(LEXNOM)
QUIT
+4 SET LEXSO=$PIECE(LEXSO,"^",2)
if $EXTRACT(LEXSO,1,4)="U000"
QUIT
if +($GET(LEXEIEN))>0
SET LEXEVP=+($GET(LEXEIEN))_";LEX(757.01,"
+5 if +($GET(LEXSIEN))>0
SET LEXCVP=+($GET(LEXSIEN))_";LEX(757.02,"
if +($GET(LEXSRC))>0
SET LEXSVP=+($GET(LEXSRC))_";LEX(757.03,"
+6 IF LEXSRC=1!(LEXSRC=30)
SET LEXNIEN=$$CODEN^ICDEX(LEXSO,80)
if +LEXNIEN>0
SET LEXNAT=+LEXNIEN_";ICD9("
+7 IF LEXSRC=2!(LEXSRC=31)
SET LEXNIEN=$$CODEN^ICDEX(LEXSO,80.1)
if +LEXNIEN>0
SET LEXNAT=+LEXNIEN_";ICD0("
+8 IF LEXSRC=3!(LEXSRC=4)
SET LEXNIEN=$$CODEN^ICPTCOD(LEXSO)
if +LEXNIEN>0
SET LEXNAT=+LEXNIEN_";ICPT("
+9 SET LEXSTA=$$SOAI(LEXSO,LEXSRC)
SET LEXACT=$PIECE(LEXSTA,"^",2)
SET LEXINA=$PIECE(LEXSTA,"^",3)
SET LEXSTA=+$PIECE(LEXSTA,"^",1)
+10 SET LEXEXA=$$EXAI(LEXSIEN)
SET LEXEXS=+($PIECE(LEXEXA,"^",1))
SET LEXEXI=$PIECE(LEXEXA,"^",3)
SET LEXEXA=$PIECE(LEXEXA,"^",2)
+11 SET LEXO=LEXSO_"^"_LEXNOM_"^"_LEXSAB
if $LENGTH($GET(LEXSTA))
SET $PIECE(LEXO,"^",4)=$GET(LEXSTA)
+12 if $LENGTH($GET(LEXACT))
SET $PIECE(LEXO,"^",5)=$GET(LEXACT)
if $LENGTH($GET(LEXINA))
SET $PIECE(LEXO,"^",6)=$GET(LEXINA)
+13 if $LENGTH($GET(LEXEXS))
SET $PIECE(LEXO,"^",7)=$GET(LEXEXS)
if $LENGTH($GET(LEXEXA))
SET $PIECE(LEXO,"^",8)=$GET(LEXEXA)
+14 if $LENGTH($GET(LEXEXI))
SET $PIECE(LEXO,"^",9)=$GET(LEXEXI)
if $LENGTH($GET(LEXEVP))
SET $PIECE(LEXO,"^",10)=$GET(LEXEVP)
+15 if $LENGTH($GET(LEXCVP))
SET $PIECE(LEXO,"^",11)=$GET(LEXCVP)
if $LENGTH($GET(LEXSVP))
SET $PIECE(LEXO,"^",12)=$GET(LEXSVP)
+16 if $LENGTH($GET(LEXNAT))
SET $PIECE(LEXO,"^",13)=$GET(LEXNAT)
+17 SET LEXNUM=$ORDER(ARY(LEXCIEN,"D",LEXSIEN," "),-1)
+18 if LEXNUM'>0
SET LEXNUM=$ORDER(ARY(LEXCIEN,"B",(LEXSO_" "),0))
+19 if LEXNUM'>0
SET LEXNUM=$ORDER(ARY(LEXCIEN," "),-1)+1
+20 if '$DATA(ARY(LEXCIEN,+LEXNUM))
SET LEXCT=LEXCT+1
+21 SET ARY(LEXCIEN,+LEXNUM)=LEXO
SET ARY(LEXCIEN,"D",LEXSIEN,LEXNUM)=""
+22 SET ARY(LEXCIEN,"B",(LEXSO_" "),LEXNUM)=LEXSO_"^"_LEXNOM
SET ARY(LEXCIEN,"C",+LEXSRC,LEXNUM)=LEXSO_"^"_LEXNOM
+23 QUIT
SOAI(X,Y) ; Source Status, Activation and Inactivation
+1 NEW LEXACT,LEXEF,LEXINA,LEXSIEN,LEXSO,LEXSRC,LEXSTA
SET LEXSO=$GET(X)
SET LEXSRC=+($GET(Y))
+2 if '$LENGTH(LEXSO)
QUIT ""
if +LEXSRC'>0
QUIT ""
if '$DATA(^LEX(757.03,+LEXSRC,0))
QUIT ""
SET (LEXSTA,LEXACT,LEXINA)=""
+3 SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+4 NEW LEXSIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+5 if $PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)'=+LEXSRC
QUIT
if '$LENGTH(LEXACT)!(LEXEF<LEXACT)
SET LEXACT=LEXEF
End DoDot:2
End DoDot:1
+6 SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+7 NEW LEXSIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),2,LEXEF,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+8 if $PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)'=+LEXSRC
QUIT
if '$LENGTH(LEXINA)!(LEXEF>LEXINA)
SET LEXINA=LEXEF
End DoDot:2
End DoDot:1
+9 if +($GET(LEXACT))'>+($GET(LEXINA))
SET LEXSTA=0
if +($GET(LEXACT))>+($GET(LEXINA))
SET LEXINA=""
SET LEXSTA=1
+10 SET X=LEXSTA_"^"_LEXACT_"^"_LEXINA
+11 QUIT X
EXAI(X) ; Expression Activation and Inactivation
+1 NEW LEXACT,LEXEF,LEXINA,LEXSIEN,LEXSTA
SET LEXSIEN=$GET(X)
if +LEXSIEN'>0
QUIT ""
SET (LEXSTA,LEXACT,LEXINA)=""
+2 SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,+($GET(LEXSIEN)),4,"B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXHIS
SET LEXHIS=0
FOR
SET LEXHIS=$ORDER(^LEX(757.02,+($GET(LEXSIEN)),4,"B",LEXEF,LEXHIS))
if +LEXHIS'>0
QUIT
Begin DoDot:2
+4 NEW LEXDT,LEXND,LEXST
SET LEXND=$GET(^LEX(757.02,+($GET(LEXSIEN)),4,+LEXHIS,0))
SET LEXST=$PIECE(LEXND,"^",2)
SET LEXDT=$PIECE(LEXND,"^",1)
+5 if LEXST=1&(+($GET(LEXDT))>+($GET(LEXACT)))
SET LEXACT=+($GET(LEXDT))
if LEXST=0&(+($GET(LEXDT))>+($GET(LEXINA)))
SET LEXINA=+($GET(LEXDT))
End DoDot:2
End DoDot:1
+6 if +($GET(LEXACT))'>+($GET(LEXINA))
SET LEXSTA=0
if +($GET(LEXACT))>+($GET(LEXINA))
SET LEXINA=""
SET LEXSTA=1
SET X=LEXSTA_"^"_LEXACT_"^"_LEXINA
+7 QUIT X
EXM(X,LEX,LEXD,LEXM) ; Exact Match
+1 ;
+2 ; Input
+3 ;
+4 ; X Text to Search for (required)
+5 ; LEX Local Array Passed by Reference (will be killed)
+6 ; LEXD Boolean Flag - Deactivated Terms (optional)
+7 ; 1 Include deactivated terms
+8 ; 0 Do not include deactivated terms (default)
+9 ; LEXM Boolean Flag - Major Concepts (optional)
+10 ; 1 Include Major Concepts ONLY
+11 ; 0 Include all (default); Major Concepts, Synonyms,
+12 ; Lexical Variants and Fully Specified Names
+13 ;
+14 ; Output
+15 ;
+16 ; $$EXM Number of exact matches found
+17 ; LEX Ouput Local Array Passed by Reference
+18 ;
+19 ; LEX(0) 2 piece "^" dilimited string
+20 ; 1 Total Exact Matches found
+21 ; 2 Text Searched for
+22 ;
+23 ; LEX(#) 5 piece "^" dilimited string
+24 ; 1 IEN of Exact Match Expression
+25 ; 2 IEN of Major Concept for Expression
+26 ; 3 Type of Exact Match Expression (internal)
+27 ; 4 Deactivation Flag (internal)
+28 ; 5 Type of Exact Match Expression (external)
+29 ;
+30 KILL LEX
NEW LEXCTL,LEXIEN,LEXINC,LEXMCO,LEXORD,LEXORG,LEXTXT,LEXCT
+31 SET LEXORG=$GET(X)
SET LEXTXT=$$UP^XLFSTR(LEXORG)
if $LENGTH(LEXTXT)<2
QUIT ""
SET LEXCTL=$EXTRACT(LEXTXT,1,62)
SET LEXCT=0
+32 SET LEXINC=+($GET(LEXD))
SET LEXMCO=+($GET(LEXM))
SET LEXORD=$EXTRACT(LEXCTL,1,($LENGTH(LEXCTL)-1))_$CHAR($ASCII($EXTRACT(LEXCTL,$LENGTH(LEXCTL)))-1)_"~"
+33 FOR
SET LEXORD=$ORDER(^LEX(757.01,"B",LEXORD))
if '$LENGTH(LEXORD)
QUIT
if $EXTRACT(LEXORD,1,$LENGTH(LEXCTL))'=LEXCTL
QUIT
Begin DoDot:1
+34 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.01,"B",LEXORD,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+35 NEW LEXTY,LEXDF,LEXEXP,LEXMC,LEXTN,LEXI
SET LEXEXP=$GET(^LEX(757.01,+LEXIEN,0))
if $$UP^XLFSTR(LEXEXP)'=LEXTXT
QUIT
+36 SET LEXTY=$PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",2)
SET LEXDF=$PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)
+37 if LEXTY'=1&(+($GET(LEXMCO))>0)
QUIT
if LEXDF>0&(+($GET(LEXINC))'>0)
QUIT
+38 SET LEXTN=$SELECT(LEXTY=1:"Major Concept",LEXTY=3:"Lexical Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
+39 if LEXDF>0
SET LEXTN="Deactivated "_LEXTN
SET LEXMC=+($PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",1))
+40 SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=LEXIEN_"^"_LEXMC_"^"_LEXTY_"^"_LEXDF_"^"_LEXTN
SET LEX(0)=LEXI_"^"_LEXORG
End DoDot:2
End DoDot:1
+41 IF LEXINC>0
Begin DoDot:1
+42 SET LEXINC=+($GET(LEXD))
SET LEXMCO=+($GET(LEXM))
SET LEXORD=$EXTRACT(LEXCTL,1,($LENGTH(LEXCTL)-1))_$CHAR($ASCII($EXTRACT(LEXCTL,$LENGTH(LEXCTL)))-1)_"~"
+43 FOR
SET LEXORD=$ORDER(^LEX(757.01,"ADTERM",LEXORD))
if '$LENGTH(LEXORD)
QUIT
if $EXTRACT(LEXORD,1,$LENGTH(LEXCTL))'=LEXCTL
QUIT
Begin DoDot:2
+44 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.01,"ADTERM",LEXORD,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:3
+45 NEW LEXTY,LEXDF,LEXEXP,LEXMC,LEXTN,LEXI
SET LEXEXP=$GET(^LEX(757.01,+LEXIEN,0))
if $$UP^XLFSTR(LEXEXP)'=LEXTXT
QUIT
+46 SET LEXTY=$PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",2)
SET LEXDF=$PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)
+47 if LEXTY'=1&(+($GET(LEXMCO))>0)
QUIT
if LEXDF>0&(+($GET(LEXINC))'>0)
QUIT
+48 SET LEXTN=$SELECT(LEXTY=1:"Major Concept",LEXTY=3:"Lexical Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
+49 if LEXDF>0
SET LEXTN="Deactivated "_LEXTN
SET LEXMC=+($PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",1))
+50 SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=LEXIEN_"^"_LEXMC_"^"_LEXTY_"^"_LEXDF_"^"_LEXTN
SET LEX(0)=LEXI_"^"_LEXORG
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET X=+($GET(LEX(0)))
+52 QUIT X
