Index: ccr/trunk/labRPMS/C0CLA7Q.m
===================================================================
--- ccr/trunk/labRPMS/C0CLA7Q.m	(revision 445)
+++ ccr/trunk/labRPMS/C0CLA7Q.m	(revision 445)
@@ -0,0 +1,166 @@
+C0CLA7Q	;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 21, 2009
+	;;n.n;;****;
+	;
+	;
+	Q
+	;
+	;
+LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7)	; Entry point for Lab Result Query
+	;
+	;
+	K ^TMP("C0C-VLAB",$J)
+	;
+	; Check and retrieve lab results from LAB DATA file (#63)
+	S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
+	;
+	; If V LAB file present then check for lab results that are only in this file
+	; If results found in V Lab file then build results and add to above results.
+	I $D(^AUPNVLAB) D
+	. D VCHECK
+	. I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
+	;
+	;K ^TMP("C0C-VLAB",$J)
+	;
+	Q C0CDEST
+	;
+	;
+VCHECK	; If V LAB file present then check for lab results that are only in this file.
+	;
+	N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
+	;
+	S LA7PTID=C0CPTID
+	D PATID^LA7QRY2
+	I $D(LA7ERR) Q
+	;
+	; Resolve search codes to lab datanames
+	S LA7SC=$G(C0CSC)
+	I $T(SCLIST^LA7QRY2)'="" D
+	. N TMP
+	. S LA7SCSRC=$G(C0CSC)
+	. S TMP=$$SCLIST^LA7QRY2(LA7SCSRC)
+	. S LA7SC=TMP
+	;
+	I LA7SC'="*" D CHKSC^LA7QRY1
+	;
+	; Convert specimen codes to file #61 Topography entries
+	S LA7SPEC=$G(C0CSPEC)
+	I LA7SPEC'="*"  D SPEC^LA7QRY1
+	;
+	S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
+	;
+	F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
+	. I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
+	. I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
+	. S C0CDA=$QS(C0CROOT,4)
+	. I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
+	. D VCHK1
+	;
+	;
+	Q
+	;
+	;
+VBUILD	; Build results found only in V LAB file into HL7 structure.
+	;
+	;
+	Q
+	;
+	;
+LNCHK	; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
+	; Call from LA7QRY2
+	;
+	N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
+	;
+	S DFN=$P(^LR(LRDFN,0),"^",3)
+	S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
+	S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
+	S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
+	;
+	; ^AUPNVLAB("ALR1",5380,3080307.211055,"EKT 0307 48",188,5427202)=""
+	;
+	S C0C60=""
+	F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
+	. D FINDDT
+	. I C0CDA<1 Q
+	. S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
+	. S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
+	. I C0CPDA="" S C0CPDA=C0CDA
+	. S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
+	. I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
+	. S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
+	. I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
+	. S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
+	. I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
+	. S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
+	;
+	S X=$P(LA7X,"^",3)
+	; If order NLT then update if no order NLT
+	I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
+	;
+	; If result NLT then update if no result NLT
+	I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
+	;
+	; If LOINC found then update variable with LN code
+	I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
+	;
+	S $P(LA7X,"^",3)=X
+	;
+	Q
+	;
+	;
+TMPCHK	; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
+	; Called from LA7VOBX1
+	;
+	N I,X
+	;
+	S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
+	I X="" Q
+	F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
+	S $P(LA7VAL,"^",3)=LA7X
+	;
+	Q
+	;
+	;
+VCHK1	; Check the entry in V Lab to determine if it meets criteria
+	;
+	N C0CVLAB,I
+	;
+	F I=0,12 S C0CVLAB(I)=^AUPNVLAB(C0CDA,I)
+	;
+	; JMC 04/13/09 - Store anything for now that meets date criteria.
+	D VSTORE
+	;
+	Q
+	;
+	;
+VSTORE	; Store entry for building in HL7 message when parent is from V LAB file.
+	;
+	N C0CPDA,C0CPTEST
+	;
+	; Determine parent test to use for OBR segment
+	S C0CPDA=$P(C0CVLAB(12),"^",8)
+	I C0CPDA="" S C0CPDA=C0CDA
+	;
+	; Determine parent test
+	S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
+	;
+	S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
+	;
+	Q
+	;
+	;
+FINDDT	; Find entry in V LAB for the date/time or one close to it.
+	; RPMS stores related specimen entries under the same date/time.
+	; Lab file #63 creates unique entries with slightly different times.
+	;
+	S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
+	I C0CDA>0 Q
+	;
+	; If entry found then confirm that specimen type matches.
+	N C0CDTY
+	S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
+	I C0CDTY D
+	. I $P(C0CDT,".")'=$P(C0CDTY,".") Q
+	. S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
+	. I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
+	;
+	Q
Index: ccr/trunk/labRPMS/LA7QRY2.m
===================================================================
--- ccr/trunk/labRPMS/LA7QRY2.m	(revision 445)
+++ ccr/trunk/labRPMS/LA7QRY2.m	(revision 445)
@@ -0,0 +1,184 @@
+LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
+ ; JMC - mods to check for IHS V LAB file
+ ;
+ Q
+ ;
+PATID ; Resolve patient id and establish patient environment
+ ;
+ N LA7X
+ ;
+ S (DFN,LRDFN)="",LA7PTYP=0
+ ;
+ ; SSN passed as patient identifier
+ I LA7PTID?9N.1A D
+ . S LA7PTYP=1
+ . S LA7X=$O(^DPT("SSN",LA7PTID,0))
+ . I LA7X>0 D SETDFN(LA7X)
+ ;
+ ; MPI/ICN (integration control number) passed as patient identifier
+ I LA7PTID?10N1"V"6N D
+ . S LA7PTYP=2
+ . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
+ . I LA7X>0 D SETDFN(LA7X)
+ ;
+ ; If no patient identified/no laboratory record - return exception message
+ I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
+ I 'DFN S LA7ERR(2)="No patient found with requested identifier"
+ I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
+ I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
+ Q
+ ;
+ ;
+BCD ; Search by specimen collection date.
+ ;
+ N LA763,LA7QUIT
+ ;
+ S (LA7SDT(0),LA7EDT(0))=0
+ I LA7SDT S LA7SDT(0)=9999999-LA7SDT
+ I LA7EDT S LA7EDT(0)=9999999-LA7EDT
+ ;
+ F LRSS="CH","MI","SP" D
+ . S (LA7QUIT,LRIDT)=0
+ . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
+ . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
+ . . ; Quit if reached end of data or outside date criteria
+ . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
+ . . D SEARCH
+ ;
+ Q
+ ;
+ ;
+BRAD ; Search by results available date (completion date).
+ ; Assumes cross-references still exist for dates in LRO(69) global.
+ ; Collects specimen date/time values for a given LRDFN and completion date.
+ ; Cross-reference is by date only, time stripped from start date.
+ ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
+ ;
+ N LA763,LA7DT,LA7ROOT,LA7SRC,X
+ ;
+ ; Check if orders still exist Iin file #69 for search range
+ S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
+ S X=$O(^LRO(69,LA7SDT(1)))
+ I X,X<LA7EDT(1) S LA7SRC=1
+ ;
+ ; Search "AN" cross-reference in file #69.
+ I LA7SRC D
+ . S LA7DT=LA7SDT(1)
+ . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
+ . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
+ . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
+ . . . I $QS(LA7ROOT,6)'=LRDFN Q
+ . . . S LRIDT=$QS(LA7ROOT,7)
+ . . . F LRSS="CH","MI","SP" D SEARCH
+ ;
+ ; If no orders in #69 then do long search through file #63.
+ I 'LA7SRC D
+ . F LRSS="CH","MI","SP" D
+ . . S LRIDT=0
+ . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
+ . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
+ ;
+ Q
+ ;
+ ;
+SEARCH ; Search subscript for a specific collection date/time
+ ;
+ K LA763
+ S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ ;
+ ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
+ ; Quit if specific specimen codes and they do not match
+ I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
+ E  S LA761=0
+ I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
+ ;
+ ; --- Chemistry
+ I LRSS="CH" D CHSS Q
+ ; --- Microbiology
+ I LRSS="MI" D MISS Q
+ ; --- Surgical pathology
+ I LRSS="SP" D APSS Q
+ ; --- Cytology
+ I LRSS="CY" D APSS Q
+ ; --- Electron Micrscopsy
+ I LRSS="EM" D APSS Q
+ ; --- Autopsy
+ I LRSS="AU" D APSS Q
+ ; --- Blood Bank
+ I LRSS="BB" D BBSS Q
+ Q
+ ;
+ ;
+CHSS ; Search "CH" datanames for matching codes
+ ;
+ N LA7X,LRSB
+ ;
+ S LRSB=1
+ F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
+ . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
+ . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
+ . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
+ . D CHECK
+ ;
+ Q
+ ;
+ ;
+MISS ; Search "MI" subscripts for matching codes
+ ;
+ N LA7ND,LRSB
+ ;
+ S LA7ND=0
+ F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
+ . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
+ . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
+ . D CHECK
+ Q
+ ;
+ ;
+APSS ; Search AP subscripts for matching codes
+ ; AP results are currently not coded - use defaults
+ ;
+ N LA7CODE,LRSB
+ ;
+ S LRSB=.012
+ S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
+ D CHECK
+ ;
+ Q
+ ;
+ ;
+BBSS ; Search BB subscript for matching codes
+ ; *** This subscript currently not supported ***
+ Q
+ ;
+ ;
+CHECK ; Check NLT order/result and LOINC codes.
+ ;
+ N LA7QUIT
+ ;
+ ; If wildcard then store
+ ; Otherwise check for specific NLT order/result and LOINC codes
+ I LA7SC="*" D STORE Q
+ S LA7QUIT=0
+ F I=1:1:3 D  Q:LA7QUIT
+ . ; If no test code then skip
+ . I '$L($P(LA7CODE,"!",I)) Q
+ . ; If test code does not match a search code then quit
+ . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
+ . D STORE S LA7QUIT=1
+ ;
+ Q
+ ;
+ ;
+STORE ; Store entry for building in HL7 message
+ ;
+ S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
+ Q
+ ;
+ ;
+SETDFN(LA7X) ; Setup DFN and other lab variables.
+ ;
+ S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
+ Q
Index: ccr/trunk/labRPMS/LA7VOBX1.m
===================================================================
--- ccr/trunk/labRPMS/LA7VOBX1.m	(revision 445)
+++ ccr/trunk/labRPMS/LA7VOBX1.m	(revision 445)
@@ -0,0 +1,114 @@
+LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
+ ; JMC - mods to check for IHS V LAB file
+ ;
+CH ; Observation/Result segment for "CH" subscript results.
+ ; Called by LA7VOBX
+ ;
+ N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
+ ;
+ ; "CH" subscript requires a dataname
+ I '$G(LRSB) Q
+ ;
+ ; get result node from LR global.
+ S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
+ ;
+ ; Check if test is OK to send - (O)utput or (B)oth
+ S LA7X=$P(LA7VAL,"^",12)
+ I LA7X]"","BO"'[LA7X Q
+ I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
+	;
+	; If no result NLT or LOINC try to determine from file #60
+	S LA7X=$P(LA7VAL,"^",3)
+	; WV check for IHS - NLT/LN codes from V LAB file
+	I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
+	;
+	I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
+	; No result NLT code - log error
+ I $P($P(LA7VAL,"^",3),"!",2)="" D
+ . N LA7X
+ . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
+ . D CREATE^LA7LOG(36)
+ ;
+ ; something missing - No NLT code, etc.
+ I LA7VAL="" Q
+ ;
+ ; Check for missing units/reference ranges
+ S LA7X=$P(LA7VAL,"^",5)
+ ;
+ ; Results missing units, lookup in file #60
+ I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
+ ;
+ ; If results missing reference ranges, use values from file #60.
+ I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
+ . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
+ . S $P(LA7X,"!",2)=$P(LA7Y,"^")
+ . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
+ . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
+ . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
+ ; Use therapeutic low/high if low/high missing.
+ I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
+ . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
+ . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
+ ;
+ ; Evaluate low/high reference ranges in case M code in these fields.
+ S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
+ F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
+ . S @("X="_$P(LA7X,"!",LA7I))
+ . S $P(LA7X,"!",LA7I)=X
+ ;
+ ; Put units/reference ranges back in variable LA7VAL
+ S $P(LA7VAL,"^",5)=LA7X
+ ;
+ ; Initialize OBX segment
+ S LA7OBX(0)="OBX"
+ S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
+ ;
+ ; Value type
+ S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
+ ;
+ ; Observation identifer
+ ; build alternate code based on dataname from file #63 in case it's needed
+ S LA7X=$P(LA7VAL,"^",3)
+ S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
+ S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
+ ;
+ ; Test value
+ S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
+ ;
+ ; Units - remove leading and trailing spaces
+ S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
+ S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
+ ;
+ ; Reference range
+ S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
+ ;
+ ; Abnormal flags
+ S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
+ ;
+ ; "P"artial or "F"inal results
+ S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
+ ;
+ ; Observation date/time - collection date/time per HL7 standard
+ I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
+ ;
+ S LA7DIV=$P(LA7VAL,"^",9)
+ I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
+ ;
+ ; Facility that performed the testing
+ S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
+ ;
+ ; Person that verified the test
+ S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
+ ;
+ ; Observation method
+ S LA7X=$P($P(LA7VAL,"^",3),"!",4)
+ I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
+ ;
+ ; Equipment entity identifier
+ I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
+ ;
+ D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
+ ;
+ Q
Index: ccr/trunk/p/C0CLA7Q.m
===================================================================
--- ccr/trunk/p/C0CLA7Q.m	(revision 444)
+++ 	(revision )
@@ -1,166 +1,0 @@
-C0CLA7Q	;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 21, 2009
-	;;n.n;;****;
-	;
-	;
-	Q
-	;
-	;
-LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7)	; Entry point for Lab Result Query
-	;
-	;
-	K ^TMP("C0C-VLAB",$J)
-	;
-	; Check and retrieve lab results from LAB DATA file (#63)
-	S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
-	;
-	; If V LAB file present then check for lab results that are only in this file
-	; If results found in V Lab file then build results and add to above results.
-	I $D(^AUPNVLAB) D
-	. D VCHECK
-	. I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
-	;
-	;K ^TMP("C0C-VLAB",$J)
-	;
-	Q C0CDEST
-	;
-	;
-VCHECK	; If V LAB file present then check for lab results that are only in this file.
-	;
-	N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
-	;
-	S LA7PTID=C0CPTID
-	D PATID^LA7QRY2
-	I $D(LA7ERR) Q
-	;
-	; Resolve search codes to lab datanames
-	S LA7SC=$G(C0CSC)
-	I $T(SCLIST^LA7QRY2)'="" D
-	. N TMP
-	. S LA7SCSRC=$G(C0CSC)
-	. S TMP=$$SCLIST^LA7QRY2(LA7SCSRC)
-	. S LA7SC=TMP
-	;
-	I LA7SC'="*" D CHKSC^LA7QRY1
-	;
-	; Convert specimen codes to file #61 Topography entries
-	S LA7SPEC=$G(C0CSPEC)
-	I LA7SPEC'="*"  D SPEC^LA7QRY1
-	;
-	S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
-	;
-	F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
-	. I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
-	. I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
-	. S C0CDA=$QS(C0CROOT,4)
-	. I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
-	. D VCHK1
-	;
-	;
-	Q
-	;
-	;
-VBUILD	; Build results found only in V LAB file into HL7 structure.
-	;
-	;
-	Q
-	;
-	;
-LNCHK	; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
-	; Call from LA7QRY2
-	;
-	N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
-	;
-	S DFN=$P(^LR(LRDFN,0),"^",3)
-	S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
-	S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
-	S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
-	;
-	; ^AUPNVLAB("ALR1",5380,3080307.211055,"EKT 0307 48",188,5427202)=""
-	;
-	S C0C60=""
-	F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
-	. D FINDDT
-	. I C0CDA<1 Q
-	. S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
-	. S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
-	. I C0CPDA="" S C0CPDA=C0CDA
-	. S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
-	. I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
-	. S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
-	. I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
-	. S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
-	. I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
-	. S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
-	;
-	S X=$P(LA7X,"^",3)
-	; If order NLT then update if no order NLT
-	I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
-	;
-	; If result NLT then update if no result NLT
-	I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
-	;
-	; If LOINC found then update variable with LN code
-	I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
-	;
-	S $P(LA7X,"^",3)=X
-	;
-	Q
-	;
-	;
-TMPCHK	; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
-	; Called from LA7VOBX1
-	;
-	N I,X
-	;
-	S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
-	I X="" Q
-	F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
-	S $P(LA7VAL,"^",3)=LA7X
-	;
-	Q
-	;
-	;
-VCHK1	; Check the entry in V Lab to determine if it meets criteria
-	;
-	N C0CVLAB,I
-	;
-	F I=0,12 S C0CVLAB(I)=^AUPNVLAB(C0CDA,I)
-	;
-	; JMC 04/13/09 - Store anything for now that meets date criteria.
-	D VSTORE
-	;
-	Q
-	;
-	;
-VSTORE	; Store entry for building in HL7 message when parent is from V LAB file.
-	;
-	N C0CPDA,C0CPTEST
-	;
-	; Determine parent test to use for OBR segment
-	S C0CPDA=$P(C0CVLAB(12),"^",8)
-	I C0CPDA="" S C0CPDA=C0CDA
-	;
-	; Determine parent test
-	S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
-	;
-	S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
-	;
-	Q
-	;
-	;
-FINDDT	; Find entry in V LAB for the date/time or one close to it.
-	; RPMS stores related specimen entries under the same date/time.
-	; Lab file #63 creates unique entries with slightly different times.
-	;
-	S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
-	I C0CDA>0 Q
-	;
-	; If entry found then confirm that specimen type matches.
-	N C0CDTY
-	S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
-	I C0CDTY D
-	. I $P(C0CDT,".")'=$P(C0CDTY,".") Q
-	. S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
-	. I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
-	;
-	Q
Index: ccr/trunk/p/LA7QRY2.m
===================================================================
--- ccr/trunk/p/LA7QRY2.m	(revision 444)
+++ 	(revision )
@@ -1,184 +1,0 @@
-LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
- ; JMC - mods to check for IHS V LAB file
- ;
- Q
- ;
-PATID ; Resolve patient id and establish patient environment
- ;
- N LA7X
- ;
- S (DFN,LRDFN)="",LA7PTYP=0
- ;
- ; SSN passed as patient identifier
- I LA7PTID?9N.1A D
- . S LA7PTYP=1
- . S LA7X=$O(^DPT("SSN",LA7PTID,0))
- . I LA7X>0 D SETDFN(LA7X)
- ;
- ; MPI/ICN (integration control number) passed as patient identifier
- I LA7PTID?10N1"V"6N D
- . S LA7PTYP=2
- . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
- . I LA7X>0 D SETDFN(LA7X)
- ;
- ; If no patient identified/no laboratory record - return exception message
- I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
- I 'DFN S LA7ERR(2)="No patient found with requested identifier"
- I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
- I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
- Q
- ;
- ;
-BCD ; Search by specimen collection date.
- ;
- N LA763,LA7QUIT
- ;
- S (LA7SDT(0),LA7EDT(0))=0
- I LA7SDT S LA7SDT(0)=9999999-LA7SDT
- I LA7EDT S LA7EDT(0)=9999999-LA7EDT
- ;
- F LRSS="CH","MI","SP" D
- . S (LA7QUIT,LRIDT)=0
- . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
- . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
- . . ; Quit if reached end of data or outside date criteria
- . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
- . . D SEARCH
- ;
- Q
- ;
- ;
-BRAD ; Search by results available date (completion date).
- ; Assumes cross-references still exist for dates in LRO(69) global.
- ; Collects specimen date/time values for a given LRDFN and completion date.
- ; Cross-reference is by date only, time stripped from start date.
- ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
- ;
- N LA763,LA7DT,LA7ROOT,LA7SRC,X
- ;
- ; Check if orders still exist Iin file #69 for search range
- S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
- S X=$O(^LRO(69,LA7SDT(1)))
- I X,X<LA7EDT(1) S LA7SRC=1
- ;
- ; Search "AN" cross-reference in file #69.
- I LA7SRC D
- . S LA7DT=LA7SDT(1)
- . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
- . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
- . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
- . . . I $QS(LA7ROOT,6)'=LRDFN Q
- . . . S LRIDT=$QS(LA7ROOT,7)
- . . . F LRSS="CH","MI","SP" D SEARCH
- ;
- ; If no orders in #69 then do long search through file #63.
- I 'LA7SRC D
- . F LRSS="CH","MI","SP" D
- . . S LRIDT=0
- . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
- . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
- . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
- ;
- Q
- ;
- ;
-SEARCH ; Search subscript for a specific collection date/time
- ;
- K LA763
- S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
- ;
- ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
- ; Quit if specific specimen codes and they do not match
- I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
- E  S LA761=0
- I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
- ;
- ; --- Chemistry
- I LRSS="CH" D CHSS Q
- ; --- Microbiology
- I LRSS="MI" D MISS Q
- ; --- Surgical pathology
- I LRSS="SP" D APSS Q
- ; --- Cytology
- I LRSS="CY" D APSS Q
- ; --- Electron Micrscopsy
- I LRSS="EM" D APSS Q
- ; --- Autopsy
- I LRSS="AU" D APSS Q
- ; --- Blood Bank
- I LRSS="BB" D BBSS Q
- Q
- ;
- ;
-CHSS ; Search "CH" datanames for matching codes
- ;
- N LA7X,LRSB
- ;
- S LRSB=1
- F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
- . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
- . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
- . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
- . D CHECK
- ;
- Q
- ;
- ;
-MISS ; Search "MI" subscripts for matching codes
- ;
- N LA7ND,LRSB
- ;
- S LA7ND=0
- F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
- . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
- . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
- . D CHECK
- Q
- ;
- ;
-APSS ; Search AP subscripts for matching codes
- ; AP results are currently not coded - use defaults
- ;
- N LA7CODE,LRSB
- ;
- S LRSB=.012
- S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
- D CHECK
- ;
- Q
- ;
- ;
-BBSS ; Search BB subscript for matching codes
- ; *** This subscript currently not supported ***
- Q
- ;
- ;
-CHECK ; Check NLT order/result and LOINC codes.
- ;
- N LA7QUIT
- ;
- ; If wildcard then store
- ; Otherwise check for specific NLT order/result and LOINC codes
- I LA7SC="*" D STORE Q
- S LA7QUIT=0
- F I=1:1:3 D  Q:LA7QUIT
- . ; If no test code then skip
- . I '$L($P(LA7CODE,"!",I)) Q
- . ; If test code does not match a search code then quit
- . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
- . D STORE S LA7QUIT=1
- ;
- Q
- ;
- ;
-STORE ; Store entry for building in HL7 message
- ;
- S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
- Q
- ;
- ;
-SETDFN(LA7X) ; Setup DFN and other lab variables.
- ;
- S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
- Q
Index: ccr/trunk/p/LA7VOBX1.m
===================================================================
--- ccr/trunk/p/LA7VOBX1.m	(revision 444)
+++ 	(revision )
@@ -1,114 +1,0 @@
-LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
- ; JMC - mods to check for IHS V LAB file
- ;
-CH ; Observation/Result segment for "CH" subscript results.
- ; Called by LA7VOBX
- ;
- N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
- ;
- ; "CH" subscript requires a dataname
- I '$G(LRSB) Q
- ;
- ; get result node from LR global.
- S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
- S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
- ;
- ; Check if test is OK to send - (O)utput or (B)oth
- S LA7X=$P(LA7VAL,"^",12)
- I LA7X]"","BO"'[LA7X Q
- I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
-	;
-	; If no result NLT or LOINC try to determine from file #60
-	S LA7X=$P(LA7VAL,"^",3)
-	; WV check for IHS - NLT/LN codes from V LAB file
-	I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
-	;
-	I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
-	; No result NLT code - log error
- I $P($P(LA7VAL,"^",3),"!",2)="" D
- . N LA7X
- . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
- . D CREATE^LA7LOG(36)
- ;
- ; something missing - No NLT code, etc.
- I LA7VAL="" Q
- ;
- ; Check for missing units/reference ranges
- S LA7X=$P(LA7VAL,"^",5)
- ;
- ; Results missing units, lookup in file #60
- I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
- ;
- ; If results missing reference ranges, use values from file #60.
- I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
- . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
- . S $P(LA7X,"!",2)=$P(LA7Y,"^")
- . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
- . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
- . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
- ; Use therapeutic low/high if low/high missing.
- I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
- . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
- . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
- ;
- ; Evaluate low/high reference ranges in case M code in these fields.
- S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
- F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
- . S @("X="_$P(LA7X,"!",LA7I))
- . S $P(LA7X,"!",LA7I)=X
- ;
- ; Put units/reference ranges back in variable LA7VAL
- S $P(LA7VAL,"^",5)=LA7X
- ;
- ; Initialize OBX segment
- S LA7OBX(0)="OBX"
- S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
- ;
- ; Value type
- S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
- ;
- ; Observation identifer
- ; build alternate code based on dataname from file #63 in case it's needed
- S LA7X=$P(LA7VAL,"^",3)
- S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
- S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
- ;
- ; Test value
- S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
- ;
- ; Units - remove leading and trailing spaces
- S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
- S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
- ;
- ; Reference range
- S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
- ;
- ; Abnormal flags
- S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
- ;
- ; "P"artial or "F"inal results
- S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
- ;
- ; Observation date/time - collection date/time per HL7 standard
- I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
- ;
- S LA7DIV=$P(LA7VAL,"^",9)
- I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
- ;
- ; Facility that performed the testing
- S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
- ;
- ; Person that verified the test
- S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
- ;
- ; Observation method
- S LA7X=$P($P(LA7VAL,"^",3),"!",4)
- I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
- ;
- ; Equipment entity identifier
- I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
- ;
- D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
- ;
- Q