Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWPCE4

ORWPCE4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; DBIA reference section
  1. ; 2950 LOOK^LEXA
  1. ; 1609 CONFIG^LEXSET
  1. ; 5006 $$GETSYN^LEXTRAN1
  1. ; 5679 $$IMPDATE^LEXU
  1. ; 5679 $$ONE^LEXU
  1. ; 10104 $$STRIP^XLFSTR
  1. ; 10104 $$TRIM^XLFSTR
  1. ; 10104 $$UP^XLFSTR
  1. ;
  1. Q
  1. 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
  1. ; APP (Required) The Lexicon APP parameter (e.g., "GMPX"
  1. ; for Problem List Subset, "10D" for ICD-10-CM, etc.
  1. ; [ORDATE] (Optional) the date of interest (Defaults to TODAY - should
  1. ; be passed as DATE OF SERVICE if not TODAY)
  1. ; [ORXTND] (Optional) Boolean flag specifying whether or not to
  1. ; use an extended search (Initial search is PL Subset
  1. ; of SCT, extended search is ICD (or 10D after impl.)
  1. ; (Defaults to 0 (FALSE))
  1. ; [ORINCSYN] (Optional) Boolean flag specifying whether or not to
  1. ; include synonyms for SNOMED CT Concepts
  1. ; (Defaults to 0 (FALSE))
  1. ;
  1. ; Returns: LST=local array name passed by ref, which contains search result set as:
  1. ; <lvn>(1..n)=LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^DESIGID^PARENTSUBSCRIPT
  1. ;
  1. N LEX,ILST,I,IEN,IMPLDT,SUBSET,FILTER,DIC
  1. S FILTER=""
  1. S IMPLDT=$$IMPDATE^LEXU("10D")
  1. S:APP="CPT" APP="CHP" ; LEX PATCH 10
  1. I APP="ICD",'+$G(ORXTND) S APP=$S($E(X,1,3)?.1A2.3N:"ICD",1:"GMPX")
  1. S:'+$G(ORDATE) ORDATE=DT
  1. S ORINCSYN=+$G(ORINCSYN)
  1. I APP="ICD",(ORDATE'<IMPLDT) S APP="10D"
  1. S SUBSET=$S(APP="GMPX":$S(ORDATE<IMPLDT:"PLS",1:"CLF"),1:APP)
  1. ; call CONFIG^LEXSET to set-up the constraints of the Lexicon search
  1. D CONFIG^LEXSET(APP,SUBSET,ORDATE) ;DBIA 1609
  1. I APP="CHP" D
  1. . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")
  1. . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;DBIA 1609
  1. . ; Set Applications Default Flag (Lexicon can not overwrite filter)
  1. . S ^TMP("LEXSCH",$J,"ADF",0)=1
  1. ; setup and/or search
  1. S X=$$UP^XLFSTR(X)
  1. ; execute the search
  1. D SRCH(.LST,X,APP,SUBSET,ORDATE,ORINCSYN)
  1. K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J),^TMP("LEXLE",$J)
  1. Q
  1. SRCH(LST,X,APP,SUBSET,ORDATE,ORINCSYN) ; call LOOK^LEXA to execute the search
  1. N LEX,I,IEN,ILST
  1. D LOOK^LEXA(X,APP,1,SUBSET,ORDATE)
  1. I '$D(LEX("LIST",1)) D Q
  1. . S LST(1)="-1^No matches found.^"_APP
  1. S ILST=0
  1. S LEX("LIST",1)=$$LEXXFRM(LEX("LIST",1),ORDATE,APP)
  1. I $S(APP="GMPX":1,APP="ICD":1,1:0),($P(LEX("LIST",1),U,6)'="799.9") D I 1
  1. . I APP="ICD",($E($P(LEX("LIST",1),U,3),1,3)'="ICD") Q
  1. . S LST(1)=LEX("LIST",1),ILST=1
  1. E S LST(1)=LEX("LIST",1),ILST=1
  1. I APP="GMPX",+$G(ORINCSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(1),U,4),ORDATE)
  1. S (I,IEN)=""
  1. F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950
  1. .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D
  1. ..N TXT,ELEMENT S TXT=^TMP("LEXFND",$J,I,IEN)
  1. ..S ELEMENT=IEN_U_TXT
  1. ..S ELEMENT=$$LEXXFRM(ELEMENT,ORDATE,APP) Q:$S(APP="GMPX":1,APP="ICD":1,1:0)&($P(ELEMENT,U,6)="799.9")
  1. ..I APP="ICD",($E($P(ELEMENT,U,3),1,3)'="ICD") Q
  1. ..I APP="SCT",$P(ELEMENT,U,4)="" Q
  1. ..S ILST=ILST+1,LST(ILST)=ELEMENT
  1. ..I APP="GMPX",+$G(ORINCSYN) D SYNONYMS(.LST,.ILST,"SCT",$P(LST(ILST),U,4),ORDATE)
  1. I '$D(LST(1)) S LST(1)="-1^No matches found.^"_APP
  1. Q
  1. LEXXFRM(ORX,ORDATE,ORAPP) ; Transform text for SCT look-up
  1. N ORLEX,ORY,ORICD,ORSCT,ORTXT,ORCODSYS,ORCCODE,ORDCODE
  1. S ORLEX=$P(ORX,U),ORTXT=$P(ORX,U,2),(ORCCODE,ORCODSYS)=""
  1. I ORTXT["*" S ORTXT=$$STRIP^XLFSTR(ORTXT,"*")
  1. I (ORTXT["("),(ORTXT[")") D I 1
  1. . S ORCODSYS=$RE($P($P($RE(ORTXT),"("),")",2))
  1. . S ORCCODE=$S(ORTXT["SNOMED":$$ONE^LEXU(+ORLEX,ORDATE,"SCT"),1:$RE($P($RE(ORCODSYS)," ")))
  1. . S ORCODSYS=$RE($P($RE(ORCODSYS)," ",2,99))
  1. . S ORTXT=$$TRIM^XLFSTR($RE($P($RE(ORTXT),"(",2,99)))
  1. E I ORAPP="SCT" D
  1. . S ORCODSYS="SNOMED CT",ORCCODE=$$ONE^LEXU(+ORLEX,ORDATE,"SCT")
  1. S ORY=$$SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE)
  1. Q ORY
  1. SYNONYMS(LST,ILST,ORCSYS,ORCCODE,ORDT) ; Get synonyms for expression
  1. N ORSYN,ORI,ORDAD S ORDT=$G(ORDT,DT),ORDAD=ILST
  1. D GETSYN^LEXTRAN1(ORCSYS,ORCCODE,ORDT,"ORSYN",1,1)
  1. S ORI=0 F S ORI=$O(ORSYN("S",ORI)) Q:+ORI'>0 D
  1. . N ELEMENT,TXT,IEN,ORDCODE
  1. . S IEN=$P(ORSYN("S",ORI),U,2),TXT=$P(ORSYN("S",ORI),U),ORDCODE=$P(ORSYN("S",ORI),U,3)
  1. . S ELEMENT=$$SETELEM(IEN,TXT,"SNOMED CT",ORCCODE,ORDT,ORDCODE)_U_ORDAD
  1. . S ILST=ILST+1,LST(ILST)=ELEMENT
  1. Q
  1. SETELEM(ORLEX,ORTXT,ORCODSYS,ORCCODE,ORDATE,ORDCODE) ; Set List Element
  1. ;LEXIEN^PREFTEXT^CODESYS^CONCEPTID^ICDVER^ICDCODE^DESIGID^PARENTSUBSCRIPT
  1. N ORY,ORIMPDT,ORICD,ORSYN,ORTYP,ORQT,ORNUM,ORFULLNAME
  1. S ORIMPDT=$$IMPDATE^LEXU("10D"),(ORTYP,ORQT,ORNUM)=""
  1. S ORY=ORLEX_U_ORTXT_U_ORCODSYS_U_ORCCODE
  1. I $S(ORCODSYS["SNOMED":1,ORCODSYS["VHAT":1,1:0) D I 1
  1. . S ORY=ORY_U_$S(ORDATE<ORIMPDT:"ICD-9-CM",1:"ICD-10-CM"),ORICD=""
  1. . S ORICD=$$GETDX^ORQQPL1(ORCCODE,ORCODSYS,ORDATE)
  1. . I '$D(ORDCODE) D
  1. . . S ORDCODE=$$GETSYN^LEXTRAN1("SCT",ORCCODE,ORDATE,"ORSYN",1,1)
  1. . . I $P(ORDCODE,U)'=1 S ORDCODE="" Q
  1. . . ;S ORFULLNAME=$P($G(ORSYN("F")),U)
  1. . . F S ORTYP=$O(ORSYN(ORTYP)) Q:ORTYP="S"!(ORQT) D
  1. . . . I $P(ORSYN(ORTYP),U)=ORTXT S ORDCODE=$P(ORSYN(ORTYP),U,3),ORQT=1 Q
  1. . . I ORTYP="S" F S ORNUM=$O(ORSYN(ORTYP,ORNUM)) Q:ORNUM=""!(ORQT) D
  1. . . . I $P(ORSYN(ORTYP,ORNUM),U)=ORTXT S ORDCODE=$P(ORSYN(ORTYP,ORNUM),U,3),ORQT=1 Q
  1. . I ORDCODE["^" S ORDCODE=""
  1. . ;S ORY=ORY_U_$G(ORICD)_U_$G(ORDCODE)_U_U_U_$G(ORFULLNAME)
  1. . S ORY=ORY_U_$G(ORICD)_U_$G(ORDCODE)
  1. E S ORY=ORY_U_U
  1. Q ORY
  1. STDCODES(LST,X,APP,ORDATE) ; Standard Codes search
  1. N CNT,NODE,I,J,ILST,N0,N1,ELEMENT
  1. S ILST=0,NODE="ORWPCE4" K ^TMP(NODE,$J)
  1. S CNT=$$TAX^LEX10CS(X,APP,ORDATE,NODE,1)
  1. I CNT'>0 S LST(1)="-1^No matches found.^"_APP Q
  1. S I=0 F S I=$O(^TMP(NODE,$J,I)) Q:I="" D
  1. . S J=0 F S J=$O(^TMP(NODE,$J,I,J)) Q:J="" D
  1. . . S N1=$G(^TMP(NODE,$J,I,J,1))
  1. . . S N0=$G(^TMP(NODE,$J,I,J,1,0))
  1. . . S ELEMENT=$$LEXXFRM($P(N1,U,3)_U_$P(N0,U,2),ORDATE,APP)
  1. . . I APP="SCT",($P(ELEMENT,U,3)'="SNOMED CT")!($P(ELEMENT,U,4)="") Q
  1. . . S ILST=ILST+1,LST(ILST)=ELEMENT
  1. I '$D(LST(1)) S LST(1)="-1^No matches found.^"_APP
  1. K ^TMP(NODE,$J)
  1. Q