LA7VMSG ;VA/DALOI/JMC - LAB ORU (Observation Result) message builder ;JUL 06, 2010 3:14 PM
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,50,56,46,64,1027**;NOV 01, 1997
;
ORU ; Bleed the ORU (Observation Result) message queue
; Tasked by LRCAPV2
;
N LA7MTYP
S LA7MTYP="ORU"
D START^LA7VMSG1
;
Q
;
ORR ; Bleed the ORR (Order Response) message queue
; Called by LRWLST12
;
N LA7MTYP
S LA7MTYP="ORR"
;D START^LA7VMSG1
;
Q
;
;
SET(LRUID,SITE,RUID,SITEN,ORD,LRNLT,LRIDT,LRSS,LRDFN,ORDT,LA7VCH,LA7MTYP) ; adds entries to LA7V QUEUE file
; Called by LA7SRR, LRVER3, LRWLST12
; variable list
; LRUID - Host Unique ID from the local ACCESSION file (#68)
; SITE - remote sites IEN in INSTITUTION file (#4)
; RUID - Remote sites Unique ID from ACCESSION file (#68)
; SITEN - Primary site number of remote site ($$SITE^VASITE)
; ORD - Free text ordered test name from WKLD CODE file (#64)
; LRNLT - National Laboratory test code from WKLD CODE file (#64)
; LRIDT - Inverse date/time (accession date/time)
; LRSS - test subscript defined in LABORATORY TEST file (#60)
; LRDFN - IEN in LAB DATA file (#63)
; ORDT - Order date
; LA7VCH (Optional) - array of Chemistry results
; ex. glucose LA7VCH(2)=LR NODE
; LA7VCH(2,1)="C" (corrected results)
; LA7MTYP (Optional) - Message Type (ORU or ORR) defaults to ORU
;
N FDA,LA76248,LA76249,LA7DT,LA7FACID,LA7ERR,LA7RSITE,LA7Y,PORD,PORT,RSITE
;
S LA7ERR=0
I $G(LA7MTYP)="" S LA7MTYP="ORU"
; Currently not building ORR when accessioning - JMC/7/11/00
I LA7MTYP="ORR" Q
;
; Retrieve facility id (VA=station number, DoD=DMIS code, other=local site assigned id)
S LA7FACID=$$RETFACID^LA7VHLU2(SITEN,2,1),LA76248=0
S LA7RSITE="LA7V COLLECTION "_LA7FACID
S LA76248=$O(^LAHM(62.48,"B",LA7RSITE,0))
; No entry in 62.48 - *** Need to add error logging ****
I 'LA76248 Q
I '$P(^LAHM(62.48,LA76248,0),"^",3) Q ; not active
;
; Create new outgoing entry in 62.49
S LA76249=$$INIT6249^LA7VHLU
I LA76249<1 D Q
. ; Log entry creation error
;
; Check/validate parameters before storing
; If error store but flag entry with error status.
D CHKACC
;
; File data
S FDA(1,62.49,LA76249_",",1)="O"
S FDA(1,62.49,LA76249_",",.5)=LA76248
S FDA(1,62.49,LA76249_",",2)=$S(LA7ERR:"E",1:"P")
S FDA(1,62.49,LA76249_",",5)=LA7RSITE_"-O-"_RUID
S FDA(1,62.49,LA76249_",",108)=LA7MTYP
S FDA(1,62.49,LA76249_",",151)=LRUID
S FDA(1,62.49,LA76249_",",152)=SITEN
S FDA(1,62.49,LA76249_",",153)=RUID
S FDA(1,62.49,LA76249_",",154)=ORD
S FDA(1,62.49,LA76249_",",155)=LRNLT
S FDA(1,62.49,LA76249_",",156)=LRIDT
S FDA(1,62.49,LA76249_",",157)=LRSS
S FDA(1,62.49,LA76249_",",158)=LRDFN
S FDA(1,62.49,LA76249_",",159)=ORDT
;
D FILE^DIE("","FDA(1)","LA7ERR(1)")
D CLEAN^DILF
;
; Add test to order
S LA7Y=0
F S LA7Y=$O(LA7VCH(LA7Y)) Q:'LA7Y D
. N FDAIEN
. S FDA(2,62.49162,"+2,"_LA76249_",",.01)=LA7Y
. I $G(LA7VCH(LA7Y,1))="C" S FDA(2,62.49162,"+2,"_LA76249_",",.02)="C"
. S FDAIEN(1)=LA76249
. D UPDATE^DIE("","FDA(2)","FDAIEN","LA7ERR(2)")
. D CLEAN^DILF
;
; Release lock on entry.
L -^LAHM(62.49,LA76249)
Q
;
;
CHKACC ; Check/validate parameters passed in before storing in file #62.49
;
N I,LA763,LA768,LA7AA,LA7AD,LA7AN
;
I $G(LRUID)="",$G(RUID)="" Q
I LRUID'="",'$D(^LRO(68,"C",LRUID)) D
. S LRUID=$G(RUID)
. I LRUID'="",'$D(^LRO(68,"C",LRUID)) S LRUID=""
I LRUID="" Q
;
S I=$Q(^LRO(68,"C",LRUID)),(LA7AA,LA7AD,LA7AN)=0
I I'="",$QS(I,3)=LRUID S LA7AA=$QS(I,4),LA7AD=$QS(I,5),LA7AN=$QS(I,6)
F I=0,.2,.3,3 S LA768(I)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,I))
;
F I=0,"ORU" S LA763(I)=$G(^LR(LRDFN,LRSS,LRIDT,I))
;
; Mismatch on subscript with file #68
I LRSS'=$P(^LRO(68,LA7AA,0),"^",2) S LA7ERR=40 D CREATE^LA7LOG(LA7ERR)
;
; Mismatch on LRDFN with file #68
I LRDFN'=$P(LA768(0),"^") S LA7ERR=41 D CREATE^LA7LOG(LA7ERR)
;
; Mismatch on specimen inverse d/t with file #68
I LRIDT'=$P(LA768(3),"^",5) S LA7ERR=42 D CREATE^LA7LOG(LA7ERR)
;
; Mismatch on remote UID with file #68
I $G(RUID)'="",RUID'=$P(LA768(.3),"^",5) S LA7ERR=43 D CREATE^LA7LOG(LA7ERR)
;
; Mismatch on remote UID with file #63
I $G(RUID)'="",$P(LA763("ORU"),"^",5)'="",RUID'=$P(LA763("ORU"),"^",5) S LA7ERR=44 D CREATE^LA7LOG(LA7ERR)
;
; Mismatch on UID between file #63 and file #68
I $P(LA768(.3),"^")'="",$P(LA763("ORU"),"^")'="",$P(LA768(.3),"^")'=$P(LA763("ORU"),"^") S LA7ERR=45 D CREATE^LA7LOG(LA7ERR)
;
Q
;
;
ACK ; ACKnowledgment message processor
;
G ACK^LA7VHL
Q
;
;
TRIGGER(LRAA,LRAD,LRAN,LRTS) ; Call with LRTS by reference
; LRTS array contains a list of verified test.
; Sets the queue for out going messages. ^LAHM(62.49
;
N ERR,LRDFN,LREND,LRIDT,LRNIEN,LRNLT,LRNLTN,LRODT,LRSS,LRTSX
N LRORU3,LRX
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRODT=+$P(^(0),U,4)
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
Q:'$P($G(LRORU3),U,2)!('LRIDT)
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
;
S LRX=0 F S LRX=$O(LRTS(LRX)) Q:'LRX D
. S LRNLT=+$G(^LAB(60,+LRTS(LRX),64)) Q:'LRNLT
. Q:'$D(^LAM(LRNLT,0))#2
. S LRNLTN=$P(^LAM(LRNLT,0),U),LRNLT=$P(^(0),U,2)
. Q:'LRNLT
. D SET($P(LRORU3,U,4),$P(LRORU3,U,2),$P(LRORU3,U,5),$P(LRORU3,U,3),LRNLTN,LRNLT,LRIDT,LRSS,LRDFN,LRODT,"","ORU")
Q
LA7VMSG ;VA/DALOI/JMC - LAB ORU (Observation Result) message builder ;JUL 06, 2010 3:14 PM
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,50,56,46,64,1027**;NOV 01, 1997
+2 ;
ORU ; Bleed the ORU (Observation Result) message queue
+1 ; Tasked by LRCAPV2
+2 ;
+3 NEW LA7MTYP
+4 SET LA7MTYP="ORU"
+5 DO START^LA7VMSG1
+6 ;
+7 QUIT
+8 ;
ORR ; Bleed the ORR (Order Response) message queue
+1 ; Called by LRWLST12
+2 ;
+3 NEW LA7MTYP
+4 SET LA7MTYP="ORR"
+5 ;D START^LA7VMSG1
+6 ;
+7 QUIT
+8 ;
+9 ;
SET(LRUID,SITE,RUID,SITEN,ORD,LRNLT,LRIDT,LRSS,LRDFN,ORDT,LA7VCH,LA7MTYP) ; adds entries to LA7V QUEUE file
+1 ; Called by LA7SRR, LRVER3, LRWLST12
+2 ; variable list
+3 ; LRUID - Host Unique ID from the local ACCESSION file (#68)
+4 ; SITE - remote sites IEN in INSTITUTION file (#4)
+5 ; RUID - Remote sites Unique ID from ACCESSION file (#68)
+6 ; SITEN - Primary site number of remote site ($$SITE^VASITE)
+7 ; ORD - Free text ordered test name from WKLD CODE file (#64)
+8 ; LRNLT - National Laboratory test code from WKLD CODE file (#64)
+9 ; LRIDT - Inverse date/time (accession date/time)
+10 ; LRSS - test subscript defined in LABORATORY TEST file (#60)
+11 ; LRDFN - IEN in LAB DATA file (#63)
+12 ; ORDT - Order date
+13 ; LA7VCH (Optional) - array of Chemistry results
+14 ; ex. glucose LA7VCH(2)=LR NODE
+15 ; LA7VCH(2,1)="C" (corrected results)
+16 ; LA7MTYP (Optional) - Message Type (ORU or ORR) defaults to ORU
+17 ;
+18 NEW FDA,LA76248,LA76249,LA7DT,LA7FACID,LA7ERR,LA7RSITE,LA7Y,PORD,PORT,RSITE
+19 ;
+20 SET LA7ERR=0
+21 IF $GET(LA7MTYP)=""
SET LA7MTYP="ORU"
+22 ; Currently not building ORR when accessioning - JMC/7/11/00
+23 IF LA7MTYP="ORR"
QUIT
+24 ;
+25 ; Retrieve facility id (VA=station number, DoD=DMIS code, other=local site assigned id)
+26 SET LA7FACID=$$RETFACID^LA7VHLU2(SITEN,2,1)
SET LA76248=0
+27 SET LA7RSITE="LA7V COLLECTION "_LA7FACID
+28 SET LA76248=$ORDER(^LAHM(62.48,"B",LA7RSITE,0))
+29 ; No entry in 62.48 - *** Need to add error logging ****
+30 IF 'LA76248
QUIT
+31 ; not active
IF '$PIECE(^LAHM(62.48,LA76248,0),"^",3)
QUIT
+32 ;
+33 ; Create new outgoing entry in 62.49
+34 SET LA76249=$$INIT6249^LA7VHLU
+35 IF LA76249<1
Begin DoDot:1
+36 ; Log entry creation error
End DoDot:1
QUIT
+37 ;
+38 ; Check/validate parameters before storing
+39 ; If error store but flag entry with error status.
+40 DO CHKACC
+41 ;
+42 ; File data
+43 SET FDA(1,62.49,LA76249_",",1)="O"
+44 SET FDA(1,62.49,LA76249_",",.5)=LA76248
+45 SET FDA(1,62.49,LA76249_",",2)=$SELECT(LA7ERR:"E",1:"P")
+46 SET FDA(1,62.49,LA76249_",",5)=LA7RSITE_"-O-"_RUID
+47 SET FDA(1,62.49,LA76249_",",108)=LA7MTYP
+48 SET FDA(1,62.49,LA76249_",",151)=LRUID
+49 SET FDA(1,62.49,LA76249_",",152)=SITEN
+50 SET FDA(1,62.49,LA76249_",",153)=RUID
+51 SET FDA(1,62.49,LA76249_",",154)=ORD
+52 SET FDA(1,62.49,LA76249_",",155)=LRNLT
+53 SET FDA(1,62.49,LA76249_",",156)=LRIDT
+54 SET FDA(1,62.49,LA76249_",",157)=LRSS
+55 SET FDA(1,62.49,LA76249_",",158)=LRDFN
+56 SET FDA(1,62.49,LA76249_",",159)=ORDT
+57 ;
+58 DO FILE^DIE("","FDA(1)","LA7ERR(1)")
+59 DO CLEAN^DILF
+60 ;
+61 ; Add test to order
+62 SET LA7Y=0
+63 FOR
SET LA7Y=$ORDER(LA7VCH(LA7Y))
IF 'LA7Y
QUIT
Begin DoDot:1
+64 NEW FDAIEN
+65 SET FDA(2,62.49162,"+2,"_LA76249_",",.01)=LA7Y
+66 IF $GET(LA7VCH(LA7Y,1))="C"
SET FDA(2,62.49162,"+2,"_LA76249_",",.02)="C"
+67 SET FDAIEN(1)=LA76249
+68 DO UPDATE^DIE("","FDA(2)","FDAIEN","LA7ERR(2)")
+69 DO CLEAN^DILF
End DoDot:1
+70 ;
+71 ; Release lock on entry.
+72 LOCK -^LAHM(62.49,LA76249)
+73 QUIT
+74 ;
+75 ;
CHKACC ; Check/validate parameters passed in before storing in file #62.49
+1 ;
+2 NEW I,LA763,LA768,LA7AA,LA7AD,LA7AN
+3 ;
+4 IF $GET(LRUID)=""
IF $GET(RUID)=""
QUIT
+5 IF LRUID'=""
IF '$DATA(^LRO(68,"C",LRUID))
Begin DoDot:1
+6 SET LRUID=$GET(RUID)
+7 IF LRUID'=""
IF '$DATA(^LRO(68,"C",LRUID))
SET LRUID=""
End DoDot:1
+8 IF LRUID=""
QUIT
+9 ;
+10 SET I=$QUERY(^LRO(68,"C",LRUID))
SET (LA7AA,LA7AD,LA7AN)=0
+11 IF I'=""
IF $QSUBSCRIPT(I,3)=LRUID
SET LA7AA=$QSUBSCRIPT(I,4)
SET LA7AD=$QSUBSCRIPT(I,5)
SET LA7AN=$QSUBSCRIPT(I,6)
+12 FOR I=0,.2,.3,3
SET LA768(I)=$GET(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,I))
+13 ;
+14 FOR I=0,"ORU"
SET LA763(I)=$GET(^LR(LRDFN,LRSS,LRIDT,I))
+15 ;
+16 ; Mismatch on subscript with file #68
+17 IF LRSS'=$PIECE(^LRO(68,LA7AA,0),"^",2)
SET LA7ERR=40
DO CREATE^LA7LOG(LA7ERR)
+18 ;
+19 ; Mismatch on LRDFN with file #68
+20 IF LRDFN'=$PIECE(LA768(0),"^")
SET LA7ERR=41
DO CREATE^LA7LOG(LA7ERR)
+21 ;
+22 ; Mismatch on specimen inverse d/t with file #68
+23 IF LRIDT'=$PIECE(LA768(3),"^",5)
SET LA7ERR=42
DO CREATE^LA7LOG(LA7ERR)
+24 ;
+25 ; Mismatch on remote UID with file #68
+26 IF $GET(RUID)'=""
IF RUID'=$PIECE(LA768(.3),"^",5)
SET LA7ERR=43
DO CREATE^LA7LOG(LA7ERR)
+27 ;
+28 ; Mismatch on remote UID with file #63
+29 IF $GET(RUID)'=""
IF $PIECE(LA763("ORU"),"^",5)'=""
IF RUID'=$PIECE(LA763("ORU"),"^",5)
SET LA7ERR=44
DO CREATE^LA7LOG(LA7ERR)
+30 ;
+31 ; Mismatch on UID between file #63 and file #68
+32 IF $PIECE(LA768(.3),"^")'=""
IF $PIECE(LA763("ORU"),"^")'=""
IF $PIECE(LA768(.3),"^")'=$PIECE(LA763("ORU"),"^")
SET LA7ERR=45
DO CREATE^LA7LOG(LA7ERR)
+33 ;
+34 QUIT
+35 ;
+36 ;
ACK ; ACKnowledgment message processor
+1 ;
+2 GOTO ACK^LA7VHL
+3 QUIT
+4 ;
+5 ;
TRIGGER(LRAA,LRAD,LRAN,LRTS) ; Call with LRTS by reference
+1 ; LRTS array contains a list of verified test.
+2 ; Sets the queue for out going messages. ^LAHM(62.49
+3 ;
+4 NEW ERR,LRDFN,LREND,LRIDT,LRNIEN,LRNLT,LRNLTN,LRODT,LRSS,LRTSX
+5 NEW LRORU3,LRX
+6 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRODT=+$PIECE(^(0),U,4)
+7 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+8 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+9 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+10 IF '$PIECE($GET(LRORU3),U,2)!('LRIDT)
QUIT
+11 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
QUIT
+12 ;
+13 SET LRX=0
FOR
SET LRX=$ORDER(LRTS(LRX))
IF 'LRX
QUIT
Begin DoDot:1
+14 SET LRNLT=+$GET(^LAB(60,+LRTS(LRX),64))
IF 'LRNLT
QUIT
+15 IF '$DATA(^LAM(LRNLT,0))#2
QUIT
+16 SET LRNLTN=$PIECE(^LAM(LRNLT,0),U)
SET LRNLT=$PIECE(^(0),U,2)
+17 IF 'LRNLT
QUIT
+18 DO SET($PIECE(LRORU3,U,4),$PIECE(LRORU3,U,2),$PIECE(LRORU3,U,5),$PIECE(LRORU3,U,3),LRNLTN,LRNLT,LRIDT,LRSS,LRDFN,LRODT,"","ORU")
End DoDot:1
+19 QUIT
