ORWPCE4 ;SLC/JM/REV - wrap calls to PCE and AICS ;May 26, 2022@12:27:43
;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,361,350,423,465,405**;Dec 17, 1997;Build 211
;
; DBIA reference section
; 2950 LOOK^LEXA
; 1609 CONFIG^LEXSET
; 5006 $$GETSYN^LEXTRAN1
; 5679 $$IMPDATE^LEXU
; 5679 $$ONE^LEXU
; 10104 $$STRIP^XLFSTR
; 10104 $$TRIM^XLFSTR
; 10104 $$UP^XLFSTR
;
Q
LEX(LST,X,APP,ORDATE,ORXTND,ORINCSYN) ; return list after lexicon lookup IA#6441
; 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.
; [ORDATE] (Optional) the date of interest (Defaults to TODAY - should
; be passed as DATE OF SERVICE if not TODAY)
; [ORXTND] (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))
; [ORINCSYN] (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,DIC
S FILTER=""
S IMPLDT=$$IMPDATE^LEXU("10D")
S:APP="CPT" APP="CHP" ; LEX PATCH 10
I APP="ICD",'+$G(ORXTND) S APP=$S($E(X,1,3)?.1A2.3N:"ICD",1:"GMPX")
S:'+$G(ORDATE) ORDATE=DT
S ORINCSYN=+$G(ORINCSYN)
I APP="ICD",(ORDATE'<IMPLDT) S APP="10D"
S SUBSET=$S(APP="GMPX":$S(ORDATE<IMPLDT:"PLS",1:"CLF"),1:APP)
; call CONFIG^LEXSET to set-up the constraints of the Lexicon search
D CONFIG^LEXSET(APP,SUBSET,ORDATE) ;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(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;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,ORDATE,ORINCSYN)
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J),^TMP("LEXLE",$J)
Q
SRCH(LST,X,APP,SUBSET,ORDATE,ORINCSYN) ; call LOOK^LEXA to execute the search
N LEX,I,IEN,ILST
D LOOK^LEXA(X,APP,1,SUBSET,ORDATE)
I '$D(LEX("LIST",1)) D Q
. S LST(1)="-1^No matches found.^"_APP
S ILST=0
S LEX("LIST",1)=$$LEXXFRM(LEX("LIST",1),ORDATE,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(ORINCSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(1),U,4),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) 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
..I APP="SCT",$P(ELEMENT,U,4)="" Q
..S ILST=ILST+1,LST(ILST)=ELEMENT
..I APP="GMPX",+$G(ORINCSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(ILST),U,4),ORDATE)
I '$D(LST(1)) S LST(1)="-1^No matches found.^"_APP
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 I 1
. S ORCODSYS=$RE($P($P($RE(ORTXT),"("),")",2))
. S ORCCODE=$S(ORTXT["SNOMED":$$ONE^LEXU(+ORLEX,ORDATE,"SCT"),1:$RE($P($RE(ORCODSYS)," ")))
. S ORCODSYS=$RE($P($RE(ORCODSYS)," ",2,99))
. S ORTXT=$$TRIM^XLFSTR($RE($P($RE(ORTXT),"(",2,99)))
E I ORAPP="SCT" D
. S ORCODSYS="SNOMED CT",ORCCODE=$$ONE^LEXU(+ORLEX,ORDATE,"SCT")
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
;LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^ICDCODE^DESIGID^PARENTSUBSCRIPT
N ORY,ORIMPDT,ORICD,ORSYN,ORTYP,ORQT,ORNUM,ORFULLNAME
S ORIMPDT=$$IMPDATE^LEXU("10D"),(ORTYP,ORQT,ORNUM)=""
S ORY=ORLEX_U_ORTXT_U_ORCODSYS_U_ORCCODE
I $S(ORCODSYS["SNOMED":1,ORCODSYS["VHAT":1,1:0) D I 1
. S ORY=ORY_U_$S(ORDATE<ORIMPDT:"ICD-9-CM",1:"ICD-10-CM"),ORICD=""
. S ORICD=$$GETDX^ORQQPL1(ORCCODE,ORCODSYS,ORDATE)
. I '$D(ORDCODE) D
. . S ORDCODE=$$GETSYN^LEXTRAN1("SCT",ORCCODE,ORDATE,"ORSYN",1,1)
. . I $P(ORDCODE,U)'=1 S ORDCODE="" Q
. . ;S ORFULLNAME=$P($G(ORSYN("F")),U)
. . 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 ORY=ORY_U_$G(ORICD)_U_$G(ORDCODE)_U_U_U_$G(ORFULLNAME)
. S ORY=ORY_U_$G(ORICD)_U_$G(ORDCODE)
E S ORY=ORY_U_U
Q ORY
STDCODES(LST,X,APP,ORDATE) ; Standard Codes search
N CNT,NODE,I,J,ILST,N0,N1,ELEMENT
S ILST=0,NODE="ORWPCE4" K ^TMP(NODE,$J)
S CNT=$$TAX^LEX10CS(X,APP,ORDATE,NODE,1)
I CNT'>0 S LST(1)="-1^No matches found.^"_APP Q
S I=0 F S I=$O(^TMP(NODE,$J,I)) Q:I="" D
. S J=0 F S J=$O(^TMP(NODE,$J,I,J)) Q:J="" D
. . S N1=$G(^TMP(NODE,$J,I,J,1))
. . S N0=$G(^TMP(NODE,$J,I,J,1,0))
. . S ELEMENT=$$LEXXFRM($P(N1,U,3)_U_$P(N0,U,2),ORDATE,APP)
. . I APP="SCT",($P(ELEMENT,U,3)'="SNOMED CT")!($P(ELEMENT,U,4)="") Q
. . S ILST=ILST+1,LST(ILST)=ELEMENT
I '$D(LST(1)) S LST(1)="-1^No matches found.^"_APP
K ^TMP(NODE,$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWPCE4 6578 printed Sep 23, 2025@20:13:20 Page 2
ORWPCE4 ;SLC/JM/REV - wrap calls to PCE and AICS ;May 26, 2022@12:27:43
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,361,350,423,465,405**;Dec 17, 1997;Build 211
+2 ;
+3 ; DBIA reference section
+4 ; 2950 LOOK^LEXA
+5 ; 1609 CONFIG^LEXSET
+6 ; 5006 $$GETSYN^LEXTRAN1
+7 ; 5679 $$IMPDATE^LEXU
+8 ; 5679 $$ONE^LEXU
+9 ; 10104 $$STRIP^XLFSTR
+10 ; 10104 $$TRIM^XLFSTR
+11 ; 10104 $$UP^XLFSTR
+12 ;
+13 QUIT
LEX(LST,X,APP,ORDATE,ORXTND,ORINCSYN) ; return list after lexicon lookup IA#6441
+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 ; [ORDATE] (Optional) the date of interest (Defaults to TODAY - should
+5 ; be passed as DATE OF SERVICE if not TODAY)
+6 ; [ORXTND] (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 ; [ORINCSYN] (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,DIC
+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(ORXTND)
SET APP=$SELECT($EXTRACT(X,1,3)?.1A2.3N:"ICD",1:"GMPX")
+22 if '+$GET(ORDATE)
SET ORDATE=DT
+23 SET ORINCSYN=+$GET(ORINCSYN)
+24 IF APP="ICD"
IF (ORDATE'<IMPLDT)
SET APP="10D"
+25 SET SUBSET=$SELECT(APP="GMPX":$SELECT(ORDATE<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,ORDATE)
+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(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))"
+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,ORDATE,ORINCSYN)
+37 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB),^TMP("LEXLE",$JOB)
+38 QUIT
SRCH(LST,X,APP,SUBSET,ORDATE,ORINCSYN) ; call LOOK^LEXA to execute the search
+1 NEW LEX,I,IEN,ILST
+2 DO LOOK^LEXA(X,APP,1,SUBSET,ORDATE)
+3 IF '$DATA(LEX("LIST",1))
Begin DoDot:1
+4 SET LST(1)="-1^No matches found.^"_APP
End DoDot:1
QUIT
+5 SET ILST=0
+6 SET LEX("LIST",1)=$$LEXXFRM(LEX("LIST",1),ORDATE,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(ORINCSYN)
DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(LST(1),U,4),ORDATE)
+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,ORDATE,APP)
if $SELECT(APP="GMPX"
QUIT
+18 IF APP="ICD"
IF ($EXTRACT($PIECE(ELEMENT,U,3),1,3)'="ICD")
QUIT
+19 IF APP="SCT"
IF $PIECE(ELEMENT,U,4)=""
QUIT
+20 SET ILST=ILST+1
SET LST(ILST)=ELEMENT
+21 IF APP="GMPX"
IF +$GET(ORINCSYN)
DO SYNONYMS(.LST,.ILST,"SCT",$PIECE(LST(ILST),U,4),ORDATE)
End DoDot:2
End DoDot:1
+22 IF '$DATA(LST(1))
SET LST(1)="-1^No matches found.^"_APP
+23 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=$SELECT(ORTXT["SNOMED":$$ONE^LEXU(+ORLEX,ORDATE,"SCT"),1:$REVERSE($PIECE($REVERSE(ORCODSYS)," ")))
+7 SET ORCODSYS=$REVERSE($PIECE($REVERSE(ORCODSYS)," ",2,99))
+8 SET ORTXT=$$TRIM^XLFSTR($REVERSE($PIECE($REVERSE(ORTXT),"(",2,99)))
End DoDot:1
IF 1
+9 IF '$TEST
IF ORAPP="SCT"
Begin DoDot:1
+10 SET ORCODSYS="SNOMED CT"
SET ORCCODE=$$ONE^LEXU(+ORLEX,ORDATE,"SCT")
End DoDot:1
+11 SET ORY=$$SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE)
+12 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 ;LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^ICDCODE^DESIGID^PARENTSUBSCRIPT
+2 NEW ORY,ORIMPDT,ORICD,ORSYN,ORTYP,ORQT,ORNUM,ORFULLNAME
+3 SET ORIMPDT=$$IMPDATE^LEXU("10D")
SET (ORTYP,ORQT,ORNUM)=""
+4 SET ORY=ORLEX_U_ORTXT_U_ORCODSYS_U_ORCCODE
+5 IF $SELECT(ORCODSYS["SNOMED":1,ORCODSYS["VHAT":1,1:0)
Begin DoDot:1
+6 SET ORY=ORY_U_$SELECT(ORDATE<ORIMPDT:"ICD-9-CM",1:"ICD-10-CM")
SET ORICD=""
+7 SET ORICD=$$GETDX^ORQQPL1(ORCCODE,ORCODSYS,ORDATE)
+8 IF '$DATA(ORDCODE)
Begin DoDot:2
+9 SET ORDCODE=$$GETSYN^LEXTRAN1("SCT",ORCCODE,ORDATE,"ORSYN",1,1)
+10 IF $PIECE(ORDCODE,U)'=1
SET ORDCODE=""
QUIT
+11 ;S ORFULLNAME=$P($G(ORSYN("F")),U)
+12 FOR
SET ORTYP=$ORDER(ORSYN(ORTYP))
if ORTYP="S"!(ORQT)
QUIT
Begin DoDot:3
+13 IF $PIECE(ORSYN(ORTYP),U)=ORTXT
SET ORDCODE=$PIECE(ORSYN(ORTYP),U,3)
SET ORQT=1
QUIT
End DoDot:3
+14 IF ORTYP="S"
FOR
SET ORNUM=$ORDER(ORSYN(ORTYP,ORNUM))
if ORNUM=""!(ORQT)
QUIT
Begin DoDot:3
+15 IF $PIECE(ORSYN(ORTYP,ORNUM),U)=ORTXT
SET ORDCODE=$PIECE(ORSYN(ORTYP,ORNUM),U,3)
SET ORQT=1
QUIT
End DoDot:3
End DoDot:2
+16 IF ORDCODE["^"
SET ORDCODE=""
+17 ;S ORY=ORY_U_$G(ORICD)_U_$G(ORDCODE)_U_U_U_$G(ORFULLNAME)
+18 SET ORY=ORY_U_$GET(ORICD)_U_$GET(ORDCODE)
End DoDot:1
IF 1
+19 IF '$TEST
SET ORY=ORY_U_U
+20 QUIT ORY
STDCODES(LST,X,APP,ORDATE) ; Standard Codes search
+1 NEW CNT,NODE,I,J,ILST,N0,N1,ELEMENT
+2 SET ILST=0
SET NODE="ORWPCE4"
KILL ^TMP(NODE,$JOB)
+3 SET CNT=$$TAX^LEX10CS(X,APP,ORDATE,NODE,1)
+4 IF CNT'>0
SET LST(1)="-1^No matches found.^"_APP
QUIT
+5 SET I=0
FOR
SET I=$ORDER(^TMP(NODE,$JOB,I))
if I=""
QUIT
Begin DoDot:1
+6 SET J=0
FOR
SET J=$ORDER(^TMP(NODE,$JOB,I,J))
if J=""
QUIT
Begin DoDot:2
+7 SET N1=$GET(^TMP(NODE,$JOB,I,J,1))
+8 SET N0=$GET(^TMP(NODE,$JOB,I,J,1,0))
+9 SET ELEMENT=$$LEXXFRM($PIECE(N1,U,3)_U_$PIECE(N0,U,2),ORDATE,APP)
+10 IF APP="SCT"
IF ($PIECE(ELEMENT,U,3)'="SNOMED CT")!($PIECE(ELEMENT,U,4)="")
QUIT
+11 SET ILST=ILST+1
SET LST(ILST)=ELEMENT
End DoDot:2
End DoDot:1
+12 IF '$DATA(LST(1))
SET LST(1)="-1^No matches found.^"_APP
+13 KILL ^TMP(NODE,$JOB)
+14 QUIT
