LEXCODE ;ISL/KER - Retrieval of IEN^Term based on Code ;04/21/2014
;;2.0;LEXICON UTILITY;**25,73,80**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
Q
; Source Abbreviatioin (SAB) is 3 character mnemonics for a
; classification/coding system. They can be found on the
; "ASAB" Cross-Reference of the Coding Systems file 757.03.
; Here are some of the more commonly used SABs:
;
; SAB Nomenclature Source
; -----------------------------------------------------------
; ICD ICD-9-CM Int'l Class of Diseases, Diagnosis
; ICP ICD-9 Proc Int'l Class of Diseases, Procedures
; 10D ICD-10-CM Int'l Class of Diseases, Diagnosis
; 10P ICD-10-PCS Int'l Class of Diseases, Procedures
; CPT CPT=4 Current Procedural Terminology
; CPC HCPCS Healthcare Common Procedure Codes
; SSC Title 38 Service Connected Codes
; DS4 DSM-IV Diag Manual of Mental Disorder
; SCT SNOMED CT SNOMED Clinical Terms
;
Q
EN(LEX,LEXVDT) ; Get terms associated with a Code
;
; Input
;
; LEX (Required) Code
;
; LEXVDT (Optional) The date against which the codes
; found by the search will be compared in order
; to determine whether the code is active or
; inactive. If not passed, TODAY's date will
; be used.
;
; Output Local Array LEXS
;
; LEXS(0)=Code
; LEXS(SAB,0)=Number of Terms found for SAB
; LEXS(SAB,0,"SAB")=Source Nomenclature ^ Name
; LEXS(SAB,#)=IEN file 757.01^Display Text (term)
;
; Example of returned array LEXS using code V62.4
;
; LEXS(0)="V62.4"
; LEXS("DS4",0)=1
; LEXS("DS4",0,"SAB")="DSM-IV^Diagnostic &
; Statistical Manual of Mental
; Disorders"
; LEXS("DS4",1)="303722^Acculturation Problem"
; LEXS("ICD",0)=5
; LEXS("ICD",0,"SAB")="ICD-9-CM^International
; Classification of Diseases,
; Diagnosis"
; LEXS("ICD",1)="111638^Social maladjustment"
; LEXS("ICD",2)="29696^Cultural Deprivation"
; LEXS("ICD",3)="100676^Psychosocial Deprivation"
; LEXS("ICD",4)="303722^Acculturation Problem"
; LEXS("ICD",5)="111507^Social Behavior
;
K LEXS S LEX=$$UP^XLFSTR($G(LEX)) Q:'$L(LEX)
N LEXSRC,LEXSO,LEXO,LEXEXI,LEXEXP,LEXSAB,LEXDA,LEXPF,LEXINA,LEXSTA
N LEXND D VDT^LEXU S LEXVDT=$G(LEXVDT)
S LEXS(0)=LEX,LEXO=LEX_" ",LEXDA=0 Q:'$D(^LEX(757.02,"CODE",LEXO))
F S LEXDA=$O(^LEX(757.02,"CODE",LEXO,LEXDA)) Q:+LEXDA=0 D CHK
D ASEM Q
CHK ; Check if Valid
N LEXPD,LEXPI,LEXPH,LEXEX
S LEXND=$G(^LEX(757.02,LEXDA,0)),LEXSO=$P(LEXND,"^",2) Q:LEXSO'=LEX
S LEXSRC=+($P(LEXND,"^",3)) Q:LEXSRC'>0
S LEXPD=$O(^LEX(757.02,+LEXDA,4,"B",(LEXVDT+.0001)),-1) Q:LEXPD'?7N
S LEXPI=$O(^LEX(757.02,+LEXDA,4,"B",LEXPD," "),-1) Q:+LEXPI'>0
S LEXPH=$G(^LEX(757.02,+LEXDA,4,+LEXPI,0)) Q:+($P(LEXPH,"^",2))'>0
S LEXEX=+LEXND Q:+LEXEX'>0 Q:'$D(^LEX(757.01,+LEXEX,0))
S LEXSAB=$E($G(^LEX(757.03,+LEXSRC,0)),1,3) Q:$L(LEXSAB)'=3
S LEXPF=+($P($G(^LEX(757.02,LEXDA,0)),"^",5))
S:LEXPF=1 LEXS(LEXSAB,"PRE")=LEXDA
S:LEXPF'=1 LEXS(LEXSAB,"OTH",LEXDA)=""
Q
ASEM ; Assemble List
Q:'$D(LEXS) N LEXSAB,LEXCT,LEXDA,LEXEX,LEXEXP,LEXY S LEXSAB=""
F S LEXSAB=$O(LEXS(LEXSAB)) Q:LEXSAB="" S LEXCT=0 D
. N LEXSABT S LEXSABT=$O(^LEX(757.03,"ASAB",LEXSAB,0))
. S LEXSABT=$P($G(^LEX(757.03,+LEXSABT,0)),"^",2,3)
. I $D(LEXS(LEXSAB,"PRE")) D
. . S LEXDA=LEXS(LEXSAB,"PRE") D LEXY
. S LEXDA=0
. F S LEXDA=$O(LEXS(LEXSAB,"OTH",LEXDA)) Q:+LEXDA=0 D LEXY
. I $L(LEXSAB) S:$D(^LEX(757.03,"ASAB",LEXSAB)) LEXS(LEXSAB,0)=LEXCT
. I $L($P($G(LEXSABT),"^",1)),$L($P($G(LEXSABT),"^",1)) D
. . S LEXS(LEXSAB,0,"SAB")=LEXSABT
Q
LEXY ; Get IEN^TERM for Code X
Q:+($G(LEXDA))'>0 Q:'$D(^LEX(757.02,+LEXDA,0))
K LEXS(LEXSAB,"OTH",LEXDA) K LEXS(LEXSAB,"PRE")
S LEXY="" N LEXEXI,LEXEXP
S LEXEXI=+($P($G(^LEX(757.02,+LEXDA,0)),"^",1)) Q:+LEXEXI'>0
Q:'$L($G(^LEX(757.01,+LEXEXI,0)))
S LEXEXP=$G(^LEX(757.01,+LEXEXI,0)),LEXCT=LEXCT+1
S LEXY=LEXEXI_"^"_LEXEXP,LEXS(LEXSAB,LEXCT)=LEXY
Q
;
CODE(X,LEXVDT,LEXSAB) ; Code for an Expression and Source
;
; Similar to $$ICDDX^ICDEX
; $$ICDOP^ICDEX
; $$CPT^ICPTCOD
; $$DX^ICDXCD
; $$PR^ICDXCD
;
; Except the data comes from the Lexicon and
; can be used for any source in file 757.03 and
; is not limited to ICD-9, ICD-10 and CPT.
;
; Input
;
; X Pointer to an Expression in file 757.01
; LEXVDT Versioning Date
; LEXSAB Source Abbreviation
;
; Output A 11 piece "^" delimited string
;
; 1 IEN of Code File ^LEX(757.02)
; 2 Code File ^LEX(757.02) Field #1
; 3 Expression Pointer to ^LEX(757.01)
; 4 Concept Expression Pointer to ^LEX(757.01)
; 5 Source Pointer ^LEX(757.03)
; 6 Preference File ^LEX(757.02) Field #4
; 7 Primary File ^LEX(757.02) Field #6
; 8 Status on date 4 multiple
; 9 Inactive Date 4 multiple
; 10 Active Date 4 multiple
; 11 Source Nomenclature File ^LEX(757.03) Field #1
;
N LEXAC,LEXE,LEXEF,LEXEX,LEXEXI,LEXH,LEXHE,LEXHI,LEXHS,LEXI
N LEXIEN,LEXIENS,LEXIN,LEXMC,LEXMCE,LEXN,LEXNAM,LEXND,LEXO
N LEXS,LEXSO,LEXSOI,LEXSRC,LEXST,LEXTY S LEXO="",LEXEX=+($G(X))
Q:'$D(^LEX(757.01,+LEXEX,0)) "-1^Expression not found"
Q:$P($G(^LEX(757.01,+LEXEX,1)),"^",5)>0 "-1^Expression deactivated"
S LEXIENS(LEXEX)=""
S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXMCE=+($G(^LEX(757,+LEXMC,0)))
S LEXTY=$P($G(^LEX(757.01,+LEXEX,1)),"^",2) I LEXTY=1 D
. N LEXMC,LEXI
. S LEXMC=+($G(^LEX(757.01,+LEXEX,1))),LEXI=0
. F S LEXI=$O(^LEX(757.01,"AMC",+LEXMC,LEXI)) Q:+LEXI'>0 D
. . Q:$P($G(^LEX(757.01,+LEXI,1)),"^",5)>0
. . S:+LEXI>0 LEXIENS(+LEXI)=""
Q:$O(LEXIENS(0))'>0 "-1^Expression not found"
S LEXVDT=$G(LEXVDT) D VDT^LEXU
S LEXSAB=$G(LEXSAB),LEXSRC=$$SAB^LEXSRC2(LEXSAB)
Q:+LEXSRC'>0 "-1^Invalid Source specified"
S LEXNAM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)
Q:'$L(LEXNAM) "-1^Invalid Source specified"
S LEXS=0,LEXO=""
S LEXIEN=0 F S LEXIEN=$O(LEXIENS(LEXIEN)) Q:+LEXIEN'>0 D Q:$L(LEXO)
. F S LEXS=$O(^LEX(757.02,"B",+LEXEX,LEXS)) Q:+LEXS'>0 D Q:$L(LEXO)
. . N LEXAC,LEXEF,LEXEXI,LEXHE,LEXHI,LEXHS,LEXIN,LEXND,LEXSOI,LEXST
. . S LEXND=$G(^LEX(757.02,+LEXS,0))
. . Q:$P(LEXND,"^",3)'=LEXSRC S LEXEXI=+LEXND
. . S LEXHE=$O(^LEX(757.02,+LEXS,4,"B",(LEXVDT+.00001)),-1) Q:+LEXHE'>0
. . S LEXHI=$O(^LEX(757.02,+LEXS,4,"B",LEXHE," "),-1) Q:+LEXHI'>0
. . S LEXHS=$G(^LEX(757.02,+LEXS,4,+LEXHI,0)) S LEXST=+$P(LEXHS,"^",2)
. . S LEXEF=LEXHE,LEXSO=$P(LEXND,"^",2)
. . S LEXSOI=+LEXS S:LEXST>0 LEXAC=LEXEF S:LEXST'>0 LEXIN=LEXEF
. . I LEXST'>0,LEXIN?7N S LEXAC=$$PA(LEXS,LEXIN)
. . I LEXST'>0,LEXIN?7N,$G(LEXAC)'?7N Q
. . S LEXO=$G(LEXS)_"^"_$G(LEXSO)_"^"_$G(LEXEXI)_"^"_$G(LEXMCE)_"^"
. . S LEXO=LEXO_$G(LEXSRC)_"^"_$P(LEXND,"^",5)_"^"_$P(LEXND,"^",7)
. . S LEXO=LEXO_"^"_$G(LEXST)_"^"_$G(LEXIN)_"^"_$G(LEXAC)_"^"_LEXNAM
S X=LEXO S:+X'>0 X="-1^"_LEXNAM_" Code not found"
Q X
;
EXP(LEX,LEXS,LEXVDT) ; Get Preferred Expression for an Active Code
;
; Input
;
; LEX (Required) Code
;
; LEXS (Required) This is either the three character
; Source Abbreviation (see list above) or a pointer
; to the Coding Systems file 757.03.
;
; LEXVDT (Optional) The date against which the codes
; found by the search will be compared in order
; to determine whether the code is active or
; inactive. If not passed, TODAY's date will
; be used.
;
; Output
;
; $$EXP 2 Piece "^" delimited string containing
;
; Either:
;
; 1 Pointer to Expression file #757.01
; 2 Display Text (Expression)
;
; or:
;
; 1 -1
; 2 Error Message
;
N LEXARY,LEXCDT,LEXCND,LEXEXP,LEXHI,LEXHND,LEXIN,LEXNOM,LEXORD,LEXPD
N LEXPF,LEXSB,LEXSI,LEXSR S (LEX,LEXIN)=$G(LEX)
Q:'$L(LEXIN) "-1^Code not passed" S LEXS=$G(LEXS)
Q:'$L(LEXS) "-1^Source not passed"
S LEXSR=+($O(^LEX(757.03,"ASAB",LEXS,0)))
S LEXSB=$E($G(^LEX(757.03,+LEXSR,0)),1,3)
I +LEXSR'>0!($L(LEXSB)'=3) D
. S LEXSR=0,LEXSB=$E($G(^LEX(757.03,+LEXS,0)),1,3)
. S:$L(LEXSB) LEXSR=+($O(^LEX(757.03,"ASAB",LEXSB,0)))
Q:+LEXSR'>0!($L(LEXSB)'=3) "-1^Invalid source passed"
I '$D(^LEX(757.03,+LEXSR,0))!('$D(^LEX(757.03,"ASAB",LEXSB))) D Q LEX
. S LEX="-1^Invalid source passed"
S LEXNOM=$P($G(^LEX(757.03,+LEXSR,0)),"^",2)
Q:'$L(LEXNOM) "-1^Invalid source on file"
S LEXORD=(LEXIN_" ") D VDT^LEXU S LEXCDT=$G(LEXVDT)
K LEXARY S LEXSI=" "
F S LEXSI=$O(^LEX(757.02,"CODE",LEXORD,LEXSI),-1) Q:+LEXSI'>0 D
. N LEXCND,LEXHND,LEXPD,LEXHI,LEXPF
. S LEXCND=$G(^LEX(757.02,+LEXSI,0)) Q:$P(LEXCND,"^",3)'=LEXSR
. S LEXPD=$O(^LEX(757.02,+LEXSI,4,"B",(LEXCDT+.0009)),-1) Q:LEXPD'?7N
. S LEXHI=$O(^LEX(757.02,+LEXSI,4,"B",LEXPD," "),-1) Q:+LEXHI'>0
. S LEXHND=$G(^LEX(757.02,+LEXSI,4,+LEXHI,0)) Q:$P(LEXHND,"^",2)'>0
. S LEXPF=+($P($G(^LEX(757.02,+LEXSI,0)),"^",5)) Q:LEXPF'>0
. S LEXARY(LEXSI,0)=LEXCND,LEXARY(LEXSI,4)=LEXHND
I $O(LEXARY(0))'>0 D Q LEX
. N LEXC S LEXC=LEX
. S LEX="-1^Active code/expression not found for "_LEXNOM_" code "
. S LEX=LEX_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
I $O(LEXARY(0))'=$O(LEXARY(" "),-1) D Q LEX
. N LEXC S LEXC=LEX
. S LEX="-1^Multiple active preferred expressions for "_LEXNOM
. S LEX=LEX_" code "_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
S LEXEXP=$O(LEXARY(0)),LEXEXP=+($G(LEXARY(+LEXEXP,0)))
Q:'$D(^LEX(757.01,+LEXEXP)) ("-1^Expression not found in file 757.01")
S LEX=LEXEXP_"^"_$P($G(^LEX(757.01,+LEXEXP,0)),"^",1)
Q LEX
;
; Miscellaneous
PA(X,Y) ; Previous Activation Date
N LEX,LEXA,LEXE,LEXI,LEXN S LEX=+($G(X)),LEXI=$G(Y)
Q:'$D(^LEX(757.02,LEXS,4)) Q:LEXI'?7N ""
S LEXA="",LEXE=LEXI+.000001
F S LEXE=$O(^LEX(757.02,+LEX,4,"B",LEXE),-1) Q:+LEXE'>0 D
. Q:LEXA?7N S LEXH=" "
. F S LEXH=$O(^LEX(757.02,+LEX,4,"B",LEXE,LEXH),-1) Q:+LEXH'>0 D
. . Q:LEXA?7N N LEXN S LEXN=$G(^LEX(757.02,+LEX,4,+LEXH,0))
. . S:$P(LEXN,"^",2)>0 LEXA=LEXE
S X="" S:LEXA?7N X=LEXA
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXCODE 11148 printed Dec 13, 2024@02:07:16 Page 2
LEXCODE ;ISL/KER - Retrieval of IEN^Term based on Code ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**25,73,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$DT^XLFDT ICR 10103
+8 ; $$FMTE^XLFDT ICR 10103
+9 ; $$UP^XLFSTR ICR 10104
+10 ;
+11 QUIT
+12 ; Source Abbreviatioin (SAB) is 3 character mnemonics for a
+13 ; classification/coding system. They can be found on the
+14 ; "ASAB" Cross-Reference of the Coding Systems file 757.03.
+15 ; Here are some of the more commonly used SABs:
+16 ;
+17 ; SAB Nomenclature Source
+18 ; -----------------------------------------------------------
+19 ; ICD ICD-9-CM Int'l Class of Diseases, Diagnosis
+20 ; ICP ICD-9 Proc Int'l Class of Diseases, Procedures
+21 ; 10D ICD-10-CM Int'l Class of Diseases, Diagnosis
+22 ; 10P ICD-10-PCS Int'l Class of Diseases, Procedures
+23 ; CPT CPT=4 Current Procedural Terminology
+24 ; CPC HCPCS Healthcare Common Procedure Codes
+25 ; SSC Title 38 Service Connected Codes
+26 ; DS4 DSM-IV Diag Manual of Mental Disorder
+27 ; SCT SNOMED CT SNOMED Clinical Terms
+28 ;
+29 QUIT
EN(LEX,LEXVDT) ; Get terms associated with a Code
+1 ;
+2 ; Input
+3 ;
+4 ; LEX (Required) Code
+5 ;
+6 ; LEXVDT (Optional) The date against which the codes
+7 ; found by the search will be compared in order
+8 ; to determine whether the code is active or
+9 ; inactive. If not passed, TODAY's date will
+10 ; be used.
+11 ;
+12 ; Output Local Array LEXS
+13 ;
+14 ; LEXS(0)=Code
+15 ; LEXS(SAB,0)=Number of Terms found for SAB
+16 ; LEXS(SAB,0,"SAB")=Source Nomenclature ^ Name
+17 ; LEXS(SAB,#)=IEN file 757.01^Display Text (term)
+18 ;
+19 ; Example of returned array LEXS using code V62.4
+20 ;
+21 ; LEXS(0)="V62.4"
+22 ; LEXS("DS4",0)=1
+23 ; LEXS("DS4",0,"SAB")="DSM-IV^Diagnostic &
+24 ; Statistical Manual of Mental
+25 ; Disorders"
+26 ; LEXS("DS4",1)="303722^Acculturation Problem"
+27 ; LEXS("ICD",0)=5
+28 ; LEXS("ICD",0,"SAB")="ICD-9-CM^International
+29 ; Classification of Diseases,
+30 ; Diagnosis"
+31 ; LEXS("ICD",1)="111638^Social maladjustment"
+32 ; LEXS("ICD",2)="29696^Cultural Deprivation"
+33 ; LEXS("ICD",3)="100676^Psychosocial Deprivation"
+34 ; LEXS("ICD",4)="303722^Acculturation Problem"
+35 ; LEXS("ICD",5)="111507^Social Behavior
+36 ;
+37 KILL LEXS
SET LEX=$$UP^XLFSTR($GET(LEX))
if '$LENGTH(LEX)
QUIT
+38 NEW LEXSRC,LEXSO,LEXO,LEXEXI,LEXEXP,LEXSAB,LEXDA,LEXPF,LEXINA,LEXSTA
+39 NEW LEXND
DO VDT^LEXU
SET LEXVDT=$GET(LEXVDT)
+40 SET LEXS(0)=LEX
SET LEXO=LEX_" "
SET LEXDA=0
if '$DATA(^LEX(757.02,"CODE",LEXO))
QUIT
+41 FOR
SET LEXDA=$ORDER(^LEX(757.02,"CODE",LEXO,LEXDA))
if +LEXDA=0
QUIT
DO CHK
+42 DO ASEM
QUIT
CHK ; Check if Valid
+1 NEW LEXPD,LEXPI,LEXPH,LEXEX
+2 SET LEXND=$GET(^LEX(757.02,LEXDA,0))
SET LEXSO=$PIECE(LEXND,"^",2)
if LEXSO'=LEX
QUIT
+3 SET LEXSRC=+($PIECE(LEXND,"^",3))
if LEXSRC'>0
QUIT
+4 SET LEXPD=$ORDER(^LEX(757.02,+LEXDA,4,"B",(LEXVDT+.0001)),-1)
if LEXPD'?7N
QUIT
+5 SET LEXPI=$ORDER(^LEX(757.02,+LEXDA,4,"B",LEXPD," "),-1)
if +LEXPI'>0
QUIT
+6 SET LEXPH=$GET(^LEX(757.02,+LEXDA,4,+LEXPI,0))
if +($PIECE(LEXPH,"^",2))'>0
QUIT
+7 SET LEXEX=+LEXND
if +LEXEX'>0
QUIT
if '$DATA(^LEX(757.01,+LEXEX,0))
QUIT
+8 SET LEXSAB=$EXTRACT($GET(^LEX(757.03,+LEXSRC,0)),1,3)
if $LENGTH(LEXSAB)'=3
QUIT
+9 SET LEXPF=+($PIECE($GET(^LEX(757.02,LEXDA,0)),"^",5))
+10 if LEXPF=1
SET LEXS(LEXSAB,"PRE")=LEXDA
+11 if LEXPF'=1
SET LEXS(LEXSAB,"OTH",LEXDA)=""
+12 QUIT
ASEM ; Assemble List
+1 if '$DATA(LEXS)
QUIT
NEW LEXSAB,LEXCT,LEXDA,LEXEX,LEXEXP,LEXY
SET LEXSAB=""
+2 FOR
SET LEXSAB=$ORDER(LEXS(LEXSAB))
if LEXSAB=""
QUIT
SET LEXCT=0
Begin DoDot:1
+3 NEW LEXSABT
SET LEXSABT=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
+4 SET LEXSABT=$PIECE($GET(^LEX(757.03,+LEXSABT,0)),"^",2,3)
+5 IF $DATA(LEXS(LEXSAB,"PRE"))
Begin DoDot:2
+6 SET LEXDA=LEXS(LEXSAB,"PRE")
DO LEXY
End DoDot:2
+7 SET LEXDA=0
+8 FOR
SET LEXDA=$ORDER(LEXS(LEXSAB,"OTH",LEXDA))
if +LEXDA=0
QUIT
DO LEXY
+9 IF $LENGTH(LEXSAB)
if $DATA(^LEX(757.03,"ASAB",LEXSAB))
SET LEXS(LEXSAB,0)=LEXCT
+10 IF $LENGTH($PIECE($GET(LEXSABT),"^",1))
IF $LENGTH($PIECE($GET(LEXSABT),"^",1))
Begin DoDot:2
+11 SET LEXS(LEXSAB,0,"SAB")=LEXSABT
End DoDot:2
End DoDot:1
+12 QUIT
LEXY ; Get IEN^TERM for Code X
+1 if +($GET(LEXDA))'>0
QUIT
if '$DATA(^LEX(757.02,+LEXDA,0))
QUIT
+2 KILL LEXS(LEXSAB,"OTH",LEXDA)
KILL LEXS(LEXSAB,"PRE")
+3 SET LEXY=""
NEW LEXEXI,LEXEXP
+4 SET LEXEXI=+($PIECE($GET(^LEX(757.02,+LEXDA,0)),"^",1))
if +LEXEXI'>0
QUIT
+5 if '$LENGTH($GET(^LEX(757.01,+LEXEXI,0)))
QUIT
+6 SET LEXEXP=$GET(^LEX(757.01,+LEXEXI,0))
SET LEXCT=LEXCT+1
+7 SET LEXY=LEXEXI_"^"_LEXEXP
SET LEXS(LEXSAB,LEXCT)=LEXY
+8 QUIT
+9 ;
CODE(X,LEXVDT,LEXSAB) ; Code for an Expression and Source
+1 ;
+2 ; Similar to $$ICDDX^ICDEX
+3 ; $$ICDOP^ICDEX
+4 ; $$CPT^ICPTCOD
+5 ; $$DX^ICDXCD
+6 ; $$PR^ICDXCD
+7 ;
+8 ; Except the data comes from the Lexicon and
+9 ; can be used for any source in file 757.03 and
+10 ; is not limited to ICD-9, ICD-10 and CPT.
+11 ;
+12 ; Input
+13 ;
+14 ; X Pointer to an Expression in file 757.01
+15 ; LEXVDT Versioning Date
+16 ; LEXSAB Source Abbreviation
+17 ;
+18 ; Output A 11 piece "^" delimited string
+19 ;
+20 ; 1 IEN of Code File ^LEX(757.02)
+21 ; 2 Code File ^LEX(757.02) Field #1
+22 ; 3 Expression Pointer to ^LEX(757.01)
+23 ; 4 Concept Expression Pointer to ^LEX(757.01)
+24 ; 5 Source Pointer ^LEX(757.03)
+25 ; 6 Preference File ^LEX(757.02) Field #4
+26 ; 7 Primary File ^LEX(757.02) Field #6
+27 ; 8 Status on date 4 multiple
+28 ; 9 Inactive Date 4 multiple
+29 ; 10 Active Date 4 multiple
+30 ; 11 Source Nomenclature File ^LEX(757.03) Field #1
+31 ;
+32 NEW LEXAC,LEXE,LEXEF,LEXEX,LEXEXI,LEXH,LEXHE,LEXHI,LEXHS,LEXI
+33 NEW LEXIEN,LEXIENS,LEXIN,LEXMC,LEXMCE,LEXN,LEXNAM,LEXND,LEXO
+34 NEW LEXS,LEXSO,LEXSOI,LEXSRC,LEXST,LEXTY
SET LEXO=""
SET LEXEX=+($GET(X))
+35 if '$DATA(^LEX(757.01,+LEXEX,0))
QUIT "-1^Expression not found"
+36 if $PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",5)>0
QUIT "-1^Expression deactivated"
+37 SET LEXIENS(LEXEX)=""
+38 SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
SET LEXMCE=+($GET(^LEX(757,+LEXMC,0)))
+39 SET LEXTY=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",2)
IF LEXTY=1
Begin DoDot:1
+40 NEW LEXMC,LEXI
+41 SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
SET LEXI=0
+42 FOR
SET LEXI=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+43 if $PIECE($GET(^LEX(757.01,+LEXI,1)),"^",5)>0
QUIT
+44 if +LEXI>0
SET LEXIENS(+LEXI)=""
End DoDot:2
End DoDot:1
+45 if $ORDER(LEXIENS(0))'>0
QUIT "-1^Expression not found"
+46 SET LEXVDT=$GET(LEXVDT)
DO VDT^LEXU
+47 SET LEXSAB=$GET(LEXSAB)
SET LEXSRC=$$SAB^LEXSRC2(LEXSAB)
+48 if +LEXSRC'>0
QUIT "-1^Invalid Source specified"
+49 SET LEXNAM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)
+50 if '$LENGTH(LEXNAM)
QUIT "-1^Invalid Source specified"
+51 SET LEXS=0
SET LEXO=""
+52 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(LEXIENS(LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+53 FOR
SET LEXS=$ORDER(^LEX(757.02,"B",+LEXEX,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:2
+54 NEW LEXAC,LEXEF,LEXEXI,LEXHE,LEXHI,LEXHS,LEXIN,LEXND,LEXSOI,LEXST
+55 SET LEXND=$GET(^LEX(757.02,+LEXS,0))
+56 if $PIECE(LEXND,"^",3)'=LEXSRC
QUIT
SET LEXEXI=+LEXND
+57 SET LEXHE=$ORDER(^LEX(757.02,+LEXS,4,"B",(LEXVDT+.00001)),-1)
if +LEXHE'>0
QUIT
+58 SET LEXHI=$ORDER(^LEX(757.02,+LEXS,4,"B",LEXHE," "),-1)
if +LEXHI'>0
QUIT
+59 SET LEXHS=$GET(^LEX(757.02,+LEXS,4,+LEXHI,0))
SET LEXST=+$PIECE(LEXHS,"^",2)
+60 SET LEXEF=LEXHE
SET LEXSO=$PIECE(LEXND,"^",2)
+61 SET LEXSOI=+LEXS
if LEXST>0
SET LEXAC=LEXEF
if LEXST'>0
SET LEXIN=LEXEF
+62 IF LEXST'>0
IF LEXIN?7N
SET LEXAC=$$PA(LEXS,LEXIN)
+63 IF LEXST'>0
IF LEXIN?7N
IF $GET(LEXAC)'?7N
QUIT
+64 SET LEXO=$GET(LEXS)_"^"_$GET(LEXSO)_"^"_$GET(LEXEXI)_"^"_$GET(LEXMCE)_"^"
+65 SET LEXO=LEXO_$GET(LEXSRC)_"^"_$PIECE(LEXND,"^",5)_"^"_$PIECE(LEXND,"^",7)
+66 SET LEXO=LEXO_"^"_$GET(LEXST)_"^"_$GET(LEXIN)_"^"_$GET(LEXAC)_"^"_LEXNAM
End DoDot:2
if $LENGTH(LEXO)
QUIT
End DoDot:1
if $LENGTH(LEXO)
QUIT
+67 SET X=LEXO
if +X'>0
SET X="-1^"_LEXNAM_" Code not found"
+68 QUIT X
+69 ;
EXP(LEX,LEXS,LEXVDT) ; Get Preferred Expression for an Active Code
+1 ;
+2 ; Input
+3 ;
+4 ; LEX (Required) Code
+5 ;
+6 ; LEXS (Required) This is either the three character
+7 ; Source Abbreviation (see list above) or a pointer
+8 ; to the Coding Systems file 757.03.
+9 ;
+10 ; LEXVDT (Optional) The date against which the codes
+11 ; found by the search will be compared in order
+12 ; to determine whether the code is active or
+13 ; inactive. If not passed, TODAY's date will
+14 ; be used.
+15 ;
+16 ; Output
+17 ;
+18 ; $$EXP 2 Piece "^" delimited string containing
+19 ;
+20 ; Either:
+21 ;
+22 ; 1 Pointer to Expression file #757.01
+23 ; 2 Display Text (Expression)
+24 ;
+25 ; or:
+26 ;
+27 ; 1 -1
+28 ; 2 Error Message
+29 ;
+30 NEW LEXARY,LEXCDT,LEXCND,LEXEXP,LEXHI,LEXHND,LEXIN,LEXNOM,LEXORD,LEXPD
+31 NEW LEXPF,LEXSB,LEXSI,LEXSR
SET (LEX,LEXIN)=$GET(LEX)
+32 if '$LENGTH(LEXIN)
QUIT "-1^Code not passed"
SET LEXS=$GET(LEXS)
+33 if '$LENGTH(LEXS)
QUIT "-1^Source not passed"
+34 SET LEXSR=+($ORDER(^LEX(757.03,"ASAB",LEXS,0)))
+35 SET LEXSB=$EXTRACT($GET(^LEX(757.03,+LEXSR,0)),1,3)
+36 IF +LEXSR'>0!($LENGTH(LEXSB)'=3)
Begin DoDot:1
+37 SET LEXSR=0
SET LEXSB=$EXTRACT($GET(^LEX(757.03,+LEXS,0)),1,3)
+38 if $LENGTH(LEXSB)
SET LEXSR=+($ORDER(^LEX(757.03,"ASAB",LEXSB,0)))
End DoDot:1
+39 if +LEXSR'>0!($LENGTH(LEXSB)'=3)
QUIT "-1^Invalid source passed"
+40 IF '$DATA(^LEX(757.03,+LEXSR,0))!('$DATA(^LEX(757.03,"ASAB",LEXSB)))
Begin DoDot:1
+41 SET LEX="-1^Invalid source passed"
End DoDot:1
QUIT LEX
+42 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
+43 if '$LENGTH(LEXNOM)
QUIT "-1^Invalid source on file"
+44 SET LEXORD=(LEXIN_" ")
DO VDT^LEXU
SET LEXCDT=$GET(LEXVDT)
+45 KILL LEXARY
SET LEXSI=" "
+46 FOR
SET LEXSI=$ORDER(^LEX(757.02,"CODE",LEXORD,LEXSI),-1)
if +LEXSI'>0
QUIT
Begin DoDot:1
+47 NEW LEXCND,LEXHND,LEXPD,LEXHI,LEXPF
+48 SET LEXCND=$GET(^LEX(757.02,+LEXSI,0))
if $PIECE(LEXCND,"^",3)'=LEXSR
QUIT
+49 SET LEXPD=$ORDER(^LEX(757.02,+LEXSI,4,"B",(LEXCDT+.0009)),-1)
if LEXPD'?7N
QUIT
+50 SET LEXHI=$ORDER(^LEX(757.02,+LEXSI,4,"B",LEXPD," "),-1)
if +LEXHI'>0
QUIT
+51 SET LEXHND=$GET(^LEX(757.02,+LEXSI,4,+LEXHI,0))
if $PIECE(LEXHND,"^",2)'>0
QUIT
+52 SET LEXPF=+($PIECE($GET(^LEX(757.02,+LEXSI,0)),"^",5))
if LEXPF'>0
QUIT
+53 SET LEXARY(LEXSI,0)=LEXCND
SET LEXARY(LEXSI,4)=LEXHND
End DoDot:1
+54 IF $ORDER(LEXARY(0))'>0
Begin DoDot:1
+55 NEW LEXC
SET LEXC=LEX
+56 SET LEX="-1^Active code/expression not found for "_LEXNOM_" code "
+57 SET LEX=LEX_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
End DoDot:1
QUIT LEX
+58 IF $ORDER(LEXARY(0))'=$ORDER(LEXARY(" "),-1)
Begin DoDot:1
+59 NEW LEXC
SET LEXC=LEX
+60 SET LEX="-1^Multiple active preferred expressions for "_LEXNOM
+61 SET LEX=LEX_" code "_LEXC_" on "_$$FMTE^XLFDT(LEXCDT,"5Z")
End DoDot:1
QUIT LEX
+62 SET LEXEXP=$ORDER(LEXARY(0))
SET LEXEXP=+($GET(LEXARY(+LEXEXP,0)))
+63 if '$DATA(^LEX(757.01,+LEXEXP))
QUIT ("-1^Expression not found in file 757.01")
+64 SET LEX=LEXEXP_"^"_$PIECE($GET(^LEX(757.01,+LEXEXP,0)),"^",1)
+65 QUIT LEX
+66 ;
+67 ; Miscellaneous
PA(X,Y) ; Previous Activation Date
+1 NEW LEX,LEXA,LEXE,LEXI,LEXN
SET LEX=+($GET(X))
SET LEXI=$GET(Y)
+2 if '$DATA(^LEX(757.02,LEXS,4))
QUIT
if LEXI'?7N
QUIT ""
+3 SET LEXA=""
SET LEXE=LEXI+.000001
+4 FOR
SET LEXE=$ORDER(^LEX(757.02,+LEX,4,"B",LEXE),-1)
if +LEXE'>0
QUIT
Begin DoDot:1
+5 if LEXA?7N
QUIT
SET LEXH=" "
+6 FOR
SET LEXH=$ORDER(^LEX(757.02,+LEX,4,"B",LEXE,LEXH),-1)
if +LEXH'>0
QUIT
Begin DoDot:2
+7 if LEXA?7N
QUIT
NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEX,4,+LEXH,0))
+8 if $PIECE(LEXN,"^",2)>0
SET LEXA=LEXE
End DoDot:2
End DoDot:1
+9 SET X=""
if LEXA?7N
SET X=LEXA
+10 QUIT X
