iSharkFly-Open
/
VistA-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rollback of Lab for RPMS code

This commit is contained in:
george 2009-04-14 14:57:24 +00:00
parent 02fc269be1
commit 2fb69de493
3 changed files with 51 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
p/C0CLA7Q.m
View File

@ -1,5 +1,5 @@
C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 12, 2009 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Apr 13, 2009
;;5.2;;****;Sep 27, 1994 ;;n.n;;****;
; ;
; ;
Q Q
@ -11,13 +11,13 @@ LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for
K ^TMP("C0C-VLAB",$J) K ^TMP("C0C-VLAB",$J)
; ;
; Check and retrieve lab results from LAB DATA file (#63) ; Check and retrieve lab results from LAB DATA file (#63)
D GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,.C0CSC,.C0CSPEC,.C0CERR,C0CDEST,C0CHL7) D 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 V LAB file present then check for lab results that are only in this file
I $D(^AUPNVLAB) D VCHECK
;
; If results found in V Lab file then build results and add to above results. ; If results found in V Lab file then build results and add to above results.
I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD I $D(^AUPNVLAB) D
. D VCHECK
. I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
; ;
;K ^TMP("C0C-VLAB",$J) ;K ^TMP("C0C-VLAB",$J)
; ;
@ -83,7 +83,7 @@ LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a
; If LOINC found then update variable with LN code ; If LOINC found then update variable with LN code
I C0CLN'="" D I C0CLN'="" D
. S X=$P(LA7X,"^",3) . S X=$P(LA7X,"^",3)
. S $P(X,"!",3)=C0CLN . I $P(X,"!",3)="" S $P(X,"!",3)=C0CLN
. S $P(LA7X,"^",3)=X . S $P(LA7X,"^",3)=X
; ;
Q Q
@ -95,6 +95,7 @@ VCHK1 ; Check the entry in V Lab to determine if it meets criteria
; ;
F I=0,12 S C0CVLAB(I)=^AUPNVLAB(C0CDA,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 D VSTORE
; ;
Q Q
@ -102,5 +103,17 @@ VCHK1 ; Check the entry in V Lab to determine if it meets criteria
; ;
VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
; ;
S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(12),"^"),$P(C0CVLAB,"^",2))="" N PARENT
;
; Determine parent test to use for OBR segment
S PARENT=$P(C0CVLAB(12),"^",8)
I PARENT="" S PARENT=$P(C0CVLAB(0),"^")
;
; patient ien
; | collection date/time
; | | parent test (ordered test)
; | | | ien of entry in V LAB file
; | | | |
S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),PARENT,C0CDA)=""
;
Q Q

44
p/LA7QRY2.m
View File

@ -1,5 +1,5 @@
LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ;1/30/07 19:05 LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,69,73**;Sep 27, 1994;Build 7 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
; JMC - mods to check for IHS V LAB file ; JMC - mods to check for IHS V LAB file
; ;
Q Q
@ -9,15 +9,18 @@ PATID ; Resolve patient id and establish patient environment
N LA7X N LA7X
; ;
S (DFN,LRDFN)="",LA7PTYP=0 S (DFN,LRDFN)="",LA7PTYP=0
; VOE changes, Use HRN cross reference, Daou;;June 8,2005
S LA7X=$O(^AUPNPAT("D",LA7PTID,""))
I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1
; ;
; See if SSN passed as patient identifier ; SSN passed as patient identifier
I DFN'>0 S LA7X=$O(^DPT("SSN",LA7PTID,0)) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1 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 ; MPI/ICN (integration control number) passed as patient identifier
I DFN'>0 S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=2 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 ; If no patient identified/no laboratory record - return exception message
I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
@ -35,8 +38,7 @@ BCD ; Search by specimen collection date.
I LA7SDT S LA7SDT(0)=9999999-LA7SDT I LA7SDT S LA7SDT(0)=9999999-LA7SDT
I LA7EDT S LA7EDT(0)=9999999-LA7EDT I LA7EDT S LA7EDT(0)=9999999-LA7EDT
; ;
S LRSS="" F LRSS="CH","MI","SP" D
F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
. S (LA7QUIT,LRIDT)=0 . S (LA7QUIT,LRIDT)=0
. I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
. F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D
@ -67,13 +69,12 @@ BRAD ; Search by results available date (completion date).
. . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
. . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D
. . . I $QS(LA7ROOT,6)'=LRDFN Q . . . I $QS(LA7ROOT,6)'=LRDFN Q
. . . S LRIDT=$QS(LA7ROOT,7),LRSS="" . . . S LRIDT=$QS(LA7ROOT,7)
. . . F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D SEARCH . . . F LRSS="CH","MI","SP" D SEARCH
; ;
; If no orders in #69 then do long search through file #63. ; If no orders in #69 then do long search through file #63.
I 'LA7SRC D I 'LA7SRC D
. S LRSS="" . F LRSS="CH","MI","SP" D
. F S LRSS=$O(LRSSLST(LRSS)) Q:LRSS="" D
. . S LRIDT=0 . . S LRIDT=0
. . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D
. . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
@ -117,7 +118,7 @@ CHSS ; Search "CH" datanames for matching codes
S LRSB=1 S LRSB=1
F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D
. S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
. I $P($P(LA7X,"^",3),"!",3)="",$D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS. . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
. S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761) . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
. D CHECK . D CHECK
; ;
@ -181,14 +182,3 @@ SETDFN(LA7X) ; Setup DFN and other lab variables.
; ;
S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^") S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
Q Q
;
;***** SETUP THE SEARCH CODES
SCLIST(SCLST) ;
N I,RC,SCALL,TMP K LRSSLST
S SCALL=",CH,MI,SP,"
S SCLST=$$UP^XLFSTR($TR(SCLST," ")),RC="*"
S:SCLST?.1"*" RC=SCLST,SCLST=$P(SCALL,",",2,999)
F I=1:1 S TMP=$P(SCLST,",",I) Q:TMP="" D Q:$D(LA7ERR)>1
. I SCALL[(","_TMP_",") S LRSSLST(TMP)="" Q
. S LA7ERR(7)="Invalid list of subscripts: '"_SCLST_"'"
Q RC

41
p/LA7VOBX1.m
View File

@ -1,33 +1,29 @@
LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd ;Apr 8, 2009 LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/13/09
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63,64,71**;Sep 27, 1994 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
; JMC - mods to check for IHS V LAB file ; JMC - mods to check for IHS V LAB file
; ;
CH ; Observation/Result segment for "CH" subscript results. CH ; Observation/Result segment for "CH" subscript results.
; Called by LA7VOBX ; Called by LA7VOBX
; ;
N LA76304,LA7ALT,LA7DIV,LA7I,LA7RS,LA7X,LA7Y,X N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
; ;
; "CH" subscript requires a dataname ; "CH" subscript requires a dataname
I '$G(LRSB) Q I '$G(LRSB) Q
; ;
; get result node from LR global. ; get result node from LR global.
S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
S LA7RS=$P(LRSB,"^",2),LRSB=$P(LRSB,"^")
S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
; If previous results have been corrected then send corrected status
I LA7RS="",$P(LA7VAL,"^",10)=2 S LA7RS="C"
; ;
; Check if test is OK to send - (O)utput or (B)oth ; Check if test is OK to send - (O)utput or (B)oth
S LA7X=$P(LA7VAL,"^",12) S LA7X=$P(LA7VAL,"^",12)
I LA7X]"","BO"'[LA7X Q I LA7X]"","BO"'[LA7X Q
I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",7)) 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 ; If no result NLT or LOINC try to determine from file #60
S LA7X=$P(LA7VAL,"^",3) S LA7X=$P(LA7VAL,"^",3)
; ; Check for no LOINC in 63 and LOINC found in V LAB file.
; Check for no LOINC in 63 and LOINC found in V LAB file. I $P(LA7X,"!",3)="",$D(^TMP("LA7-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) S $P(LA7X,"!",3)=$P(^TMP("LA7-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB),"^")
I $P(LA7X,"!",3)="",$D(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) S $P(LA7X,"!",3)=$P(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB),"^") ;
;
I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) 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 ; No result NLT code - log error
I $P($P(LA7VAL,"^",3),"!",2)="" D I $P($P(LA7VAL,"^",3),"!",2)="" D
@ -70,10 +66,7 @@ CH ; Observation/Result segment for "CH" subscript results.
S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
; ;
; Value type ; Value type
; If result is "cancel" or "comment" then data type is ST - string data S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
S LA7X=$S("canccomment"[$P(LA7VAL,"^"):1,1:0)
I LA7X S LA7OBX(2)="ST"
E S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
; ;
; Observation identifer ; Observation identifer
; build alternate code based on dataname from file #63 in case it's needed ; build alternate code based on dataname from file #63 in case it's needed
@ -82,28 +75,20 @@ CH ; Observation/Result segment for "CH" subscript results.
S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
; ;
; Test value ; Test value
; If DoD and "canc" then report "PL Cancelled" per Lab Interop ICD. S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
S LA7X=$P(LA7VAL,"^")
I LA7X'="canc",$$GET1^DID(63.04,LRSB,"","TYPE","","LA7ERR")="SET" D
. S LA7X=$$EXTERNAL^DILFD(63.04,LRSB,"",LA7X)
. I LA7X="" S LA7X=$P(LA7VAL,"^")
I $G(LA7NVAF)=1,LA7X="canc" S LA7X="PL Cancelled"
S LA7OBX(5)=$$OBX5^LA7VOBX(LA7X,LA7OBX(2),LA7FS,LA7ECH)
; ;
; Units ; Units - remove leading and trailing spaces
S LA7X=$P(LA7VAL,"^",5) S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
; ;
; Reference range ; Reference range
S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
; ;
; Abnormal flags ; Abnormal flags
S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,"^",2)) S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
; ;
; "P"artial or "F"inal results ; "P"artial or "F"inal results
S LA7X=$S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F") S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
I LA7RS="C" S LA7X=LA7RS
S LA7OBX(11)=$$OBX11^LA7VOBX(LA7X)
; ;
; Observation date/time - collection date/time per HL7 standard ; Observation date/time - collection date/time per HL7 standard
I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))