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

HMPDLRA.m

Go to the documentation of this file. 
  1. HMPDLRA ;SLC/MKB,ASMR/RRB,BL - Laboratory extract by accession;Aug 29, 2016 20:06:27
  1.  ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; External References          DBIA#
  1.  ; -------------------          -----
  1.  ; ^DPT                         10035
  1.  ; ^LAB(61                        524
  1.  ; ^LRO(68                       1963
  1.  ; ^LRO(69                       2407
  1.  ; ^LR                            525
  1.  ; ^SC                          10040
  1.  ; ^VA(200                      10060
  1.  ; DIC                           2051
  1.  ; DIQ                           2056
  1.  ; LR7OR1,^TMP("LRRR",$J)        2503
  1.  ; LR7OSUM,^TMP("LRC",$J),       2766
  1.  ;  ^TMP("LRH",$J),^TMP("LRT",$J)
  1.  ; LR7OSAP4                      4989
  1.  ; ORX8                          2467
  1.  ; PXAPI                         1894
  1.  ; XUAF4                         2171
  1.  Q
  1.  ; ------------ Get results from VistA ------------
  1.  ;
  1. EN(DFN,BEG,END,MAX,ID) ; -- find patient's lab results
  1.  N HMPSUB,HMPIDT,HMPN,HMPITM,LRDFN,LR0,ORD,X
  1.  S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q  ;DE4496 19 August 2016
  1.  S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1.  S HMPSUB=$G(FILTER("type")),LRDFN=$$LRDFN^HMPXGLAB(DFN)  ;DE2818, (#63) LABORATORY REFERENCE
  1.  K ^TMP("LRRR",$J,DFN)
  1.  ;
  1.  ; get result(s)
  1.  I $L($G(ID)) D  ;reset search parameters
  1.  . S HMPSUB=$P(ID,";"),HMPIDT=+$P(ID,";",2)
  1.  . S:HMPIDT (BEG,END)=9999999-HMPIDT
  1.  ;
  1.  D RR^LR7OR1(DFN,,BEG,END,HMPSUB,,,MAX)
  1.  S HMPSUB="" F  S HMPSUB=$O(^TMP("LRRR",$J,DFN,HMPSUB)) Q:HMPSUB=""  D
  1.  . S HMPIDT=0 F  S HMPIDT=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT)) Q:HMPIDT<1  I $O(^(HMPIDT,0)) D
  1.  .. K HMPITM,ORD,CMMT,^TMP("HMPTEXT",$J)
  1.  .. I "CH^MI"'[HMPSUB D AP(.HMPITM),XML(.HMPITM) Q
  1.  .. S HMPITM("type")=HMPSUB,HMPITM("id")=HMPSUB_";"_HMPIDT
  1.  .. S HMPITM("collected")=9999999-HMPIDT,HMPITM("status")="completed"
  1.  .. S LR0=$G(^LR(LRDFN,HMPSUB,HMPIDT,0))
  1.  .. S HMPITM("resulted")=$P(LR0,U,3),X=+$P(LR0,U,5) I X D
  1.  ... N IENS,HMPY S IENS=X_","
  1.  ... D GETS^DIQ(61,IENS,".01;2;4.1",,"HMPY")
  1.  ... S HMPITM("specimen")=$G(HMPY(61,IENS,2))_U_$G(HMPY(61,IENS,.01)) ;SNOMED^name
  1.  ... S HMPITM("sample")=$G(HMPY(61,IENS,4.1)) ;name
  1.  .. S X=$P(LR0,U,6),HMPITM("name")=$$AREA(X),HMPITM("groupName")=X
  1.  .. S X=+$P(LR0,U,14) S:X HMPITM("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
  1.  .. I 'X S HMPITM("facility")=$$FAC^HMPD ;local stn#^name
  1.  .. I HMPSUB="MI" D  ;report
  1.  ... S HMPITM("document",1)=HMPSUB_";"_HMPIDT_"^LR MICROBIOLOGY REPORT^LABORATORY NOTE"
  1.  ... S:$G(HMPTEXT) HMPITM("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
  1.  .. S HMPN=0 F  S HMPN=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,HMPN)) Q:HMPN<1  D
  1.  ... S X=$S(HMPSUB="MI":$$MI,1:$$CH)
  1.  ... S:$L(X) HMPITM("value",HMPN)=X
  1.  ... S:$G(ORD) HMPITM("labOrderID")=ORD
  1.  .. I $D(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,"N")) M CMMT=^("N") S HMPITM("comment")=$$STRING^HMPD(.CMMT)
  1.  .. D XML(.HMPITM)
  1.  K ^TMP("LRRR",$J,DFN),^TMP("HMPTEXT",$J)
  1.  Q
  1.  ;
  1. CH() ; -- return a Chemistry result as:
  1.  ;   id^test^result^interpretation^units^low^high^localName^loinc^vuid^order
  1.  ;   Expects ^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN),LRDFN
  1.  N X,Y,X0,NODE,CMMT,LOINC
  1.  S X0=$G(^TMP("LRRR",$J,DFN,"CH",HMPIDT,HMPN)),NODE=$G(^LR(LRDFN,"CH",HMPIDT,HMPN))
  1.  S X=$$LABTSTNM^HMPXGLAB(+X0)  ; DE2818
  1.  S Y="CH;"_HMPIDT_";"_HMPN_U_X_U_$P(X0,U,2,4)
  1.  S X=$P(X0,U,5) I $L(X),X["-" S X=$TR(X,"- ","^"),$P(Y,U,6,7)=X
  1.  S $P(Y,U,8)=$P(X0,U,15) ;test short name
  1.  S X=$P($P(NODE,U,3),"!",3) S:X LOINC=$$GET1^DIQ(95.3,X_",",.01)
  1.  S:$G(LOINC) $P(Y,U,9,10)=LOINC_U_$$VUID^HMPD(+LOINC,95.3)
  1.  S ORD=+$P(X0,U,17),X=$$ORDER(ORD,+X0) S:X $P(Y,U,11)=X
  1.  Q Y
  1.  ;
  1. MI() ; -- return a Microbiology result as:
  1.  ;   id^test^result^interpretation^units
  1.  ;   Expects ^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)
  1.  N Y,X0
  1.  S X0=$G(^TMP("LRRR",$J,DFN,"MI",HMPIDT,HMPN)),Y=""
  1.  S:$L($P(X0,U))>1 Y="MI;"_HMPIDT_";"_HMPN_U_$P(X0,U,1,4)
  1.  S ORD=+$P(X0,U,17)
  1.  Q Y
  1.  ;
  1. AP(LAB) ; -- return a Pathology result in LAB("attribute")=value
  1.  N LR0,X,I,NODE
  1.  S LR0=$G(^LR(LRDFN,HMPSUB,HMPIDT,0))
  1.  S LAB("type")=HMPSUB,LAB("id")=HMPSUB_";"_HMPIDT
  1.  S LAB("collected")=9999999-HMPIDT,LAB("status")="completed"
  1.  S LAB("resulted")=$P(LR0,U,11),LAB("groupName")=$P(LR0,U,6)
  1.  S X="",I=0 F  S I=$O(^LR(LRDFN,HMPSUB,HMPIDT,.1,I)) Q:I<1  S X=X_$S($L(X):", ",1:"")_$P($G(^(I,0)),U)
  1.  S:$L(X) LAB("specimen")=U_X
  1.  S LAB("facility")=$$FAC^HMPD
  1.  S NODE=$S(HMPSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,HMPSUB,HMPIDT,.05)))
  1.  S I=0 F  S I=$O(@NODE@(I)) Q:I<1  S X=+$P($G(@NODE@(I,0)),U,2) I X D
  1.  . N LT,NT,HMPY
  1.  . S LT=$$GET1^DIQ(8925,+X_",",.01) Q:$P(LT," ")="Addendum"
  1.  . S NT=$$GET1^DIQ(8925,+X_",",".01:1501") S:NT="" NT="LABORATORY NOTE"
  1.  . S LAB("document",I)=+X_U_LT_U_NT
  1.  . S:$G(HMPTEXT) LAB("document",I,"content")=$$TEXT^HMPDTIU(+X)
  1.  I '$O(LAB("document",0)) D  ;non-TIU reports
  1.  . S LAB("document",1)=HMPSUB_";"_HMPIDT_"^LR "_$$NAME(HMPSUB)_" REPORT^LABORATORY NOTE"
  1.  . S:$G(HMPTEXT) LAB("document",1,"content")=$$TEXT(DFN,HMPSUB,HMPIDT)
  1.  Q
  1.  ;
  1. ORDER(LABORD,TEST) ; -- return #100 order^name for Lab order# & Test
  1.  N Y,D,S,T
  1.  S D=$P(9999999-HMPIDT,"."),Y=""
  1.  S S=0 F  S S=$O(^LRO(69,"C",LABORD,D,S)) Q:S<1  D  Q:Y
  1.  . S T=0 F  S T=$O(^LRO(69,D,1,S,2,T)) Q:T<1  I 'TEST!(+$G(^(T,0))=TEST) S Y=+$P(^(0),U,7)
  1.  ;I Y S Y=Y_U_$P($$OI^ORX8(Y),U,2)
  1.  Q Y
  1.  ;
  1. NAME(X) ; -- Return name of subscript X
  1.  I X="AU" Q "AUTOPSY"
  1.  I X="BB" Q "BLOOD BANK"
  1.  I X="CH" Q "CHEM,HEM,TOX,RIA,SER,etc."
  1.  I X="CY" Q "CYTOPATHOLOGY"
  1.  I X="EM" Q "ELECTRON MICROSCOPY"
  1.  I X="MI" Q "MICROBIOLOGY"
  1.  I X="SP" Q "SURGICAL PATHOLOGY"
  1.  Q "ANATOMIC PATHOLOGY"
  1.  ;
  1. AREA(ACCNUM) ; -- Return name of accession area
  1.  N X,Y,HMPA
  1.  S X=$P($G(ACCNUM)," "),Y=""
  1.  I $L(X) D FIND^DIC(68,,.01,"QX",X,,,,,"HMPA")
  1.  S Y=$G(HMPA("DILIST",1,1))
  1.  Q Y
  1.  ;
  1.  ; ------------ Get report(s) [via HMPDTIU] ------------
  1.  ;
  1. RPTS(DFN,BEG,END,MAX) ; -- find patient's lab reports
  1.  N HMPSUB,HMPIDT,HMPITM,HMPTIU,HMPXID,LRDFN,HMPN,DA
  1.  S DFN=+$G(DFN) Q:$G(DFN)<1
  1.  S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1.  S LRDFN=$$LRDFN^HMPXGLAB(DFN)  ;DE2818, (#63) LABORATORY REFERENCE
  1.  K ^TMP("LRRR",$J,DFN) D RR^LR7OR1(DFN,,BEG,END,"AP",,,MAX)
  1.  S HMPSUB="" F  S HMPSUB=$O(^TMP("LRRR",$J,DFN,HMPSUB)) Q:HMPSUB=""  D
  1.  . S HMPIDT=0 F  S HMPIDT=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT)) Q:HMPIDT<1  I $O(^(HMPIDT,0)) D
  1.  .. S HMPTIU=$S(HMPSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,HMPSUB,HMPIDT,.05)))
  1.  .. K HMPITM S HMPXID=HMPSUB_";"_HMPIDT
  1.  .. I '$O(@HMPTIU@(0)) D RPT1(DFN,HMPXID,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM) Q
  1.  .. S HMPN=0 F  S HMPN=$O(@HMPTIU@(HMPN)) Q:HMPN<1  D
  1.  ... S DA=+$P($G(@HMPTIU@(HMPN,0)),U,2) Q:DA<1  K HMPITM
  1.  ... D EN1^HMPDTIU(DA,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
  1.  K ^TMP("LRRR",$J,DFN),^TMP("HMPTEXT",$J)
  1.  Q
  1.  ;
  1. RPT1(DFN,ID,RPT) ; -- return report as a TIU document
  1.  S DFN=+$G(DFN),ID=$G(ID) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q  ;DE4496 19 August 2016
  1.  Q:'$L(ID)
  1.  N SUB,IDT,LRDFN,LR0,X,LOC
  1.  K RPT,^TMP("HMPTEXT",$J)
  1.  S SUB=$P(ID,";"),IDT=+$P(ID,";",2),LRDFN=$$LRDFN^HMPXGLAB(DFN)  ;DE2818, (#63) LABORATORY REFERENCE
  1.  S LR0=$S(SUB="AU":$G(^LR(LRDFN,"AU")),1:$G(^LR(LRDFN,SUB,IDT,0)))
  1.  S RPT("id")=ID,RPT("referenceDateTime")=9999999-IDT
  1.  S RPT("localTitle")="LR "_$$NAME(SUB)_" REPORT"
  1.  S RPT("documentClass")="LR LABORATORY REPORTS"
  1.  S RPT("nationalTitle")="4697105^LABORATORY NOTE"
  1.  S RPT("nationalTitleSubject")="4697104^LABORATORY"
  1.  S RPT("nationalTitleType")="4696120^NOTE"
  1.  S RPT("type")="LR",RPT("status")="COMPLETED"
  1.  S:$G(FILTER("loinc")) RPT("loinc")=$P(FILTER("loinc"),U)
  1.  S X=$P(LR0,U,$S(SUB="AU":5,1:8)),LOC="" S:$L(X) LOC=+$O(^SC("B",X,0))  ;DE2818, ***fix needed to get location IEN***
  1.  S RPT("facility")=$$FAC^HMPD(LOC)
  1.  I LOC D  ;look-up visit
  1.  . N CDT S CDT=9999999-IDT
  1.  . S X=$$GETENC^PXAPI(DFN,CDT,LOC)
  1.  . S:X RPT("encounter")=+X
  1.  S X=+$P(LR0,U,$S(SUB="AU":10,1:2)) ;pathologist
  1.  S:X RPT("clinician",1)=X_U_$$GET1^DIQ(200,X_",",.01)_"^A"  ;DE2818, changed global read to FileMan
  1.  S X=$S(SUB="AU":$P(LR0,U,15,16),1:$P(LR0,U,11)_U_$P(LR0,U,13)) I X D
  1.  . N Y S Y=$P(X,U,2)
  1.  . ;DE2818, changed global read to FileMan - (#.01) NAME and (#1) INITIAL
  1.  . S RPT("clinician",2)=Y_U_$$GET1^DIQ(200,+Y_",",.01)_"^S^"_+X_U_$$GET1^DIQ(200,+Y_",",1)
  1.  S:$G(HMPTEXT) RPT("content")=$$TEXT(DFN,SUB,IDT)
  1.  Q
  1.  ;
  1. TEXT(DFN,SUB,IDT,LRDFN) ; -- Get report text, return temp array name
  1.  N DATE,NAME,HMPS,HMPY,I,X,Y
  1.  K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
  1.  S DATE=9999999-$G(IDT),NAME=$$NAME(SUB),HMPS(NAME)=""
  1.  ;The ^LR7OSUM API is not returning correct data for all entries. The ^LR7OSAP4 API (which is what CPRS uses)
  1.  ;does return correct entries where ^LR7OSUM fails, but it only returns data for lab result subscripts
  1.  ;"EM", "SP", and "CY". Therefore, if we can, call the ^LR7OSAP4 API for data, and fall back to ^LR7OSUM
  1.  ;otherwise.
  1.  S SUB=$G(SUB) D  ; Make sure SUB is defined
  1.  . ;If LRDFN and SUB is correct, call new API
  1.  . I $G(LRDFN),SUB="EM"!(SUB="SP")!(SUB="CY") D EN^LR7OSAP4($NA(^TMP("LRC",$J)),LRDFN,SUB,IDT) Q
  1.  . ;Otherwise, call old API
  1.  . D EN^LR7OSUM(.HMPY,DFN,DATE,DATE,,,.HMPS)
  1.  S Y=$NA(^TMP("HMPTEXT",$J,SUB_";"_IDT)) K @Y
  1.  S I=+$G(^TMP("LRH",$J,NAME)) ;LRH=header
  1.  F  S I=$O(^TMP("LRC",$J,I)) Q:I<1  S X=$G(^(I,0)) Q:X?1."="  S @Y@(I)=X
  1.  K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
  1.  Q Y
  1.  ;
  1.  ; ------------ Return data to middle tier ------------
  1.  ;
  1. XML(LAB) ; -- Return result as XML in @HMP@(#)
  1.  N ATT,X,Y,NAMES,I,J
  1.  D ADD("<accession>") S HMPTOTL=$G(HMPTOTL)+1
  1.  S ATT="" F  S ATT=$O(LAB(ATT)) Q:ATT=""  D  D:$L(Y) ADD(Y)
  1.  . I $O(LAB(ATT,0)) D  S Y="" Q
  1.  .. D ADD("<"_ATT_"s>")
  1.  .. S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^Z",ATT="value":"id^test^result^interpretation^units^low^high^localName^loinc^vuid^order^Z",1:"code^name^Z")
  1.  .. S I=0 F  S I=$O(LAB(ATT,I)) Q:I<1  D
  1.  ... S X=$G(LAB(ATT,I))
  1.  ... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
  1.  ... S X=$G(LAB(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q
  1.  ... S Y=Y_">" D ADD(Y)
  1.  ... S Y="<content xml:space='preserve'>" D ADD(Y)
  1.  ... S J=0 F  S J=$O(@X@(J)) Q:J<1  S Y=$$ESC^HMPD(@X@(J)) D ADD(Y)
  1.  ... D ADD("</content>"),ADD("</"_ATT_">")
  1.  .. D ADD("</"_ATT_"s>")
  1.  . S X=$G(LAB(ATT)),Y="" Q:'$L(X)
  1.  . I ATT="comment" S Y="<"_ATT_" xml:space='preserve'>"_$$ESC^HMPD(X)_"</"_ATT_">" Q
  1.  . I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
  1.  . I $L(X)>1 D  S Y=""
  1.  .. S NAMES="code^name^Z"
  1.  .. S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
  1.  D ADD("</accession>")
  1.  Q
  1.  ;
  1. LOOP() ; -- build sub-items string from NAMES and X
  1.  N STR,P,TAG S STR=""
  1.  F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z"  I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^HMPD($P(X,U,P))_"' "
  1.  Q STR
  1.  ;
  1. ADD(X) ; -- Add a line @HMP@(n)=X
  1.  S HMPI=$G(HMPI)+1
  1.  S @HMP@(HMPI)=X
  1.  Q