VIABPCE4.m

VIABPCE4 ;AITC/BWF - wrap calls to PCE and AICS ;2/12/16  15:13

 ;;1.0;VISTA INTEGRATION ADAPTER;**5**;06-FEB-2014;Build 8

 ;

 ; DBIA 2950   LOOK^LEXA          ^TMP("LEXFND",$J)

 ; DBIA 1609   CONFIG^LEXSET      ^TMP("LEXSCH",$J)

 ; DBIA 3991   $$STATCHK^ICDAPIU

 ;

 ; This is a clone of ORWPCE4.

 Q

LEX(LST,X,APP,VIADATE,VIAXTND,VIAINSYN) ; return list after lexicon lookup

 ; Call with: X           (Required) The search text entered by the user

 ;            APP         (Required) The Lexicon APP parameter (e.g., "GMPX"

 ;                                   for Problem List Subset, "10D" for ICD-10-CM, etc.

 ;            [VIADATE]    (Optional) the date of interest (Defaults to TODAY - should

 ;                                   be passed as DATE OF SERVICE if not TODAY)

 ;            [VIAXTND]    (Optional) Boolean flag specifying whether or not to

 ;                                   use an extended search (Initial search is PL Subset

 ;                                   of SCT, extended search is ICD (or 10D after impl.)

 ;                                   (Defaults to 0 (FALSE))

 ;            [VIAINSYN]  (Optional) Boolean flag specifying whether or not to

 ;                                   include synonyms for SNOMED CT Concepts

 ;                                   (Defaults to 0 (FALSE))

 ;

 ;   Returns: LST=local array name passed by ref, which contains search result set as:

 ;            <lvn>(1..n)=LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^DESIGID^PARENTSUBSCRIPT

 ;

 N LEX,ILST,I,IEN,IMPLDT,SUBSET,FILTER

 S FILTER=""

 S IMPLDT=$$IMPDATE^LEXU("10D")

 S:APP="CPT" APP="CHP" ; LEX PATCH 10

 I APP="ICD",'+$G(VIAXTND) S APP=$S($E(X,1,3)?.1A2.3N:"ICD",1:"GMPX")

 S:'+$G(VIADATE) VIADATE=DT

 S VIAINSYN=+$G(VIAINSYN)

 I APP="ICD",(VIADATE'<IMPLDT) S APP="10D"

 S SUBSET=$S(APP="GMPX":$S(VIADATE<IMPLDT:"PLS",1:"CLF"),1:APP)

 ; call CONFIG^LEXSET to set-up the constraints of the Lexicon search

 D CONFIG^LEXSET(APP,SUBSET,VIADATE)  ;DBIA 1609

 I APP="CHP" D

 . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")

 . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(VIADATE)))!($L($$CPCONE^LEXU(+Y,$G(VIADATE))))"  ;DBIA 1609

 . ; Set Applications Default Flag (Lexicon can not overwrite filter)

 . S ^TMP("LEXSCH",$J,"ADF",0)=1

 ; setup and/or search

 S X=$$UP^XLFSTR(X)

 ; execute the search

 D SRCH(.LST,X,APP,SUBSET,VIADATE,VIAINSYN)

LEXX K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J),^TMP("LEXLE",$J)

 Q

SRCH(LST,X,APP,SUBSET,VIADATE,VIAINSYN) ; call LOOK^LEXA to execute the search

 N LEX,I,IEN,ILST

 D LOOK^LEXA(X,APP,1,SUBSET,VIADATE)

 I '$D(LEX("LIST",1)) D  G LEXX

 . S LST(1)="-1^No matches found.^"_APP

 S ILST=0

 S LEX("LIST",1)=$$LEXXFRM(LEX("LIST",1),VIADATE,APP)

 I $S(APP="GMPX":1,APP="ICD":1,1:0),($P(LEX("LIST",1),U,6)'="799.9") D  I 1

 . I APP="ICD",($E($P(LEX("LIST",1),U,3),1,3)'="ICD") Q

 . S LST(1)=LEX("LIST",1),ILST=1

 E  S LST(1)=LEX("LIST",1),ILST=1

 I APP="GMPX",+$G(VIAINSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(1),U,4),VIADATE)

 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,VIADATE,APP) Q:$S(APP="GMPX":1,APP="ICD":1,1:0)&($P(ELEMENT,U,6)="799.9")

 ..I APP="ICD",($E($P(ELEMENT,U,3),1,3)'="ICD") Q

 ..S ILST=ILST+1,LST(ILST)=ELEMENT

 ..I APP="GMPX",+$G(VIAINSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(ILST),U,4),VIADATE)

 I '$D(LST(1)) S LST(1)="-1^No matches found.^"_APP

 Q

LEXXFRM(VIAX,VIADATE,VIAAPP) ; Transform text for SCT look-up

 N VIALEX,VIAY,VIAICD,VIASCT,VIATXT,VIACSYS,VIACCODE,VIADCODE

 S VIALEX=$P(VIAX,U),VIATXT=$P(VIAX,U,2),(VIACCODE,VIACSYS)=""

 I (VIATXT["("),(VIATXT[")") D

 . S VIACSYS=$RE($P($P($RE(VIATXT),"("),")",2))

 . S VIACCODE=$RE($P($RE(VIACSYS)," ")),VIACSYS=$RE($P($RE(VIACSYS)," ",2,99))

 . S VIATXT=$$TRIM^XLFSTR($RE($P($RE(VIATXT),"(",2,99)))

 S VIAY=$$SETELEM(VIALEX,VIATXT,VIACSYS,VIACCODE,VIADATE)

 Q VIAY

SYNONYMS(LST,ILST,VIACSYS,VIACCODE,VIADT) ; Get synonyms fVIA expression

 N VIASYN,VIAI,VIADAD S VIADT=$G(VIADT,DT),VIADAD=ILST

 D GETSYN^LEXTRAN1(VIACSYS,VIACCODE,VIADT,"VIASYN",1)

 S VIAI=0 F  S VIAI=$O(VIASYN("S",VIAI)) Q:+VIAI'>0  D

 . N ELEMENT,TXT,IEN,VIADCODE

 . S IEN=$P(VIASYN("S",VIAI),U,2),TXT=$P(VIASYN("S",VIAI),U)

 . S ELEMENT=$$SETELEM(IEN,TXT,"SNOMED CT",VIACCODE,VIADT)_U_VIADAD

 . S ILST=ILST+1,LST(ILST)=ELEMENT

 Q

SETELEM(VIALEX,VIATXT,VIACSYS,VIACCODE,VIADATE) ; Set List Element

 ;LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^ICDCODE^DESIGID^PARENTSUBSCRIPT

 N VIAY,VIADCODE,VIAIMPDT,VIAICD

 S VIAIMPDT=$$IMPDATE^LEXU("10D")

 S VIAY=VIALEX_U_VIATXT_U_VIACSYS_U_VIACCODE

 I $S(VIACSYS["SNOMED":1,VIACSYS["VHAT":1,1:0) D

 .S VIAY=VIAY_U_$S(VIADATE<VIAIMPDT:"ICD-9-CM",1:""),VIAICD=""

 .S:VIADATE<VIAIMPDT VIAICD=$$GETDX(VIACCODE,VIACSYS,VIADATE)

 .S VIADCODE=$$GETDES^LEXTRAN1("SCT",VIATXT,VIADATE)

 .S VIADCODE=$S(+VIADCODE=1:$P(VIADCODE,U,2),1:"")

 .S VIAY=VIAY_U_VIAICD_U_VIADCODE

 E  S VIAY=VIAY_U_U

 Q VIAY

GETDX(CODE,SYS,VIAIDT) ; Get ICD associated with SNOMED CT VIA VHAT Code

 N LEX,VIAI,VIAY,VIAUH,IMPLDT,VIASYSPR

 S VIAIDT=$G(VIAIDT,DT)

 S VIAY=0,IMPLDT=$$IMPDATE^LEXU("10D")

 S VIAUH=$S(VIAIDT<IMPLDT:"799.9",1:"R69.")

 S VIASYSPR=$S(VIAIDT<IMPLDT:1,1:30)

 I SYS["VHAT" D  I 1

 . I VIAIDT<IMPLDT S VIAY=$$GETASSN^LEXTRAN1(CODE,"VHAT2ICD") I 1

 . E  S VIAY=0

 E  D

 . I VIAIDT<IMPLDT S VIAY=$$GETASSN^LEXTRAN1(CODE,"SCT2ICD") I 1

 . E  S VIAY=0

 I $S(+VIAY'>0:1,+$P(VIAY,U,2)'>0:1,+LEX'>0:1,1:0) S VIAY=VIAUH G GETDXX

 S VIAI=0,VIAY=""

 F  S VIAI=$O(LEX(VIAI)) Q:+VIAI'>0  D

 . N ICD

 . S ICD=$O(LEX(VIAI,""))

 . S:'+$$STATCHK^ICDXCODE(VIASYSPR,ICD,VIAIDT) ICD=""

 . I ICD]"" S VIAY=$S(VIAY'="":VIAY_"/",1:"")_ICD

 I (VIAY]""),(VIAY'[".") S VIAY=VIAY_"."

GETDXX Q VIAY

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VIABPCE4   5936     printed  Apr 23, 2025@18:59:54                                                                                                                                                                                                    Page 2

VIABPCE4  ;AITC/BWF - wrap calls to PCE and AICS ;2/12/16  15:13

 +1       ;;1.0;VISTA INTEGRATION ADAPTER;**5**;06-FEB-2014;Build 8

 +2       ;

 +3       ; DBIA 2950   LOOK^LEXA          ^TMP("LEXFND",$J)

 +4       ; DBIA 1609   CONFIG^LEXSET      ^TMP("LEXSCH",$J)

 +5       ; DBIA 3991   $$STATCHK^ICDAPIU

 +6       ;

 +7       ; This is a clone of ORWPCE4.

 +8        QUIT 

LEX(LST,X,APP,VIADATE,VIAXTND,VIAINSYN) ; return list after lexicon lookup

 +1       ; Call with: X           (Required) The search text entered by the user

 +2       ;            APP         (Required) The Lexicon APP parameter (e.g., "GMPX"

 +3       ;                                   for Problem List Subset, "10D" for ICD-10-CM, etc.

 +4       ;            [VIADATE]    (Optional) the date of interest (Defaults to TODAY - should

 +5       ;                                   be passed as DATE OF SERVICE if not TODAY)

 +6       ;            [VIAXTND]    (Optional) Boolean flag specifying whether or not to

 +7       ;                                   use an extended search (Initial search is PL Subset

 +8       ;                                   of SCT, extended search is ICD (or 10D after impl.)

 +9       ;                                   (Defaults to 0 (FALSE))

 +10      ;            [VIAINSYN]  (Optional) Boolean flag specifying whether or not to

 +11      ;                                   include synonyms for SNOMED CT Concepts

 +12      ;                                   (Defaults to 0 (FALSE))

 +13      ;

 +14      ;   Returns: LST=local array name passed by ref, which contains search result set as:

 +15      ;            <lvn>(1..n)=LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^DESIGID^PARENTSUBSCRIPT

 +16      ;

 +17       NEW LEX,ILST,I,IEN,IMPLDT,SUBSET,FILTER

 +18       SET FILTER=""

 +19       SET IMPLDT=$$IMPDATE^LEXU("10D")

 +20      ; LEX PATCH 10

           if APP="CPT"

               SET APP="CHP"

 +21       IF APP="ICD"

               IF '+$GET(VIAXTND)

                   SET APP=$SELECT($EXTRACT(X,1,3)?.1A2.3N:"ICD",1:"GMPX")

 +22       if '+$GET(VIADATE)

               SET VIADATE=DT

 +23       SET VIAINSYN=+$GET(VIAINSYN)

 +24       IF APP="ICD"

               IF (VIADATE'<IMPLDT)

                   SET APP="10D"

 +25       SET SUBSET=$SELECT(APP="GMPX":$SELECT(VIADATE<IMPLDT:"PLS",1:"CLF"),1:APP)

 +26      ; call CONFIG^LEXSET to set-up the constraints of the Lexicon search

 +27      ;DBIA 1609

           DO CONFIG^LEXSET(APP,SUBSET,VIADATE)

 +28       IF APP="CHP"

               Begin DoDot:1

 +29      ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")

 +30      ;DBIA 1609

                   SET ^TMP("LEXSCH",$JOB,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(VIADATE)))!($L($$CPCONE^LEXU(+Y,$G(VIADATE))))"

 +31      ; Set Applications Default Flag (Lexicon can not overwrite filter)

 +32               SET ^TMP("LEXSCH",$JOB,"ADF",0)=1

               End DoDot:1

 +33      ; setup and/or search

 +34       SET X=$$UP^XLFSTR(X)

 +35      ; execute the search

 +36       DO SRCH(.LST,X,APP,SUBSET,VIADATE,VIAINSYN)

LEXX       KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB),^TMP("LEXLE",$JOB)

 +1        QUIT 

SRCH(LST,X,APP,SUBSET,VIADATE,VIAINSYN) ; call LOOK^LEXA to execute the search

 +1        NEW LEX,I,IEN,ILST

 +2        DO LOOK^LEXA(X,APP,1,SUBSET,VIADATE)

 +3        IF '$DATA(LEX("LIST",1))

               Begin DoDot:1

 +4                SET LST(1)="-1^No matches found.^"_APP

               End DoDot:1

               GOTO LEXX

 +5        SET ILST=0

 +6        SET LEX("LIST",1)=$$LEXXFRM(LEX("LIST",1),VIADATE,APP)

 +7        IF $SELECT(APP="GMPX":1,APP="ICD":1,1:0)

               IF ($PIECE(LEX("LIST",1),U,6)'="799.9")

                   Begin DoDot:1

 +8                    IF APP="ICD"

                           IF ($EXTRACT($PIECE(LEX("LIST",1),U,3),1,3)'="ICD")

                               QUIT 

 +9                    SET LST(1)=LEX("LIST",1)

                       SET ILST=1

                   End DoDot:1

                   IF 1

 +10      IF '$TEST

               SET LST(1)=LEX("LIST",1)

               SET ILST=1

 +11       IF APP="GMPX"

               IF +$GET(VIAINSYN)

                   DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(LST(1),U,4),VIADATE)

 +12       SET (I,IEN)=""

 +13      ;DBIA 2950

           FOR 

               SET I=$ORDER(^TMP("LEXFND",$JOB,I))

               if I=""

                   QUIT 

               Begin DoDot:1

 +14               FOR 

                       SET IEN=$ORDER(^TMP("LEXFND",$JOB,I,IEN))

                       if IEN=""

                           QUIT 

                       Begin DoDot:2

 +15                       NEW TXT,ELEMENT

                           SET TXT=^TMP("LEXFND",$JOB,I,IEN)

 +16                       SET ELEMENT=IEN_U_TXT

 +17                       SET ELEMENT=$$LEXXFRM(ELEMENT,VIADATE,APP)

                           if $SELECT(APP="GMPX"

                               QUIT 

 +18                       IF APP="ICD"

                               IF ($EXTRACT($PIECE(ELEMENT,U,3),1,3)'="ICD")

                                   QUIT 

 +19                       SET ILST=ILST+1

                           SET LST(ILST)=ELEMENT

 +20                       IF APP="GMPX"

                               IF +$GET(VIAINSYN)

                                   DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(LST(ILST),U,4),VIADATE)

                       End DoDot:2

               End DoDot:1

 +21       IF '$DATA(LST(1))

               SET LST(1)="-1^No matches found.^"_APP

 +22       QUIT 

LEXXFRM(VIAX,VIADATE,VIAAPP) ; Transform text for SCT look-up

 +1        NEW VIALEX,VIAY,VIAICD,VIASCT,VIATXT,VIACSYS,VIACCODE,VIADCODE

 +2        SET VIALEX=$PIECE(VIAX,U)

           SET VIATXT=$PIECE(VIAX,U,2)

           SET (VIACCODE,VIACSYS)=""

 +3        IF (VIATXT["(")

               IF (VIATXT[")")

                   Begin DoDot:1

 +4                    SET VIACSYS=$REVERSE($PIECE($PIECE($REVERSE(VIATXT),"("),")",2))

 +5                    SET VIACCODE=$REVERSE($PIECE($REVERSE(VIACSYS)," "))

                       SET VIACSYS=$REVERSE($PIECE($REVERSE(VIACSYS)," ",2,99))

 +6                    SET VIATXT=$$TRIM^XLFSTR($REVERSE($PIECE($REVERSE(VIATXT),"(",2,99)))

                   End DoDot:1

 +7        SET VIAY=$$SETELEM(VIALEX,VIATXT,VIACSYS,VIACCODE,VIADATE)

 +8        QUIT VIAY

SYNONYMS(LST,ILST,VIACSYS,VIACCODE,VIADT) ; Get synonyms fVIA expression

 +1        NEW VIASYN,VIAI,VIADAD

           SET VIADT=$GET(VIADT,DT)

           SET VIADAD=ILST

 +2        DO GETSYN^LEXTRAN1(VIACSYS,VIACCODE,VIADT,"VIASYN",1)

 +3        SET VIAI=0

           FOR 

               SET VIAI=$ORDER(VIASYN("S",VIAI))

               if +VIAI'>0

                   QUIT 

               Begin DoDot:1

 +4                NEW ELEMENT,TXT,IEN,VIADCODE

 +5                SET IEN=$PIECE(VIASYN("S",VIAI),U,2)

                   SET TXT=$PIECE(VIASYN("S",VIAI),U)

 +6                SET ELEMENT=$$SETELEM(IEN,TXT,"SNOMED CT",VIACCODE,VIADT)_U_VIADAD

 +7                SET ILST=ILST+1

                   SET LST(ILST)=ELEMENT

               End DoDot:1

 +8        QUIT 

SETELEM(VIALEX,VIATXT,VIACSYS,VIACCODE,VIADATE) ; Set List Element

 +1       ;LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^ICDCODE^DESIGID^PARENTSUBSCRIPT

 +2        NEW VIAY,VIADCODE,VIAIMPDT,VIAICD

 +3        SET VIAIMPDT=$$IMPDATE^LEXU("10D")

 +4        SET VIAY=VIALEX_U_VIATXT_U_VIACSYS_U_VIACCODE

 +5        IF $SELECT(VIACSYS["SNOMED":1,VIACSYS["VHAT":1,1:0)

               Begin DoDot:1

 +6                SET VIAY=VIAY_U_$SELECT(VIADATE<VIAIMPDT:"ICD-9-CM",1:"")

                   SET VIAICD=""

 +7                if VIADATE<VIAIMPDT

                       SET VIAICD=$$GETDX(VIACCODE,VIACSYS,VIADATE)

 +8                SET VIADCODE=$$GETDES^LEXTRAN1("SCT",VIATXT,VIADATE)

 +9                SET VIADCODE=$SELECT(+VIADCODE=1:$PIECE(VIADCODE,U,2),1:"")

 +10               SET VIAY=VIAY_U_VIAICD_U_VIADCODE

               End DoDot:1

 +11      IF '$TEST

               SET VIAY=VIAY_U_U

 +12       QUIT VIAY

GETDX(CODE,SYS,VIAIDT) ; Get ICD associated with SNOMED CT VIA VHAT Code

 +1        NEW LEX,VIAI,VIAY,VIAUH,IMPLDT,VIASYSPR

 +2        SET VIAIDT=$GET(VIAIDT,DT)

 +3        SET VIAY=0

           SET IMPLDT=$$IMPDATE^LEXU("10D")

 +4        SET VIAUH=$SELECT(VIAIDT<IMPLDT:"799.9",1:"R69.")

 +5        SET VIASYSPR=$SELECT(VIAIDT<IMPLDT:1,1:30)

 +6        IF SYS["VHAT"

               Begin DoDot:1

 +7                IF VIAIDT<IMPLDT

                       SET VIAY=$$GETASSN^LEXTRAN1(CODE,"VHAT2ICD")

                       IF 1

 +8               IF '$TEST

                       SET VIAY=0

               End DoDot:1

               IF 1

 +9       IF '$TEST

               Begin DoDot:1

 +10               IF VIAIDT<IMPLDT

                       SET VIAY=$$GETASSN^LEXTRAN1(CODE,"SCT2ICD")

                       IF 1

 +11              IF '$TEST

                       SET VIAY=0

               End DoDot:1

 +12       IF $SELECT(+VIAY'>0:1,+$PIECE(VIAY,U,2)'>0:1,+LEX'>0:1,1:0)

               SET VIAY=VIAUH

               GOTO GETDXX

 +13       SET VIAI=0

           SET VIAY=""

 +14       FOR 

               SET VIAI=$ORDER(LEX(VIAI))

               if +VIAI'>0

                   QUIT 

               Begin DoDot:1

 +15               NEW ICD

 +16               SET ICD=$ORDER(LEX(VIAI,""))

 +17               if '+$$STATCHK^ICDXCODE(VIASYSPR,ICD,VIAIDT)

                       SET ICD=""

 +18               IF ICD]""

                       SET VIAY=$SELECT(VIAY'="":VIAY_"/",1:"")_ICD

               End DoDot:1

 +19       IF (VIAY]"")

               IF (VIAY'[".")

                   SET VIAY=VIAY_"."

GETDXX     QUIT VIAY