ORQQPL4 ; ISL/JER/TC - Lexicon Look-up w/Synonyms ;07/30/15 08:25
;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,361,350,401**;Dec 17, 1997;Build 11
;
; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J)
; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J)
; ICR 5699 $$ICDDATA^ICDXCODE
;
Q
LEX(LST,X,VIEW,ORDATE,ORINCSYN) ; return list after lexicon lookup
; Call with: X (Required) The search text entered by the user
; [VIEW] (Optional) The Lexicon VIEW parameter (Defaults to
; Problem List Subset (i.e., "PLS")
; [ORDATE] (Optional) the date of interest (Defaults to TODAY)
; [ORINCSYN] (Optional) Boolean flag specifying whether or not to
; include synonyms for SNOMED CT Concepts
; (Defaults to 0 (FALSE))
;
; Returns: LST=gvn of ^TMP("ORLEX",$J), which contains search result set as:
; ^TMP("ORLEX",$J,1..n)=LEXIEN^PREFTEXT^ICDCODE(S)^ICDIEN^CODESYS^CONCEPTID^DESIGID^ICDVER^PARENTSUBSCRIPT
; ^TMP("ORLEX",$J,n+1)="<n> matches found"
;
N LEX,ILST,I,IEN,APP
N DIC ; p401 if an erroneous DIC("S") is left in memory it causes issues in LOOK^LEXA
S APP="GMPX",LST=$NA(^TMP("ORLEX",$J)) K @LST
S:'+$G(ORDATE) ORDATE=DT
S:'$L($G(VIEW)) VIEW="PLS"
S ORINCSYN=+$G(ORINCSYN)
I $S(X?.1A2.3N.1".".2N:1,X?.1A2.3N1"+":1,1:0) D Q
. S @LST@(1)="icd^Searching by code on the Problems Tab supports SNOMED CT, but not ICD."
. S @LST@(2)="Please try a different search"
D CONFIG^LEXSET(APP,VIEW,ORDATE)
; call LOOK^LEXA to execute the search as defined by the call to CONFIG^LEXSET
D LOOK^LEXA(X,,1,,ORDATE)
I '$D(LEX("LIST",1)) D G LEXX
. S:X?.N @LST@(1)="Code search failed"
S ILST=0
S @LST@(1)=$$LEXXFRM(LEX("LIST",1),ORDATE,APP),ILST=1
D:ORINCSYN SYNONYMS(.LST,.ILST,"SCT",$P(@LST@(1),U,6),ORDATE)
S (I,IEN)=""
F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950
.F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D
..N TXT,ELEMENT S TXT=^TMP("LEXFND",$J,I,IEN)
..S ELEMENT=IEN_U_TXT
..S ELEMENT=$$LEXXFRM(ELEMENT,ORDATE,APP)
..S ILST=ILST+1,@LST@(ILST)=ELEMENT
..D:ORINCSYN SYNONYMS(.LST,.ILST,"SCT",$P(ELEMENT,U,6),ORDATE)
I '$D(@LST@(1)) S @LST@(1)="No matches found"
E S @LST@(ILST+1)=ILST_$S(ILST=1:" match",1:" matches")_" found"
LEXX K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J),^TMP("LEXLE",$J)
Q
LEXXFRM(ORX,ORDATE,ORAPP) ; Transform text for SCT look-up
N ORLEX,ORY,ORICD,ORSCT,ORTXT,ORCODSYS,ORCCODE,ORDCODE
S ORLEX=$P(ORX,U),ORTXT=$P(ORX,U,2),(ORCCODE,ORCODSYS)=""
I ORTXT["*" S ORTXT=$$STRIP^XLFSTR(ORTXT,"*")
I (ORTXT["("),(ORTXT[")") D
. S ORCODSYS=$RE($P($P($RE(ORTXT),"("),")",2))
. S ORCCODE=$$ONE^LEXU(+ORLEX,ORDATE,"SCT"),ORCODSYS=$RE($P($RE(ORCODSYS)," ",2,99))
. S ORTXT=$$TRIM^XLFSTR($RE($P($RE(ORTXT),"(",2,99)))
S ORY=$$SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE)
Q ORY
SYNONYMS(LST,ILST,ORCSYS,ORCCODE,ORDT) ; Get synonyms for expression
N ORSYN,ORI,ORDAD S ORDT=$G(ORDT,DT),ORDAD=ILST
D GETSYN^LEXTRAN1(ORCSYS,ORCCODE,ORDT,"ORSYN",1,1)
S ORI=0 F S ORI=$O(ORSYN("S",ORI)) Q:+ORI'>0 D
. N ELEMENT,TXT,IEN,ORDCODE
. S IEN=$P(ORSYN("S",ORI),U,2),TXT=$P(ORSYN("S",ORI),U),ORDCODE=$P(ORSYN("S",ORI),U,3)
. S ELEMENT=$$SETELEM(IEN,TXT,"SNOMED CT",ORCCODE,ORDT,ORDCODE)_U_ORDAD
. S ILST=ILST+1,@LST@(ILST)=ELEMENT
Q
SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE,ORDCODE) ; Set List Element
N ORY,ORIMPDT,ORICD,ORICDID,ORSYN,ORTYP,ORQT,ORNUM
S ORIMPDT=$$IMPDATE^LEXU("10D"),(ORTYP,ORQT,ORNUM)=""
I '$D(ORDCODE) D
. S ORDCODE=$$GETSYN^LEXTRAN1("SCT",ORCCODE,ORDATE,"ORSYN",1,1)
. I $P(ORDCODE,U)'=1 S ORDCODE="" Q
. F S ORTYP=$O(ORSYN(ORTYP)) Q:ORTYP="S"!(ORQT) D
. . I $P(ORSYN(ORTYP),U)=ORTXT S ORDCODE=$P(ORSYN(ORTYP),U,3),ORQT=1 Q
. I ORTYP="S" F S ORNUM=$O(ORSYN(ORTYP,ORNUM)) Q:ORNUM=""!(ORQT) D
. . I $P(ORSYN(ORTYP,ORNUM),U)=ORTXT S ORDCODE=$P(ORSYN(ORTYP,ORNUM),U,3),ORQT=1 Q
I ORDCODE["^" S ORDCODE=""
S ORICD=$$GETDX^ORQQPL1(ORCCODE,ORCODSYS,ORDATE)
S ORICDID=+$$ICDDATA^ICDXCODE("DIAG",$P(ORICD,"/"),ORDATE,"E")
S ORY=ORLEX_U_ORTXT_U_ORICD_U_ORICDID_U_ORCODSYS_U_ORCCODE_U_ORDCODE
I (ORCODSYS["SNOMED")!(ORCODSYS["VHAT") D
.S ORY=ORY_U_$S(ORDATE<ORIMPDT:"ICD-9-CM",1:"ICD-10-CM")
Q ORY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPL4 4365 printed Sep 23, 2025@20:10:02 Page 2
ORQQPL4 ; ISL/JER/TC - Lexicon Look-up w/Synonyms ;07/30/15 08:25
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,361,350,401**;Dec 17, 1997;Build 11
+2 ;
+3 ; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J)
+4 ; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J)
+5 ; ICR 5699 $$ICDDATA^ICDXCODE
+6 ;
+7 QUIT
LEX(LST,X,VIEW,ORDATE,ORINCSYN) ; return list after lexicon lookup
+1 ; Call with: X (Required) The search text entered by the user
+2 ; [VIEW] (Optional) The Lexicon VIEW parameter (Defaults to
+3 ; Problem List Subset (i.e., "PLS")
+4 ; [ORDATE] (Optional) the date of interest (Defaults to TODAY)
+5 ; [ORINCSYN] (Optional) Boolean flag specifying whether or not to
+6 ; include synonyms for SNOMED CT Concepts
+7 ; (Defaults to 0 (FALSE))
+8 ;
+9 ; Returns: LST=gvn of ^TMP("ORLEX",$J), which contains search result set as:
+10 ; ^TMP("ORLEX",$J,1..n)=LEXIEN^PREFTEXT^ICDCODE(S)^ICDIEN^CODESYS^CONCEPTID^DESIGID^ICDVER^PARENTSUBSCRIPT
+11 ; ^TMP("ORLEX",$J,n+1)="<n> matches found"
+12 ;
+13 NEW LEX,ILST,I,IEN,APP
+14 ; p401 if an erroneous DIC("S") is left in memory it causes issues in LOOK^LEXA
NEW DIC
+15 SET APP="GMPX"
SET LST=$NAME(^TMP("ORLEX",$JOB))
KILL @LST
+16 if '+$GET(ORDATE)
SET ORDATE=DT
+17 if '$LENGTH($GET(VIEW))
SET VIEW="PLS"
+18 SET ORINCSYN=+$GET(ORINCSYN)
+19 IF $SELECT(X?.1A2.3N.1".".2N:1,X?.1A2.3N1"+":1,1:0)
Begin DoDot:1
+20 SET @LST@(1)="icd^Searching by code on the Problems Tab supports SNOMED CT, but not ICD."
+21 SET @LST@(2)="Please try a different search"
End DoDot:1
QUIT
+22 DO CONFIG^LEXSET(APP,VIEW,ORDATE)
+23 ; call LOOK^LEXA to execute the search as defined by the call to CONFIG^LEXSET
+24 DO LOOK^LEXA(X,,1,,ORDATE)
+25 IF '$DATA(LEX("LIST",1))
Begin DoDot:1
+26 if X?.N
SET @LST@(1)="Code search failed"
End DoDot:1
GOTO LEXX
+27 SET ILST=0
+28 SET @LST@(1)=$$LEXXFRM(LEX("LIST",1),ORDATE,APP)
SET ILST=1
+29 if ORINCSYN
DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(@LST@(1),U,6),ORDATE)
+30 SET (I,IEN)=""
+31 ;DBIA 2950
FOR
SET I=$ORDER(^TMP("LEXFND",$JOB,I))
if I=""
QUIT
Begin DoDot:1
+32 FOR
SET IEN=$ORDER(^TMP("LEXFND",$JOB,I,IEN))
if IEN=""
QUIT
Begin DoDot:2
+33 NEW TXT,ELEMENT
SET TXT=^TMP("LEXFND",$JOB,I,IEN)
+34 SET ELEMENT=IEN_U_TXT
+35 SET ELEMENT=$$LEXXFRM(ELEMENT,ORDATE,APP)
+36 SET ILST=ILST+1
SET @LST@(ILST)=ELEMENT
+37 if ORINCSYN
DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(ELEMENT,U,6),ORDATE)
End DoDot:2
End DoDot:1
+38 IF '$DATA(@LST@(1))
SET @LST@(1)="No matches found"
+39 IF '$TEST
SET @LST@(ILST+1)=ILST_$SELECT(ILST=1:" match",1:" matches")_" found"
LEXX KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB),^TMP("LEXLE",$JOB)
+1 QUIT
LEXXFRM(ORX,ORDATE,ORAPP) ; Transform text for SCT look-up
+1 NEW ORLEX,ORY,ORICD,ORSCT,ORTXT,ORCODSYS,ORCCODE,ORDCODE
+2 SET ORLEX=$PIECE(ORX,U)
SET ORTXT=$PIECE(ORX,U,2)
SET (ORCCODE,ORCODSYS)=""
+3 IF ORTXT["*"
SET ORTXT=$$STRIP^XLFSTR(ORTXT,"*")
+4 IF (ORTXT["(")
IF (ORTXT[")")
Begin DoDot:1
+5 SET ORCODSYS=$REVERSE($PIECE($PIECE($REVERSE(ORTXT),"("),")",2))
+6 SET ORCCODE=$$ONE^LEXU(+ORLEX,ORDATE,"SCT")
SET ORCODSYS=$REVERSE($PIECE($REVERSE(ORCODSYS)," ",2,99))
+7 SET ORTXT=$$TRIM^XLFSTR($REVERSE($PIECE($REVERSE(ORTXT),"(",2,99)))
End DoDot:1
+8 SET ORY=$$SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE)
+9 QUIT ORY
SYNONYMS(LST,ILST,ORCSYS,ORCCODE,ORDT) ; Get synonyms for expression
+1 NEW ORSYN,ORI,ORDAD
SET ORDT=$GET(ORDT,DT)
SET ORDAD=ILST
+2 DO GETSYN^LEXTRAN1(ORCSYS,ORCCODE,ORDT,"ORSYN",1,1)
+3 SET ORI=0
FOR
SET ORI=$ORDER(ORSYN("S",ORI))
if +ORI'>0
QUIT
Begin DoDot:1
+4 NEW ELEMENT,TXT,IEN,ORDCODE
+5 SET IEN=$PIECE(ORSYN("S",ORI),U,2)
SET TXT=$PIECE(ORSYN("S",ORI),U)
SET ORDCODE=$PIECE(ORSYN("S",ORI),U,3)
+6 SET ELEMENT=$$SETELEM(IEN,TXT,"SNOMED CT",ORCCODE,ORDT,ORDCODE)_U_ORDAD
+7 SET ILST=ILST+1
SET @LST@(ILST)=ELEMENT
End DoDot:1
+8 QUIT
SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE,ORDCODE) ; Set List Element
+1 NEW ORY,ORIMPDT,ORICD,ORICDID,ORSYN,ORTYP,ORQT,ORNUM
+2 SET ORIMPDT=$$IMPDATE^LEXU("10D")
SET (ORTYP,ORQT,ORNUM)=""
+3 IF '$DATA(ORDCODE)
Begin DoDot:1
+4 SET ORDCODE=$$GETSYN^LEXTRAN1("SCT",ORCCODE,ORDATE,"ORSYN",1,1)
+5 IF $PIECE(ORDCODE,U)'=1
SET ORDCODE=""
QUIT
+6 FOR
SET ORTYP=$ORDER(ORSYN(ORTYP))
if ORTYP="S"!(ORQT)
QUIT
Begin DoDot:2
+7 IF $PIECE(ORSYN(ORTYP),U)=ORTXT
SET ORDCODE=$PIECE(ORSYN(ORTYP),U,3)
SET ORQT=1
QUIT
End DoDot:2
+8 IF ORTYP="S"
FOR
SET ORNUM=$ORDER(ORSYN(ORTYP,ORNUM))
if ORNUM=""!(ORQT)
QUIT
Begin DoDot:2
+9 IF $PIECE(ORSYN(ORTYP,ORNUM),U)=ORTXT
SET ORDCODE=$PIECE(ORSYN(ORTYP,ORNUM),U,3)
SET ORQT=1
QUIT
End DoDot:2
End DoDot:1
+10 IF ORDCODE["^"
SET ORDCODE=""
+11 SET ORICD=$$GETDX^ORQQPL1(ORCCODE,ORCODSYS,ORDATE)
+12 SET ORICDID=+$$ICDDATA^ICDXCODE("DIAG",$PIECE(ORICD,"/"),ORDATE,"E")
+13 SET ORY=ORLEX_U_ORTXT_U_ORICD_U_ORICDID_U_ORCODSYS_U_ORCCODE_U_ORDCODE
+14 IF (ORCODSYS["SNOMED")!(ORCODSYS["VHAT")
Begin DoDot:1
+15 SET ORY=ORY_U_$SELECT(ORDATE<ORIMPDT:"ICD-9-CM",1:"ICD-10-CM")
End DoDot:1
+16 QUIT ORY
