| 1 | LR7OF0 ;slc/dcm/JAH - Receive/Route MSG array from OE/RR ;8/10/04
|
|---|
| 2 | ;;5.2;LAB SERVICE;**121,187,223,230,256,291**;Sep 27, 1994
|
|---|
| 3 | ;
|
|---|
| 4 | ;This routine invokes IA #2187
|
|---|
| 5 | ;
|
|---|
| 6 | EN(MSG,MSGTYPE) ;Route all messages from here
|
|---|
| 7 | ;MSG=HL7 message array
|
|---|
| 8 | ;MSGTYPE=LRCH for chem (default), LRAP for AP
|
|---|
| 9 | N X,VISIT,LOC,LOCP,ROOM,DFN,LRPNM,LRXMSG,TEST,TESTN,TYPE,SAMP,SPEC,URG,ORIFN,STARTDT,LRDUZ,PROV,REASON,LRSX,LRLLOC,LROLLOC,LRPRAC,LROUTINE,LRSDT,LRXZ,LRODT,LRSAMP,LRSPEC,LRORDR,LRLB,LRNT,LRSX,LROT,LRCOM,LRI,LRIO,LRJ,LRORD,QUANT
|
|---|
| 10 | N LOCA,LINE,LRHDR,LRORDER,LRORIFN,LRSN,LRSUM,LRSXN,LRTIME,LRTSTS,LRURG,LRSDT,LREND,LRXTYPE,LRXORC,LRDFN,LRDPF,LRPLACR,LRQUANT,LRVERZ,NOBR,NORC
|
|---|
| 11 | S (NOBR,NORC)=1 ;flag to check for OBR, ORC segments
|
|---|
| 12 | D END
|
|---|
| 13 | S LRI=2,LRXORC="ORC"
|
|---|
| 14 | F S LRI=$O(MSG(LRI)) Q:LRI<1 S X=MSG(LRI) I $P(MSG(LRI),"|")="ORC" S LRXORC=MSG(LRI),NORC=0 Q
|
|---|
| 15 | S LRHDR=$$HDRCHK($G(MSG(1)))
|
|---|
| 16 | Q:'$L(LRHDR)
|
|---|
| 17 | I '$$PIDCHK($G(MSG(2))) Q
|
|---|
| 18 | I LRHDR="BHS" K ^TMP("OR",$J,"LRES") Q ;Initialization to begin batch
|
|---|
| 19 | I LRHDR="BTS" D Q ;Clean-up to end batch
|
|---|
| 20 | . D LC
|
|---|
| 21 | . K ^TMP("OR",$J,"LRES")
|
|---|
| 22 | S LINE=2,LRSX=0,LREND=0 F S LINE=$O(MSG(LINE)) Q:LINE<1 S LRXMSG=MSG(LINE) D:$O(MSG(LINE,0)) SPLIT D I LREND Q
|
|---|
| 23 | . I $P(LRXMSG,"|")="PV1" S VISIT=$P(LRXMSG,"|",19),LOC=$P($P(LRXMSG,"|",4),"^"),ROOM=$P($P(LRXMSG,"|",4),"^",2),LOCP=LOC,LOCA=$S(LOCP:$P(^SC(LOCP,0),"^",2),1:"") Q
|
|---|
| 24 | . I $P(LRXMSG,"|")="ORC" S NORC=0,LRXTYPE=$P(LRXMSG,"|",2),LRXORC=LRXMSG I LRXTYPE="NW" D NEW^LR7OF2 Q ;New order, from OE/RR
|
|---|
| 25 | . I $P(LRXMSG,"|")="ORC",LRXTYPE="CA" Q ; D CANC^LR7OF2 S LREND=1 Q ;Cancel order, from OE/RR
|
|---|
| 26 | . I $P(LRXMSG,"|")="OBR" S NOBR=0 I LRXTYPE="CA" D CANC^LR7OF2 Q ;Cancel tests identified in OBR segment
|
|---|
| 27 | . I $P(LRXMSG,"|")="ORC",LRXTYPE="Z@" D PURG1^LR7OF4 S LREND=1 Q ;Purge request-weird
|
|---|
| 28 | . I $P(LRXMSG,"|")="OBR",LRXTYPE="Z@" D PURG^LR7OF4 S LREND=1 Q ;Purge request
|
|---|
| 29 | . I $P(LRXMSG,"|")="ORC",LRXTYPE="XO" D XO^LR7OF2 Q ;Change order
|
|---|
| 30 | . I $P(LRXMSG,"|")="ORC",LRXTYPE="NA" D NUM^LR7OF2 Q ;Backdoor new order, request order number
|
|---|
| 31 | . I $P(LRXMSG,"|")="ORC" S X="Unrecognized order control: "_LRXTYPE D ACK("DE",LRXORC,X) Q
|
|---|
| 32 | . I $P(LRXMSG,"|")="OBR",LRXTYPE="NA" D NA^LR7OF2 Q ;Backdoor assign ORIFN to test
|
|---|
| 33 | . I $P(LRXMSG,"|")="OBR",LRXTYPE="NW" D OBR^LR7OF3 Q
|
|---|
| 34 | . I $P(LRXMSG,"|")="OBR",LRXTYPE="XO" D OBR^LR7OF3 Q
|
|---|
| 35 | . I $P(LRXMSG,"|")="DG1" D DG1^LRBEBA2(LRXMSG) Q ; CIDC
|
|---|
| 36 | . I $P(LRXMSG,"|")="ZCL" D ZCL^LRBEBA2(LRXMSG) Q ; CIDC
|
|---|
| 37 | . I $P(LRXMSG,"|")="NTE" D NTE^LR7OF2 Q ;Order comments
|
|---|
| 38 | . D ACK("DE",LRXORC,"Unrecognized Message segment: "_$P(LRXMSG,"|")) Q
|
|---|
| 39 | I LREND S LREND=0 D END Q
|
|---|
| 40 | I NORC D ACK("OC",LRXORC,"Incomplete transaction...no ORC segment in message!") D END Q
|
|---|
| 41 | I NOBR D ACK("OC",LRXORC,"Incomplete transaction...no OBR segment in message") D END Q
|
|---|
| 42 | I LRXTYPE="NW" D ;Process new order request
|
|---|
| 43 | . N REJECT
|
|---|
| 44 | . S LROLLOC=LOCP,LRLLOC=$S($L($G(LOCA)):LOCA,1:"UNKNOWN"),LRPRAC=PROV,LROUTINE=$P(^LAB(69.9,1,3),"^",2)
|
|---|
| 45 | . I $D(^TMP("OR",$J,"LROT")) S LRSDT=0 D
|
|---|
| 46 | .. F S LRSDT=$O(^TMP("OR",$J,"LROT",LRSDT)) Q:LRSDT<1 S LRXZ="" F LRI=0:0 S LRXZ=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ)) Q:LRXZ="" S LRODT=$P(LRSDT,".") D
|
|---|
| 47 | ... I $G(MSGTYPE)="LRAP" D EN^LR7OFA1 Q
|
|---|
| 48 | ... D EN^LR7OF1
|
|---|
| 49 | . D END,ACK("OK","ORC|OK|"_LRPLACR_"|"_LRORD_";"_LRODT_";"_LRSN_"^"_$S($G(MSG)="BBMSG":"LRBB",$G(MSG)="APMSG":"LRAP",1:"LRCH"),"")
|
|---|
| 50 | Q
|
|---|
| 51 | HDRCHK(HDR) ;Check & return message Header (BHS,MSH,BTS)
|
|---|
| 52 | I '$L(HDR) D ACK("DE",LRXORC,"No Message Header Defined") Q ""
|
|---|
| 53 | I $P(HDR,"|")="BTS" Q "BTS"
|
|---|
| 54 | I $P(HDR,"|")'="BHS",$P(HDR,"|")'="MSH" D ACK("DE",LRXORC,"Invalid Message Header: "_$P(HDR,"|")) Q ""
|
|---|
| 55 | I $P(HDR,"|",2)'="^~\&" D ACK("DE",LRXORC,"Invalid Encoding Characters: "_$P(HDR,"|",2)) Q ""
|
|---|
| 56 | I $P(HDR,"|",3)'="ORDER ENTRY" D ACK("DE",LRXORC,"Unrecognized message source: "_$P(HDR,"|",3)) Q ""
|
|---|
| 57 | I $P(HDR,"|",4)'=DUZ(2) D ACK("DE",LRXORC,"DUZ(2) doesn't match institution in message: "_DUZ(2)_"'="_$P(HDR,"|",4)) Q ""
|
|---|
| 58 | I $P(HDR,"|")="MSH",$P(HDR,"|",9)'="ORM"&($P(HDR,"|",9)'="ORR") D ACK("DE",LRXORC,"Unrecognized Message type: "_$P(HDR,"|",9)) Q ""
|
|---|
| 59 | Q $P(HDR,"|")
|
|---|
| 60 | ;
|
|---|
| 61 | PIDCHK(PID) ;Check PID & setup patient variables (DFN,LRDPF,LRDFN,LRPNM)
|
|---|
| 62 | I '$L(PID) D ACK("DE",LRXORC,"No Patient ID in message") Q 0
|
|---|
| 63 | I $P(PID,"|")'="PID" D ACK("DE",LRXORC,"Invalid (PID) message header: "_$P(X,"|")) Q 0
|
|---|
| 64 | I '$L($P(PID,"|",6)) D ACK("DE",LRXORC,"No Patient Name") Q 0
|
|---|
| 65 | S DFN=$S($P(PID,"|",4):$P(PID,"|",4),1:+$P(PID,"|",5)),LRDPF=$S($P(PID,"|",4):"2^DPT(",1:$P(@("^"_$P($P(PID,"|",5),";",2)_"0)"),"^",2)_"^"_$P($P(PID,"|",5),";",2)),LRPNM=$P(PID,"|",6),LRDFN=$$LRDFN^LR7OR1(+DFN,$P(LRDPF,"^",2))
|
|---|
| 66 | I 'LRDFN D END^LRDPA I LRDFN<1 D ACK("DE",LRXORC,"Invalid LRDFN") Q 0
|
|---|
| 67 | I '$D(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")) D ACK("DE",LRXORC,"Patient identifier: "_LRDFN_" not found in "_LRDPF_" file") Q 0
|
|---|
| 68 | Q 1
|
|---|
| 69 | ;
|
|---|
| 70 | LC ;Print to LC Lab device
|
|---|
| 71 | N LRSDT,LRXZ,CTR,LRODT,LRSN,LRPTR
|
|---|
| 72 | S LRSDT=0
|
|---|
| 73 | F S LRSDT=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT)) Q:'LRSDT S LRXZ="" F S LRXZ=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ)) Q:LRXZ="" D
|
|---|
| 74 | . S CTR=0 F S CTR=$O(^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,CTR)) Q:'CTR S X=^(CTR) D
|
|---|
| 75 | .. S LRPTR(LRXZ,$P(X,"^",2),$P(X,"^",3))=""
|
|---|
| 76 | S LRODT=0 F S LRODT=$O(LRPTR("LC",LRODT)) Q:'LRODT S LRSN=0 F S LRSN=$O(LRPTR("LC",LRODT,LRSN)) Q:'LRSN D
|
|---|
| 77 | . S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2) S:ION="" ION=$P(^LAB(69.9,1,3),U,4) I ION]"" D ^LROW2P
|
|---|
| 78 | S LRODT=0 F S LRODT=$O(LRPTR("I",LRODT)) Q:'LRODT S LRSN=0 F S LRSN=$O(LRPTR("I",LRODT,LRSN)) Q:'LRSN D
|
|---|
| 79 | . S ION=$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,3) I ION]"" D ^LROW2P
|
|---|
| 80 | Q
|
|---|
| 81 | ACK(TYPE,MSG3,COMMENT) ;Send back ok or nok to OE/RR
|
|---|
| 82 | ;TYPE=Message control
|
|---|
| 83 | ;COMMENT=Comment to be passed back
|
|---|
| 84 | ;MSG3=contents of MSG(3) containing the ORC segment
|
|---|
| 85 | N LRMSG,ARRAY,X8,VAR
|
|---|
| 86 | I TYPE="DE" S VAR("XQY0")="" D EN^ORERR("BAD msg xchng OE/RR->LAB:"_$G(COMMENT),.MSG,.VAR) S:$P($G(MSG3),"|",2)="NW" TYPE="OC" ;Trap problem message and send back to OE/RR as an OC type
|
|---|
| 87 | S LRMSG(1)=$$MSH^LR7OU0("ORR")
|
|---|
| 88 | S LRMSG(2)=$G(MSG(2))
|
|---|
| 89 | S LRMSG(3)=$G(MSG3),$P(LRMSG(3),"|",2)=TYPE
|
|---|
| 90 | I $O(REJECT(0)),$O(^ORD(100.03,"C","LRDUP",0)) S X8=$$DC1^LROR6($O(^(0)),"Already ordered for this specimen, type and time"),$P(LRMSG(3),"|",2)="OC",$P(LRMSG(3),"|",4)="",$P(LRMSG(3),"|",17)=X8
|
|---|
| 91 | I $D(COMMENT) N MSG S MSG="LRMSG",ARRAY(1)=COMMENT D NTE^LR7OU01(1,"L","ARRAY(",4)
|
|---|
| 92 | S LRMSG="LRMSG"
|
|---|
| 93 | D MSG^XQOR("LR7O CH EVSEND OR",.LRMSG) ;Lab accepts, returns Order #
|
|---|
| 94 | Q
|
|---|
| 95 | SPLIT ;Build array for long segment
|
|---|
| 96 | N I
|
|---|
| 97 | S I=0 F S I=$O(MSG(LINE,I)) Q:I<1 S LRXMSG(I)=MSG(LINE,I)
|
|---|
| 98 | Q
|
|---|
| 99 | END ;Clean-up and get out
|
|---|
| 100 | K ^TMP("OR",$J,"LROT"),^("COM")
|
|---|
| 101 | Q
|
|---|
