Routine: ORQQPL4

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

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)

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

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  Mar 13, 2025@21:38:42                                                                                                                                                                                                     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

ORQQPL4.m