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 ---[H[J[2J[HVIABPCE4 5936 printed Apr 09, 2024@21:47:35 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
