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

LA7QRY2.m

Go to the documentation of this file. 
  1. LA7QRY2 ;VA/DALOI/JMC - Lab HL7 Query Utility ; 13-Aug-2013 09:09 ; MKK
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,1918,69,1027,68,1033**;NOV 1, 1997
  1.  ;
  1.  ; Reference to ^AUPNPAT("D") global supported by DBIA #4814
  1.  ;
  1.  Q
  1.  ;
  1. PATID ; Resolve patient id and establish patient environment
  1.  ;
  1.  N LA7X
  1.  ;
  1.  S (DFN,LRDFN)="",LA7PTYP=0
  1.  S LA7PTID("TYPE")=$P(LA7PTID,"^",2),LA7PTID=$P(LA7PTID,"^")
  1.  ;
  1.  ; SSN passed as patient identifier
  1.  ; Identifier type will be checked in subsequent patch once subscribers
  1.  ; have updated their API call.
  1.  ; I LA7PTID("TYPE")="SS" D
  1.  I LA7PTID?9N.1A D
  1.  . S LA7PTYP=1
  1.  . S LA7X=$O(^DPT("SSN",LA7PTID,0))
  1.  . I LA7X>0 D SETDFN(LA7X)
  1.  ;
  1.  ; MPI/ICN (integration control number) passed as patient identifier
  1.  ; Identifier type will be checked in subsequent patch once subscribers have updated their API call.
  1.  ; I LA7PTID("TYPE")="PI" D
  1.  I LA7PTID?10N1"V"6N D
  1.  . S LA7PTYP=2
  1.  . S LA7X=$$GETDFN^MPIF001(LA7PTID)
  1.  . I LA7X<0 S LA7QERR(5)=$P(LA7X,"^",2) Q
  1.  . I LA7PTID'=$$GETICN^MPIF001(LA7X) S LA7QERR(1)="Invalid patient identifier passed" Q
  1.  . D SETDFN(LA7X)
  1.  ;
  1.  ; Use HRN (health record number) cross reference of file PATIENT/IHS (#9000001).
  1.  I LA7PTID("TYPE")="MR" D
  1.  . S LA7PTYP=3
  1.  . S LA7X=$O(^AUPNPAT("D",LA7PTID,0))
  1.  . D SETDFN(LA7X)
  1.  ;
  1.  ; If no patient identified/no laboratory record - return exception message
  1.  I 'LA7PTYP S LA7QERR(1)="Invalid patient identifier passed"
  1.  I 'DFN S LA7QERR(2)="No patient found with requested identifier"
  1.  I DFN,'LRDFN S LA7QERR(3)="No laboratory record for requested patient"
  1.  I LRDFN,'$D(^LR(LRDFN)) S LA7QERR(4)="Database error - missing laboratory record for requested patient"
  1.  Q
  1.  ;
  1.  ;
  1. BCD ; Search by specimen collection date.
  1.  ;
  1.  N LA763,LA7QUIT
  1.  ;
  1.  S (LA7SDT(0),LA7EDT(0))=0
  1.  I LA7SDT S LA7SDT(0)=9999999-LA7SDT
  1.  I LA7EDT S LA7EDT(0)=9999999-LA7EDT
  1.  ;
  1.  S LRSS=""
  1.  F  S LRSS=$O(LRSSLST(LRSS))  Q:LRSS=""  D
  1.  . S (LA7QUIT,LRIDT)=0
  1.  . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
  1.  . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
  1.  . . ; Quit if reached end of data or outside date criteria
  1.  . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
  1.  . . D SEARCH
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. BRAD ; Search by results available date (completion date).
  1.  ; Assumes cross-references still exist for dates in LRO(69) global.
  1.  ; Collects specimen date/time values for a given LRDFN and completion date.
  1.  ; Cross-reference is by date only, time stripped from start date.
  1.  ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
  1.  ;
  1.  N LA763,LA7DT,LA7ROOT,LA7SRC,LA7X,X
  1.  ;
  1.  ; Check if orders still exist in file #69 for search range.
  1.  ; If also searching any AP (SP,CY,EM,AU) subscripts then use long search as these do not always have orders in file #69.
  1.  S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
  1.  S X=$O(^LRO(69,LA7SDT(1)))
  1.  I X,X<LA7EDT(1) D
  1.  . S LA7SRC=1
  1.  . F I="AU","CY","EM","SP" I $D(LRSSLST(I)) S LA7SRC=2 Q
  1.  ;
  1.  ; Search "AN" cross-reference in file #69.
  1.  I LA7SRC D
  1.  . S LA7DT=LA7SDT(1)
  1.  . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
  1.  . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
  1.  . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
  1.  . . . I $QS(LA7ROOT,6)'=LRDFN Q
  1.  . . . S LRIDT=$QS(LA7ROOT,7),LRSS=""
  1.  . . . F  S LRSS=$O(LRSSLST(LRSS))  Q:LRSS=""  D SEARCH
  1.  ;
  1.  ; If no orders in #69 then do long search through file #63.
  1.  ; Or if searching AP subscripts.
  1.  ; If MI subscript then check each section of specimen for release date.
  1.  I 'LA7SRC!(LA7SRC=2) D
  1.  . S LRSS=""
  1.  . F  S LRSS=$O(LRSSLST(LRSS))  Q:LRSS=""  D
  1.  . . I LA7SRC=2,"AUCYEMSP"'[LRSS Q
  1.  . . S LRIDT=0
  1.  . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
  1.  . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
  1.  . . . I LRSS="MI" D SEARCH
  1.  . . . S LA7X=$S("SPCYEM"[LRSS:$P(LA763(0),"^",11),1:$P(LA763(0),"^",3))
  1.  . . . I LA7X>LA7SDT(1),LA7X<LA7EDT(1) D SEARCH
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1.  K LA763
  1.  S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
  1.  ; Skip if CH, SP, CY, or EM subscript and no complete date
  1.  I "CHSPCYEM"[LRSS,'$P(LA763(0),"^",3) Q
  1.  ; Skip if SP, CY, or EM subscript and no release date
  1.  I "SPCYEM"[LRSS,'$P(LA763(0),"^",11) Q
  1.  ;
  1.  ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
  1.  ; Quit if specific specimen codes and they do not match
  1.  I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
  1.  E  S LA761=0
  1.  I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
  1.  ;
  1.  ; --- Chemistry
  1.  I LRSS="CH" D CHSS Q
  1.  ; --- Microbiology
  1.  I LRSS="MI" D MISS Q
  1.  ; --- Surgical pathology
  1.  I LRSS="SP" D APSS Q
  1.  ; --- Cytology
  1.  I LRSS="CY" D APSS Q
  1.  ; --- Electron Microscopy
  1.  I LRSS="EM" D APSS Q
  1.  ; --- Autopsy
  1.  I LRSS="AU" D APSS Q
  1.  ; --- Blood Bank
  1.  I LRSS="BB" D BBSS Q
  1.  Q
  1.  ;
  1.  ;
  1. CHSS ; Search "CH" datanames for matching codes
  1.  ;
  1.  N LA7X,LRSB
  1.  ;
  1.  S LRSB=1
  1.  F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
  1.  . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
  1.  . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
  1.  . D CHECK
  1.  Q
  1.  ;
  1.  ;
  1. MISS ; Search "MI" subscripts for matching codes
  1.  ;
  1.  N LA7ND,LA7X,LRSB
  1.  ;
  1.  S LA7ND=0
  1.  F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
  1.  . S LA7X=$P(^LR(LRDFN,LRSS,LRIDT,LA7ND),"^")
  1.  . ; If no rpt date approved do not include
  1.  . I LA7X="" Q
  1.  . I $P(LA7SDT,"^",2)="RAD",((LA7X<LA7SDT(1))!(LA7X>LA7EDT(1))) Q
  1.  . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
  1.  . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
  1.  . D CHECK
  1.  Q
  1.  ;
  1.  ;
  1. APSS ; Search AP subscripts for matching codes
  1.  ; AP results are currently not coded - use defaults
  1.  ;
  1.  N LA7CODE,LRSB
  1.  ;
  1.  ; *** Autopsy subscript currently not supported ***
  1.  I LRSS="AU" Q
  1.  ;
  1.  S LRSB=.012
  1.  S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
  1.  D CHECK
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. BBSS ; Search BB subscript for matching codes
  1.  ; *** This subscript currently not supported ***
  1.  Q
  1.  ;
  1.  ;
  1. CHECK ; Check NLT order/result and LOINC codes.
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("CHECK^LA7QRY2 0.0")
  1.  ;
  1.  N LA7I,LA7QUIT,LA7X
  1.  ;
  1.  ; If wildcard then store
  1.  ; Otherwise check for specific NLT order/result and LOINC codes
  1.  ; If searching for suffix "0000" then check for other than "0000" coded result NLT code suffixes
  1.  I $P(LA7SCDE,"^")="*" D STORE Q
  1.  S LA7QUIT=0
  1.  F LA7I=1:1:3 D  Q:LA7QUIT
  1.  . ; If no test code then skip
  1.  . I $P(LA7CODE,"!",LA7I)="" Q
  1.  . ; If test code matches a search code then store
  1.  . I $D(^TMP($S(LA7I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",LA7I))) D  Q
  1.  . . D STORE
  1.  . . S LA7QUIT=1
  1.  . I LA7I=2,$P($P(LA7CODE,"!",LA7I),".",2)'="0000" D
  1.  . . S LA7X=$P($P(LA7CODE,"!",LA7I),".",1)_".0000"
  1.  . . I $D(^TMP("LA7-NLT",$J,LA7X)) D STORE S LA7QUIT=1 Q
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. STORE ; Store entry for building in HL7 message
  1.  ;
  1.  S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,$P(LA7CODE,"!"),LRSB)=""
  1.  Q
  1.  ;
  1.  ;
  1. SETDFN(LA7X) ; Setup DFN and other lab variables.
  1.  ;
  1.  S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
  1.  Q
  1.  ;
  1.  ;
  1. SCLIST(SCLST,LA7SLST) ; Setup subscript search list
  1.  ; Call with   SCLST = list of subscripts to search, "," delimited
  1.  ;           LA7SLST = array reference to return parsed subscript array
  1.  ;
  1.  ;   Returns LA7SLST =  parsed array of subscripts (passed by reference)
  1.  ;
  1.  N I,RC,SCALL,TMP
  1.  ;
  1.  ; Search all supported subscripts
  1.  I SCLST="*" F I="AU","BB","CH","CY","EM","MI","SP" S LA7SLST(I)=""
  1.  ;
  1.  ; Search only requested valid subscripts
  1.  I SCLST'="*" D
  1.  . S SCALL=",AU,BB,CH,CY,EM,MI,SP,",SCLST=$$UP^XLFSTR($TR(SCLST," "))
  1.  . F I=1:1:$L(SCLST,",") D  Q:$D(LA7QERR)
  1.  . . S TMP=$P(SCLST,",",I) Q:TMP=""
  1.  . . I SCALL[(","_TMP_",")  S LA7SLST(TMP)="" Q
  1.  . . S LA7QERR(7)="Invalid list of subscripts: '"_SCLST_"'"
  1.  Q