LA7VORM1 ;VA/DALOI/DLR - LAB ORM (Order) message builder ; 13-Aug-2013 09:09 ; MKK
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,1018,64,1027,68,1033**;NOV 01, 1997;Build 9
;
BUILD(LA7628) ;
; Call with LA7628 = ien of entry in file #62.8 Shipping Manifest
;
N LA7101,LA762801,LA7629,LA7NVAF,LA7PIDSN,LA7X,ECNT,GBL,SHP,SHPC,SITE,ORUID,NTST
;
I $G(LA7628)<1!('$D(^LAHM(62.8,+$G(LA7628),0))) D Q
. ; Need to add error logging for manifest not found.
. D EXIT
;
S GBL="^TMP(""HLS"","_$J_")",ECNT=1
S LA7628(0)=$G(^LAHM(62.8,LA7628,0))
S LA7629=$P(LA7628(0),U,2)
S LA7629(0)=$G(^LAHM(62.9,LA7629,0))
S LA76248=+$P(LA7629(0),"^",7)
S LA76248(0)=$G(^LAHM(62.48,LA76248,0))
I '$P(LA76248(0),"^",3) D EXIT Q ; not active
;
S LA7V("INST")=$P(LA7629(0),U,11)
Q:LA7V("INST")=$P(LA7629(0),U,6) ;Same system shipment
;
S LA7NVAF=$$NVAF^LA7VHLU2(+LA7V("INST")),SITE=""
I LA7NVAF=0 S SITE=$$GET1^DIQ(4,+$P(LA7629(0),U,11)_",",99)
I LA7NVAF=1 S SITE=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,11))
S LA7V("NON")=$P(LA7629(0),U,12)
I LA7V("NON")'="" S SITE=LA7V("NON")
;
S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,2))
I LA7X=0 S LA7V("CLNT")=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",99)
I LA7X=1 S LA7V("CLNT")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,2))
S $P(LA7V("CLNT"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",.01)
;
S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,3))
I LA7X=0 S LA7V("HOST")=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",99)
I LA7X=1 S LA7V("HOST")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,3))
S $P(LA7V("HOST"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",.01)
;
; Assuming the receiving institution is the primary site (site with the computer system)
;
; Set flag = 0 (multiple PID's/message - build one message)
; 1 (one PID/message - build multiple messages)
; 2 (one ORC/message - build multiple messages)
S LA7SMSG=+$P(LA76248(0),"^",8)
;
; Sort tests by patient,UID,test - only need to build one PID, PV1 per patient
; ^TMP("LA7628",$J, LRDFN, accession UID, ien of shipping manifest specimen entry)
K ^TMP("LA7628",$J)
S LA762801=0
F S LA762801=$O(^LAHM(62.8,LA7628,10,LA762801)) Q:'LA762801 D
. S X(0)=$G(^LAHM(62.8,LA7628,10,LA762801,0))
. I $P(X(0),"^",8)=0 Q ; Removed from manifest
. I $G(LA7SMSG)'=3 D ;cmi/maw for LEDI IHS order
.. I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$P(X(0),"^",5),LA762801)=""
. I $G(LA7SMSG)=3 D ;cmi/maw for LEDI IHS order
.. I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,$$GETORDA($P(X(0),"^",5)),$P(X(0),"^",5),LA762801)=""
.. ;I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$$GETORDA($P(X(0),"^",5))_"~"_$P(X(0),"^",5),LA762801)=""
K LA762801
;
; Nothing to send
I '$D(^TMP("LA7628",$J)) D EXIT Q
;
;
I LA7SMSG=0 D Q:$G(HL)
. D STARTMSG
. I $G(HL) D EXIT
;
;S (LRDFN,LRI,LA7PIDSN,LA7ORD)=0 ;ihs/cmi/maw 11/17/2010
S (LRDFN,LRI,LA7PIDSN,LA7ORD,LA7OBRSN)=0 ;ihs/cmi/maw 11/17/2010
F S LA7ORD=$O(^TMP("LA7628",$J,LA7ORD)) Q:'LA7ORD D Q:$G(HL)
. N LA7PID,LA7PV1,LA7ORDI,LA7ORDD,LA7ORI
. I LA7SMSG=1 D STARTMSG Q:$G(HL)
. S LA7ORDI=$Q(^LRO(69,"C",LA7ORD))
. I $QS(LA7ORDI,3)'=LA7ORD Q
. S LA7ORDD=$QS(LA7ORDI,4)
. S LA7ORI=$QS(LA7ORDI,5)
. S LRDFN=+$G(^LRO(69,LA7ORDD,1,LA7ORI,0))
. ;S LA7ORD=$$GETORD(LRDFN) ;cmi/maw get order number
. I LA7SMSG<2 D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;cmi/maw for billing info
. I LA7SMSG=3 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added LEDI order
. S LA7UID=""
. S (LA7GUAR,LA7DGQ)=0 ;cmi/maw 5/26/2010 insurance
. F S LA7UID=$O(^TMP("LA7628",$J,LA7ORD,LA7UID)) Q:LA7UID="" D
. . N LA76802,LA7ORC,X
. . S X=$Q(^LRO(68,"C",LA7UID))
. . I $QS(X,3)'=LA7UID Q
. . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
. . F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) ;cmi/maw 3/10/2010 get .1 node as well
. . ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) cmi/maw 3/10/2010 orig line
. . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
. . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
. . I LA7SMSG=2 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added
. . S (LA7OBRSN,LA762801)=0 ;ihs/cmi/maw 11/16/2010 orig line changed back 04/04/2011 to this
. . ;S LA762801=0 ;ihs/cmi/maw 11/17/2010 mod changed back 04/04/2011
. . F S LA762801=$O(^TMP("LA7628",$J,LA7ORD,LA7UID,LA762801)) Q:'LA762801 D
. . . N LA7OBR,I
. . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
. . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q ;deleted accession
. . . D ORC,OBR^LA7VORM3,DG1(LA7ORD),OBX(LA7ORD,LA7UID) ;cmi/maw 06/23/2010 added DG1 segment for LEDI
. . I LA7SMSG=2 D BLG,SENDMSG
. I LA7SMSG=3 D BLG,SENDMSG ;cmi/maw 7/1/2010 for ledi insurance
. S (LA7DGQ,LA7GUAR)=0 ;cmi/maw 5/26/2010 added for insurance
. I LA7SMSG<2 D BLG
. I LA7SMSG=1 D SENDMSG
;
I LA7SMSG=0 D SENDMSG
;
;ihs/cmi/maw 9/27/10 below is original ledi code
;S (LRDFN,LRI,LA7PIDSN)=0
;F S LRDFN=$O(^TMP("LA7628",$J,LRDFN)) Q:'LRDFN D Q:$G(HL)
;. N LA7PID,LA7PV1
;. I LA7SMSG=1 D STARTMSG Q:$G(HL)
;. S LA7ORD=$$GETORD(LRDFN) ;cmi/maw get order number
;. I LA7SMSG<2 D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;cmi/maw for billing info
;. I LA7SMSG=3 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added LEDI order
;. S LA7UID=""
;. S (LA7GUAR,LA7DGQ)=0 ;cmi/maw 5/26/2010 insurance
;. F S LA7UID=$O(^TMP("LA7628",$J,LRDFN,LA7UID)) Q:LA7UID="" D
;. . N LA76802,LA7ORC,X
;. . S X=$Q(^LRO(68,"C",$P(LA7UID,"~",2)))
;. . I $QS(X,3)'=$P(LA7UID,"~",2) Q
;. . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
;. . F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) ;cmi/maw 3/10/2010 get .1 node as well
;. . ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) cmi/maw 3/10/2010 orig line
;. . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
;. . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
;. . I LA7SMSG=2 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added
;. . S (LA7OBRSN,LA762801)=0
;. . F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D
;. . . N LA7OBR,I
;. . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
;. . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q ;deleted accession
;. . . D ORC,OBR^LA7VORM3,DG1(LA7ORD),OBX^LA7VORM3 ;cmi/maw 06/23/2010 added DG1 segment for LEDI
;. . I LA7SMSG=2 D BLG,SENDMSG
;. . I LA7SMSG=3 D BLG,SENDMSG ;cmi/maw 7/1/2010 for ledi insurance
;. . S (LA7DGQ,LA7GUAR)=0 ;cmi/maw 5/26/2010 added for insurance
;. I LA7SMSG<2 D BLG
;. I LA7SMSG=1 D SENDMSG
;
;I LA7SMSG=0 D SENDMSG
;ihs/cmi/maw end of orig ledi code
;
EXIT ;
K @GBL,^TMP("LA7628",$J)
K DIC,DFN,EID,HL,HLCOMP,HLFS,HLQ,HLSUB,INT
K LA760,LA7628,LA762801,LA7629
K LA7ECH,LA7FS,LA7MID,LA7V,LA7HDR,LA7OBRSN,LA7OBXSN,LA7VIEN,LAEVNT
K LRAA,LRACC,LRAD,LRAN,LRDFN,LRI
K LTST,NLT,NLTIEN,PCNT,RUID,SNIEN,TIEN,X,Y,LA
D KVAR^LRX
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
;
STARTMSG ; Create/initialize HL message
;
K @GBL
S (LA76249,LA7PIDSN)=0
D STARTMSG^LA7VHLU("LA7V Order to "_SITE,.LA76249)
Q
;
;
SENDMSG ; File HL7 message with HL and LAB packages.
;
N LA7DATA,LA7ID
S LA7ID="LA7V HOST "_SITE_"-O-"_$P($G(LA7628(0)),"^")
; If no message to send then quit
I '$D(^TMP("HLS",$J)) D Q
. N FDA,LA7ER
. I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
. S FDA(1,62.49,LA76249_",",1)="O"
. S FDA(1,62.49,LA76249_",",2)="E"
. S FDA(1,62.49,LA76249_",",5)=LA7ID
. D FILE^DIE("","FDA(1)","LA7ER(1)")
. D CLEAN^DILF
. L -^LAHM(62.49,LA76249)
;
D GEN^LA7VHLU
S LA7DATA="SM06"_"^"_$$NOW^XLFDT
D SEUP^LA7SMU($P(LA7628(0),"^"),"1",LA7DATA)
D UPDT6249
; Unlock entry
L -^LAHM(62.49,LA76249)
Q
;
;
UPDT6249 ; update entry in 62.49
;
N FDA,LA7ER
;
I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
S FDA(1,62.49,LA76249_",",1)="O"
I $P(^LAHM(62.49,LA76249,0),"^",3)'="E" D
. I $G(HL("APAT"))="AL" S FDA(1,62.49,LA76249_",",2)="A"
. E S FDA(1,62.49,LA76249_",",2)="X"
. I $G(LA7ERR) S FDA(1,62.49,LA76249_",",2)="E"
S FDA(1,62.49,LA76249_",",5)=LA7ID
I $G(HL("SAN"))'="" S FDA(1,62.49,LA76249_",",102)=HL("SAN")
I $G(HL("SAF"))'="" S FDA(1,62.49,LA76249_",",103)=HL("SAF")
I $G(HL("MTN"))'="" S FDA(1,62.49,LA76249_",",108)=HL("MTN")
I $G(HL("PID"))'="" S FDA(1,62.49,LA76249_",",110)=HL("PID")
I $G(HL("VER"))'="" S FDA(1,62.49,LA76249_",",111)=HL("VER")
I $P($G(LA7MID),"^")'="" S FDA(1,62.49,LA76249_",",109)=$P(LA7MID,"^")
I $P($G(LA7MID),"^",2) D
. S FDA(1,62.49,LA76249_",",160)=$P(LA7MID,"^",2)
. S FDA(1,62.49,LA76249_",",161)=$P(LA7MID,"^",3)
D FILE^DIE("","FDA(1)","LA7ER(1)")
D CLEAN^DILF
Q
;
;
PID ; Patient identification
S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
D DEM^LRX
D PID^LA7VPID(LRDFN,"",.LA7PID,.LA7PIDSN,.HL,"")
; DoD/CHCS facilities only use 1st repetition of PID-3.
I LA7NVAF=1 D
. S X=$P(LA7PID(0),LA7FS,4),X=$P(X,$E(LA7ECH,2))
. S $P(LA7PID(0),LA7FS,4)=X
D FILESEG^LA7VHLU(GBL,.LA7PID)
D FILE6249^LA7VHLU(LA76249,.LA7PID)
Q
;
;
PV1 ; Location information
; DoD/CHCS facilities do not use PV1 segment
I LA7NVAF=1 Q
;
D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
D FILESEG^LA7VHLU(GBL,.LA7PV1)
D FILE6249^LA7VHLU(LA76249,.LA7PV1)
Q
;
;
ORC ;Order Control
;
N ORC,LA7DATA,LA7DUR,LA7DURU,LA76205,LA762801,LA7X
;
S ORC(0)="ORC"
S ORC(1)=$$ORC1^LA7VORC("NW")
;
; Place order number - accession UID
;S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.3),"^"),LA7FS,LA7ECH)
S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.1),"^"),LA7FS,LA7ECH)
;
; Placer group number - shipping manifest invoice #
S ORC(4)=$$ORC4^LA7VORC($P(LA7628(0),"^"),LA7FS,LA7ECH)
;
; Quantity/Timing
S (LA76205,LA7DUR,LA7DURU)=""
S LA762801=0
;F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D ;ihs/cmi/maw ledi orig
F S LA762801=$O(^TMP("LA7628",$J,LA7ORD,LA7UID,LA762801)) Q:'LA762801 D ;ihs/cmi/maw 09/27/2010 ledi new
. N I,LA760
. ; Test duration
. F I=0,2 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
. I $P(LA762801(2),"^",4) D
. . S LA7DUR=$P(LA762801(2),"^",6) ; collection duration
. . S LA7DURU=$P(LA762801(2),"^",7) ; duration units
. ; Test urgency - find highest urgency on accession
. S LA760=+$P(LA762801(0),"^",2)
. S X=+$$GET1^DIQ(68.04,LA760_","_LRAN_","_LRAD_","_LRAA_",",1,"I")
. I 'LA76205 S LA76205=X
. I LA76205,X<LA76205 S LA76205=X
S ORC(7)=$$ORC7^LA7VORC(LA7DUR,LA7DURU,LA76205,LA7FS,LA7ECH)
;
; Order Date/Time - if no order date/time then try draw time
I $P(LA76802(0),"^",4) S ORC(9)=$$ORC9^LA7VORC($P(LA76802(0),"^",4))
I '$P(LA76802(0),"^",4),$P(LA76802(3),"^") S ORC(9)=$$ORC9^LA7VORC($P(LA76802(3),"^"))
;
; Ordering provider
S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
S ORC(12)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH)
;
; Entering organization - VA facility
S ORC(17)=$$ORC17^LA7VORC($P($G(LA7629(0)),U,2),LA7FS,LA7ECH)
;
D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
Q
;
GETORD(DF) ;-- get the order number
N LA7QUID
S LA7QUID=$O(^TMP("LA7628",$J,DF,0))
I $G(LA7QUID)="" Q ""
Q $P(LA7QUID,"~")
;
GETORDA(UID) ;-- get the order number
N X
S X=$Q(^LRO(68,"C",UID))
I $QS(X,3)'=UID Q ""
S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) ;cmi/maw 3/10/2010 get .1 node as well
Q $G(LA76802(.1))
;
DG1(ORD) ;-- handle the diagnosis
Q:$P($$ACCT^LA7VQINS(ORD),U,4)'="T"
D DG1^LA7VQINS(ORD)
Q
;
GT1(ORD) ;-- handle the guarantor
Q:$P($$ACCT^LA7VQINS(ORD),U,4)="C" ;ihs/cmi/maw 11/18/2010 changed to send if T or P
D GAR^LA7VQINS(DFN,,,1)
Q
;
IN1(ORD) ;-- handle insurance
;Q:$P($$ACCT^LA7VQINS(ORD),U,4)'="T"
K IN1 ;maybe this is hanging around?
S CNT=0 ;ihs/cmi/maw resets the IN1 segment counter 1/12/2011
D INS^LA7VQINS(1,ORD)
Q
;
OBX(ORD,UID) ;-- build the obx ask at order questions
D OBX^LA7VQINS(ORD,UID) ;ihs/cmi/maw 11/15/2010 - lets put the local ask at order questions in OBX
Q
BLG ; Billing segment
;
Q ;cmi/maw 4/14/2010 no BLG segment, will replace with DG1, IN1, and GT1
N LA7BLG
;
I $P(LA7629(0),U,13)="" Q
S LA7BLG(0)=$$BLG^LA7VHLU($P(LA7629(0),"^",13),"CO",LA7FS,LA7ECH)
D FILESEG^LA7VHLU(GBL,.LA7BLG)
D FILE6249^LA7VHLU(LA76249,.LA7BLG)
Q
LA7VORM1 ;VA/DALOI/DLR - LAB ORM (Order) message builder ; 13-Aug-2013 09:09 ; MKK
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,1018,64,1027,68,1033**;NOV 01, 1997;Build 9
+2 ;
BUILD(LA7628) ;
+1 ; Call with LA7628 = ien of entry in file #62.8 Shipping Manifest
+2 ;
+3 NEW LA7101,LA762801,LA7629,LA7NVAF,LA7PIDSN,LA7X,ECNT,GBL,SHP,SHPC,SITE,ORUID,NTST
+4 ;
+5 IF $GET(LA7628)<1!('$DATA(^LAHM(62.8,+$GET(LA7628),0)))
Begin DoDot:1
+6 ; Need to add error logging for manifest not found.
+7 DO EXIT
End DoDot:1
QUIT
+8 ;
+9 SET GBL="^TMP(""HLS"","_$JOB_")"
SET ECNT=1
+10 SET LA7628(0)=$GET(^LAHM(62.8,LA7628,0))
+11 SET LA7629=$PIECE(LA7628(0),U,2)
+12 SET LA7629(0)=$GET(^LAHM(62.9,LA7629,0))
+13 SET LA76248=+$PIECE(LA7629(0),"^",7)
+14 SET LA76248(0)=$GET(^LAHM(62.48,LA76248,0))
+15 ; not active
IF '$PIECE(LA76248(0),"^",3)
DO EXIT
QUIT
+16 ;
+17 SET LA7V("INST")=$PIECE(LA7629(0),U,11)
+18 ;Same system shipment
IF LA7V("INST")=$PIECE(LA7629(0),U,6)
QUIT
+19 ;
+20 SET LA7NVAF=$$NVAF^LA7VHLU2(+LA7V("INST"))
SET SITE=""
+21 IF LA7NVAF=0
SET SITE=$$GET1^DIQ(4,+$PIECE(LA7629(0),U,11)_",",99)
+22 IF LA7NVAF=1
SET SITE=$$ID^XUAF4("DMIS",+$PIECE(LA7629(0),U,11))
+23 SET LA7V("NON")=$PIECE(LA7629(0),U,12)
+24 IF LA7V("NON")'=""
SET SITE=LA7V("NON")
+25 ;
+26 SET LA7X=$$NVAF^LA7VHLU2(+$PIECE(LA7629(0),U,2))
+27 IF LA7X=0
SET LA7V("CLNT")=$$GET1^DIQ(4,+$PIECE(LA7629(0),U,2)_",",99)
+28 IF LA7X=1
SET LA7V("CLNT")=$$ID^XUAF4("DMIS",+$PIECE(LA7629(0),U,2))
+29 SET $PIECE(LA7V("CLNT"),U,2)=$$GET1^DIQ(4,+$PIECE(LA7629(0),U,2)_",",.01)
+30 ;
+31 SET LA7X=$$NVAF^LA7VHLU2(+$PIECE(LA7629(0),U,3))
+32 IF LA7X=0
SET LA7V("HOST")=$$GET1^DIQ(4,+$PIECE(LA7629(0),U,3)_",",99)
+33 IF LA7X=1
SET LA7V("HOST")=$$ID^XUAF4("DMIS",+$PIECE(LA7629(0),U,3))
+34 SET $PIECE(LA7V("HOST"),U,2)=$$GET1^DIQ(4,+$PIECE(LA7629(0),U,3)_",",.01)
+35 ;
+36 ; Assuming the receiving institution is the primary site (site with the computer system)
+37 ;
+38 ; Set flag = 0 (multiple PID's/message - build one message)
+39 ; 1 (one PID/message - build multiple messages)
+40 ; 2 (one ORC/message - build multiple messages)
+41 SET LA7SMSG=+$PIECE(LA76248(0),"^",8)
+42 ;
+43 ; Sort tests by patient,UID,test - only need to build one PID, PV1 per patient
+44 ; ^TMP("LA7628",$J, LRDFN, accession UID, ien of shipping manifest specimen entry)
+45 KILL ^TMP("LA7628",$JOB)
+46 SET LA762801=0
+47 FOR
SET LA762801=$ORDER(^LAHM(62.8,LA7628,10,LA762801))
IF 'LA762801
QUIT
Begin DoDot:1
+48 SET X(0)=$GET(^LAHM(62.8,LA7628,10,LA762801,0))
+49 ; Removed from manifest
IF $PIECE(X(0),"^",8)=0
QUIT
+50 ;cmi/maw for LEDI IHS order
IF $GET(LA7SMSG)'=3
Begin DoDot:2
+51 IF $PIECE(X(0),"^")
IF $LENGTH($PIECE(X(0),"^",5))
SET ^TMP("LA7628",$JOB,+$PIECE(X(0),"^"),$PIECE(X(0),"^",5),LA762801)=""
End DoDot:2
+52 ;cmi/maw for LEDI IHS order
IF $GET(LA7SMSG)=3
Begin DoDot:2
+53 IF $PIECE(X(0),"^")
IF $LENGTH($PIECE(X(0),"^",5))
SET ^TMP("LA7628",$JOB,$$GETORDA($PIECE(X(0),"^",5)),$PIECE(X(0),"^",5),LA762801)=""
+54 ;I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$$GETORDA($P(X(0),"^",5))_"~"_$P(X(0),"^",5),LA762801)=""
End DoDot:2
End DoDot:1
+55 KILL LA762801
+56 ;
+57 ; Nothing to send
+58 IF '$DATA(^TMP("LA7628",$JOB))
DO EXIT
QUIT
+59 ;
+60 ;
+61 IF LA7SMSG=0
Begin DoDot:1
+62 DO STARTMSG
+63 IF $GET(HL)
DO EXIT
End DoDot:1
IF $GET(HL)
QUIT
+64 ;
+65 ;S (LRDFN,LRI,LA7PIDSN,LA7ORD)=0 ;ihs/cmi/maw 11/17/2010
+66 ;ihs/cmi/maw 11/17/2010
SET (LRDFN,LRI,LA7PIDSN,LA7ORD,LA7OBRSN)=0
+67 FOR
SET LA7ORD=$ORDER(^TMP("LA7628",$JOB,LA7ORD))
IF 'LA7ORD
QUIT
Begin DoDot:1
+68 NEW LA7PID,LA7PV1,LA7ORDI,LA7ORDD,LA7ORI
+69 IF LA7SMSG=1
DO STARTMSG
IF $GET(HL)
QUIT
+70 SET LA7ORDI=$QUERY(^LRO(69,"C",LA7ORD))
+71 IF $QSUBSCRIPT(LA7ORDI,3)'=LA7ORD
QUIT
+72 SET LA7ORDD=$QSUBSCRIPT(LA7ORDI,4)
+73 SET LA7ORI=$QSUBSCRIPT(LA7ORDI,5)
+74 SET LRDFN=+$GET(^LRO(69,LA7ORDD,1,LA7ORI,0))
+75 ;S LA7ORD=$$GETORD(LRDFN) ;cmi/maw get order number
+76 ;cmi/maw for billing info
IF LA7SMSG<2
DO PID
DO PV1
DO IN1(LA7ORD)
DO GT1(LA7ORD)
+77 ;,INS ;cmi/maw 5/26/2010 insurance added LEDI order
IF LA7SMSG=3
DO STARTMSG
IF $GET(HL)
QUIT
DO PID
DO PV1
DO IN1(LA7ORD)
DO GT1(LA7ORD)
+78 SET LA7UID=""
+79 ;cmi/maw 5/26/2010 insurance
SET (LA7GUAR,LA7DGQ)=0
+80 FOR
SET LA7UID=$ORDER(^TMP("LA7628",$JOB,LA7ORD,LA7UID))
IF LA7UID=""
QUIT
Begin DoDot:2
+81 NEW LA76802,LA7ORC,X
+82 SET X=$QUERY(^LRO(68,"C",LA7UID))
+83 IF $QSUBSCRIPT(X,3)'=LA7UID
QUIT
+84 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+85 ;cmi/maw 3/10/2010 get .1 node as well
FOR I=0,.1,.3,3
SET LA76802(I)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,I))
+86 ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) cmi/maw 3/10/2010 orig line
+87 SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
+88 SET LA76802(5)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
+89 ;,INS ;cmi/maw 5/26/2010 insurance added
IF LA7SMSG=2
DO STARTMSG
IF $GET(HL)
QUIT
DO PID
DO PV1
DO IN1(LA7ORD)
DO GT1(LA7ORD)
+90 ;ihs/cmi/maw 11/16/2010 orig line changed back 04/04/2011 to this
SET (LA7OBRSN,LA762801)=0
+91 ;S LA762801=0 ;ihs/cmi/maw 11/17/2010 mod changed back 04/04/2011
+92 FOR
SET LA762801=$ORDER(^TMP("LA7628",$JOB,LA7ORD,LA7UID,LA762801))
IF 'LA762801
QUIT
Begin DoDot:3
+93 NEW LA7OBR,I
+94 FOR I=0,.1,1,2,5
SET LA762801(I)=$GET(^LAHM(62.8,LA7628,10,LA762801,I))
+95 ;deleted accession
IF $$CHKTST^LA7SMU(LA7628,LA762801)'=0
QUIT
+96 ;cmi/maw 06/23/2010 added DG1 segment for LEDI
DO ORC
DO OBR^LA7VORM3
DO DG1(LA7ORD)
DO OBX(LA7ORD,LA7UID)
End DoDot:3
+97 IF LA7SMSG=2
DO BLG
DO SENDMSG
End DoDot:2
+98 ;cmi/maw 7/1/2010 for ledi insurance
IF LA7SMSG=3
DO BLG
DO SENDMSG
+99 ;cmi/maw 5/26/2010 added for insurance
SET (LA7DGQ,LA7GUAR)=0
+100 IF LA7SMSG<2
DO BLG
+101 IF LA7SMSG=1
DO SENDMSG
End DoDot:1
IF $GET(HL)
QUIT
+102 ;
+103 IF LA7SMSG=0
DO SENDMSG
+104 ;
+105 ;ihs/cmi/maw 9/27/10 below is original ledi code
+106 ;S (LRDFN,LRI,LA7PIDSN)=0
+107 ;F S LRDFN=$O(^TMP("LA7628",$J,LRDFN)) Q:'LRDFN D Q:$G(HL)
+108 ;. N LA7PID,LA7PV1
+109 ;. I LA7SMSG=1 D STARTMSG Q:$G(HL)
+110 ;. S LA7ORD=$$GETORD(LRDFN) ;cmi/maw get order number
+111 ;. I LA7SMSG<2 D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;cmi/maw for billing info
+112 ;. I LA7SMSG=3 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added LEDI order
+113 ;. S LA7UID=""
+114 ;. S (LA7GUAR,LA7DGQ)=0 ;cmi/maw 5/26/2010 insurance
+115 ;. F S LA7UID=$O(^TMP("LA7628",$J,LRDFN,LA7UID)) Q:LA7UID="" D
+116 ;. . N LA76802,LA7ORC,X
+117 ;. . S X=$Q(^LRO(68,"C",$P(LA7UID,"~",2)))
+118 ;. . I $QS(X,3)'=$P(LA7UID,"~",2) Q
+119 ;. . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
+120 ;. . F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) ;cmi/maw 3/10/2010 get .1 node as well
+121 ;. . ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I)) cmi/maw 3/10/2010 orig line
+122 ;. . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
+123 ;. . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
+124 ;. . I LA7SMSG=2 D STARTMSG Q:$G(HL) D PID,PV1,IN1(LA7ORD),GT1(LA7ORD) ;,INS ;cmi/maw 5/26/2010 insurance added
+125 ;. . S (LA7OBRSN,LA762801)=0
+126 ;. . F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D
+127 ;. . . N LA7OBR,I
+128 ;. . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
+129 ;. . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q ;deleted accession
+130 ;. . . D ORC,OBR^LA7VORM3,DG1(LA7ORD),OBX^LA7VORM3 ;cmi/maw 06/23/2010 added DG1 segment for LEDI
+131 ;. . I LA7SMSG=2 D BLG,SENDMSG
+132 ;. . I LA7SMSG=3 D BLG,SENDMSG ;cmi/maw 7/1/2010 for ledi insurance
+133 ;. . S (LA7DGQ,LA7GUAR)=0 ;cmi/maw 5/26/2010 added for insurance
+134 ;. I LA7SMSG<2 D BLG
+135 ;. I LA7SMSG=1 D SENDMSG
+136 ;
+137 ;I LA7SMSG=0 D SENDMSG
+138 ;ihs/cmi/maw end of orig ledi code
+139 ;
EXIT ;
+1 KILL @GBL,^TMP("LA7628",$JOB)
+2 KILL DIC,DFN,EID,HL,HLCOMP,HLFS,HLQ,HLSUB,INT
+3 KILL LA760,LA7628,LA762801,LA7629
+4 KILL LA7ECH,LA7FS,LA7MID,LA7V,LA7HDR,LA7OBRSN,LA7OBXSN,LA7VIEN,LAEVNT
+5 KILL LRAA,LRACC,LRAD,LRAN,LRDFN,LRI
+6 KILL LTST,NLT,NLTIEN,PCNT,RUID,SNIEN,TIEN,X,Y,LA
+7 DO KVAR^LRX
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
+10 ;
+11 ;
STARTMSG ; Create/initialize HL message
+1 ;
+2 KILL @GBL
+3 SET (LA76249,LA7PIDSN)=0
+4 DO STARTMSG^LA7VHLU("LA7V Order to "_SITE,.LA76249)
+5 QUIT
+6 ;
+7 ;
SENDMSG ; File HL7 message with HL and LAB packages.
+1 ;
+2 NEW LA7DATA,LA7ID
+3 SET LA7ID="LA7V HOST "_SITE_"-O-"_$PIECE($GET(LA7628(0)),"^")
+4 ; If no message to send then quit
+5 IF '$DATA(^TMP("HLS",$JOB))
Begin DoDot:1
+6 NEW FDA,LA7ER
+7 IF $GET(LA76248)
SET FDA(1,62.49,LA76249_",",.5)=LA76248
+8 SET FDA(1,62.49,LA76249_",",1)="O"
+9 SET FDA(1,62.49,LA76249_",",2)="E"
+10 SET FDA(1,62.49,LA76249_",",5)=LA7ID
+11 DO FILE^DIE("","FDA(1)","LA7ER(1)")
+12 DO CLEAN^DILF
+13 LOCK -^LAHM(62.49,LA76249)
End DoDot:1
QUIT
+14 ;
+15 DO GEN^LA7VHLU
+16 SET LA7DATA="SM06"_"^"_$$NOW^XLFDT
+17 DO SEUP^LA7SMU($PIECE(LA7628(0),"^"),"1",LA7DATA)
+18 DO UPDT6249
+19 ; Unlock entry
+20 LOCK -^LAHM(62.49,LA76249)
+21 QUIT
+22 ;
+23 ;
UPDT6249 ; update entry in 62.49
+1 ;
+2 NEW FDA,LA7ER
+3 ;
+4 IF $GET(LA76248)
SET FDA(1,62.49,LA76249_",",.5)=LA76248
+5 SET FDA(1,62.49,LA76249_",",1)="O"
+6 IF $PIECE(^LAHM(62.49,LA76249,0),"^",3)'="E"
Begin DoDot:1
+7 IF $GET(HL("APAT"))="AL"
SET FDA(1,62.49,LA76249_",",2)="A"
+8 IF '$TEST
SET FDA(1,62.49,LA76249_",",2)="X"
+9 IF $GET(LA7ERR)
SET FDA(1,62.49,LA76249_",",2)="E"
End DoDot:1
+10 SET FDA(1,62.49,LA76249_",",5)=LA7ID
+11 IF $GET(HL("SAN"))'=""
SET FDA(1,62.49,LA76249_",",102)=HL("SAN")
+12 IF $GET(HL("SAF"))'=""
SET FDA(1,62.49,LA76249_",",103)=HL("SAF")
+13 IF $GET(HL("MTN"))'=""
SET FDA(1,62.49,LA76249_",",108)=HL("MTN")
+14 IF $GET(HL("PID"))'=""
SET FDA(1,62.49,LA76249_",",110)=HL("PID")
+15 IF $GET(HL("VER"))'=""
SET FDA(1,62.49,LA76249_",",111)=HL("VER")
+16 IF $PIECE($GET(LA7MID),"^")'=""
SET FDA(1,62.49,LA76249_",",109)=$PIECE(LA7MID,"^")
+17 IF $PIECE($GET(LA7MID),"^",2)
Begin DoDot:1
+18 SET FDA(1,62.49,LA76249_",",160)=$PIECE(LA7MID,"^",2)
+19 SET FDA(1,62.49,LA76249_",",161)=$PIECE(LA7MID,"^",3)
End DoDot:1
+20 DO FILE^DIE("","FDA(1)","LA7ER(1)")
+21 DO CLEAN^DILF
+22 QUIT
+23 ;
+24 ;
PID ; Patient identification
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
+2 DO DEM^LRX
+3 DO PID^LA7VPID(LRDFN,"",.LA7PID,.LA7PIDSN,.HL,"")
+4 ; DoD/CHCS facilities only use 1st repetition of PID-3.
+5 IF LA7NVAF=1
Begin DoDot:1
+6 SET X=$PIECE(LA7PID(0),LA7FS,4)
SET X=$PIECE(X,$EXTRACT(LA7ECH,2))
+7 SET $PIECE(LA7PID(0),LA7FS,4)=X
End DoDot:1
+8 DO FILESEG^LA7VHLU(GBL,.LA7PID)
+9 DO FILE6249^LA7VHLU(LA76249,.LA7PID)
+10 QUIT
+11 ;
+12 ;
PV1 ; Location information
+1 ; DoD/CHCS facilities do not use PV1 segment
+2 IF LA7NVAF=1
QUIT
+3 ;
+4 DO PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
+5 DO FILESEG^LA7VHLU(GBL,.LA7PV1)
+6 DO FILE6249^LA7VHLU(LA76249,.LA7PV1)
+7 QUIT
+8 ;
+9 ;
ORC ;Order Control
+1 ;
+2 NEW ORC,LA7DATA,LA7DUR,LA7DURU,LA76205,LA762801,LA7X
+3 ;
+4 SET ORC(0)="ORC"
+5 SET ORC(1)=$$ORC1^LA7VORC("NW")
+6 ;
+7 ; Place order number - accession UID
+8 ;S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.3),"^"),LA7FS,LA7ECH)
+9 SET ORC(2)=$$ORC2^LA7VORC($PIECE(LA76802(.1),"^"),LA7FS,LA7ECH)
+10 ;
+11 ; Placer group number - shipping manifest invoice #
+12 SET ORC(4)=$$ORC4^LA7VORC($PIECE(LA7628(0),"^"),LA7FS,LA7ECH)
+13 ;
+14 ; Quantity/Timing
+15 SET (LA76205,LA7DUR,LA7DURU)=""
+16 SET LA762801=0
+17 ;F S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801 D ;ihs/cmi/maw ledi orig
+18 ;ihs/cmi/maw 09/27/2010 ledi new
FOR
SET LA762801=$ORDER(^TMP("LA7628",$JOB,LA7ORD,LA7UID,LA762801))
IF 'LA762801
QUIT
Begin DoDot:1
+19 NEW I,LA760
+20 ; Test duration
+21 FOR I=0,2
SET LA762801(I)=$GET(^LAHM(62.8,LA7628,10,LA762801,I))
+22 IF $PIECE(LA762801(2),"^",4)
Begin DoDot:2
+23 ; collection duration
SET LA7DUR=$PIECE(LA762801(2),"^",6)
+24 ; duration units
SET LA7DURU=$PIECE(LA762801(2),"^",7)
End DoDot:2
+25 ; Test urgency - find highest urgency on accession
+26 SET LA760=+$PIECE(LA762801(0),"^",2)
+27 SET X=+$$GET1^DIQ(68.04,LA760_","_LRAN_","_LRAD_","_LRAA_",",1,"I")
+28 IF 'LA76205
SET LA76205=X
+29 IF LA76205
IF X<LA76205
SET LA76205=X
End DoDot:1
+30 SET ORC(7)=$$ORC7^LA7VORC(LA7DUR,LA7DURU,LA76205,LA7FS,LA7ECH)
+31 ;
+32 ; Order Date/Time - if no order date/time then try draw time
+33 IF $PIECE(LA76802(0),"^",4)
SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(0),"^",4))
+34 IF '$PIECE(LA76802(0),"^",4)
IF $PIECE(LA76802(3),"^")
SET ORC(9)=$$ORC9^LA7VORC($PIECE(LA76802(3),"^"))
+35 ;
+36 ; Ordering provider
+37 SET LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
+38 SET ORC(12)=$$ORC12^LA7VORC($PIECE(LA76802(0),"^",8),$PIECE(LA7X,"^",3),LA7FS,LA7ECH)
+39 ;
+40 ; Entering organization - VA facility
+41 SET ORC(17)=$$ORC17^LA7VORC($PIECE($GET(LA7629(0)),U,2),LA7FS,LA7ECH)
+42 ;
+43 DO BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
+44 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+45 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+46 QUIT
+47 ;
GETORD(DF) ;-- get the order number
+1 NEW LA7QUID
+2 SET LA7QUID=$ORDER(^TMP("LA7628",$JOB,DF,0))
+3 IF $GET(LA7QUID)=""
QUIT ""
+4 QUIT $PIECE(LA7QUID,"~")
+5 ;
GETORDA(UID) ;-- get the order number
+1 NEW X
+2 SET X=$QUERY(^LRO(68,"C",UID))
+3 IF $QSUBSCRIPT(X,3)'=UID
QUIT ""
+4 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+5 ;cmi/maw 3/10/2010 get .1 node as well
FOR I=0,.1,.3,3
SET LA76802(I)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,I))
+6 QUIT $GET(LA76802(.1))
+7 ;
DG1(ORD) ;-- handle the diagnosis
+1 IF $PIECE($$ACCT^LA7VQINS(ORD),U,4)'="T"
QUIT
+2 DO DG1^LA7VQINS(ORD)
+3 QUIT
+4 ;
GT1(ORD) ;-- handle the guarantor
+1 ;ihs/cmi/maw 11/18/2010 changed to send if T or P
IF $PIECE($$ACCT^LA7VQINS(ORD),U,4)="C"
QUIT
+2 DO GAR^LA7VQINS(DFN,,,1)
+3 QUIT
+4 ;
IN1(ORD) ;-- handle insurance
+1 ;Q:$P($$ACCT^LA7VQINS(ORD),U,4)'="T"
+2 ;maybe this is hanging around?
KILL IN1
+3 ;ihs/cmi/maw resets the IN1 segment counter 1/12/2011
SET CNT=0
+4 DO INS^LA7VQINS(1,ORD)
+5 QUIT
+6 ;
OBX(ORD,UID) ;-- build the obx ask at order questions
+1 ;ihs/cmi/maw 11/15/2010 - lets put the local ask at order questions in OBX
DO OBX^LA7VQINS(ORD,UID)
+2 QUIT
BLG ; Billing segment
+1 ;
+2 ;cmi/maw 4/14/2010 no BLG segment, will replace with DG1, IN1, and GT1
QUIT
+3 NEW LA7BLG
+4 ;
+5 IF $PIECE(LA7629(0),U,13)=""
QUIT
+6 SET LA7BLG(0)=$$BLG^LA7VHLU($PIECE(LA7629(0),"^",13),"CO",LA7FS,LA7ECH)
+7 DO FILESEG^LA7VHLU(GBL,.LA7BLG)
+8 DO FILE6249^LA7VHLU(LA76249,.LA7BLG)
+9 QUIT
