LA7VRIN1 ;VA/DALOI/JMC - Process Incoming UI Msgs, continued ; 01/14/99
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;NOV 01, 1997
; This routine is a continuation of LA7VIN and is only called from there.
; It is called with each message found in the incoming queue.
Q
;
NXTMSG ;
N FDA,LA7ABORT,LA7CNT,LA7END,LA7ERR
N LA7INDX,LA7QUIT,LA7SEG,LA7STYP
;
S LA7ERR=""
S (LA7ABORT,LA7CNT,LA7END,LA7INDX,LA7QUIT,LA7SEQ)=0
S DT=$$DT^XLFDT
S LA7ID="UNKNOWN-I-"
;
; Message built but no text.
I '$O(^LAHM(62.49,LA76249,150,0)) D Q
. S (LA7ABORT,LA7ERR)=6
. D CREATE^LA7LOG(LA7ERR)
. D SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN")
;
; Process message segments
; Lab currently does not accept segments beginning with the letter "Z"
; which are reserved for locally-defined messages. "Z" segments will be
; ignored by this software.
F S LA7END=$$GETSEG^LA7VHLU2(LA76249,.LA7INDX,.LA7SEG) Q:LA7END!(LA7ABORT) D
. S LA7STYP=$E(LA7SEG(0),1,3) ; Segment type
. I $E(LA7STYP,1)="Z" Q
. ; Not a valid segment type
. I LA7STYP'?2U1UN D Q
. . S LA7ERR=34
. . D CREATE^LA7LOG(LA7ERR)
. ; Segment encoded wrong - field separator does not match
. I "MSH^FSH^BHS^"'[(LA7STYP_"^"),$E(LA7SEG(0),4)'=LA7FS D Q
. . S LA7ERR=35
. . D CREATE^LA7LOG(LA7ERR)
. I $T(@LA7STYP)="" Q ; No processing logic for this segment type
. D @LA7STYP
;
; Set id if only MSH segment received.
I LA7SEQ<5 D
. D SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN")
;
; Set status to purgeable if no errors.
I $P($G(^LAHM(62.49,LA76249,0)),"^",3)'="E" D
. S FDA(1,62.49,LA76249_",",2)="X"
. D FILE^DIE("","FDA(1)","LA7ERR(1)")
;
; Store identifier's found in message.
D UPID^LA7VHLU1(LA76249)
;
; Send new result alert for ORU messages if turned on.
; Currently only on LEDI (10) type interfaces.
I $G(LA7MTYP)="ORU",$D(^LAHM(62.48,+$G(LA76248),20,"B",1)) D
. I LA7INTYP=10,$D(^TMP("LA7-ORU",$J,LA76248)) D XQA^LA7UXQA(1,LA76248)
;
; Send new order alert for ORM messages if turned on.
I $G(LA7MTYP)="ORM",$D(^LAHM(62.48,+$G(LA76248),20,"B",3)) D
. N LA7ROOT
. S LA7ROOT="^TMP(""LA7-ORM"",$J)"
. F S LA7ROOT=$Q(@LA7ROOT) Q:$QS(LA7ROOT,1)'="LA7-ORM"!($QS(LA7ROOT,2)'=$J) D
. . D XQA^LA7UXQA(3,$QS(LA7ROOT,3),"",$QS(LA7ROOT,4),"",$QS(LA7ROOT,5))
;
; Cleanup shipping config test info used to process orders
I $G(LA7MTYP)="ORM" K ^TMP("LA7TC",$J)
;
; If amended results received then send bulletins
I $D(^TMP("LA7 AMENDED RESULTS",$J)) D SENDARB^LA7VRN1A
;
; If cancelled orders received then send bulletins
I $D(^TMP("LA7 ORDER STATUS",$J)) D SENDOSB^LA7VRN1A
;
; If units/normals changed then send bulletins
I $D(^TMP("LA7 UNITS/NORMALS CHANGED",$J)) D SENDUNCB^LA7VRN1A
;
; If abnormal/critical results then send bulletins
I $D(^TMP("LA7 ABNORMAL RESULTS",$J)) D SENDACB^LA7VRN1A
;
D KILLMSH
;
Q
;
;
MSA ;; Process MSA segment
;
D KILLMSA
;
D MSA^LA7VRIN3
;
; Set sequence flag
S LA7SEQ=5
Q
;
;
BSH ;; Process various HL7 header segments
FSH ;;
MSH ;;
D KILLMSH
;
D MSH^LA7VRIN2
;
; Set sequence flag
S LA7SEQ=1
Q
;
;
NTE ;; Process NTE segment
;
I LA7SEQ<30 D Q
. ; Put code to log error - no OBR/OBX segment
;
; Flag set that there was problem with OBR segment,
; skip associated NTE segments that follow OBR/OBX segments
I LA7QUIT=2 Q
;
I LA7MTYP="ORU" D NTE^LA7VRIN2
I LA7MTYP="ORM" D NTE^LA7VRIN2
I LA7MTYP="ORR" D NTE^LA7VRIN2
;
Q
;
;
OBR ;; Process OBR segment
;
D KILLOBR
;
; Clear flag to process this segment
I LA7QUIT=2 S LA7QUIT=0
;
; If not UI interface and no PID segment
I LA7INTYP'=1,LA7SEQ<10 D Q
. S (LA7ABORT,LA7ERR)=46
. D CREATE^LA7LOG(LA7ERR)
;
I LA7MTYP="ORR" D OBR^LA7VRIN4
I LA7MTYP="ORU" D OBR^LA7VRIN4
I LA7MTYP="ORM" D OBR^LA7VORM
;
; Set sequence flag
S LA7SEQ=30
Q
;
;
OBX ;; Process OBX segment
;
D KILLOBX
;
; No OBR segment, can't process OBX
I LA7SEQ<30 D Q
. S (LA7ABORT,LA7ERR)=9
. D CREATE^LA7LOG(LA7ERR)
;
; Flag set that there was problem with OBR segment,
; skip associated OBX segments that follow OBR segment
I LA7QUIT=2 Q
;
; Process result messages (ORU).
I LA7MTYP="ORU" D
. ; Process "CH" subscript results.
. I $G(LA7SS)="CH" D
. . I '$G(LA7ISQN) Q ; No place to store results
. . D OBX^LA7VRIN5
. ;
. ; Process "AP" subscript results.
. ;I $G(LA7SS)="AP",$L($T(OBX^LA7VIN6)) D OBX^LA7VIN6
. ;
. ; Process "MI" subscript results.
. ;I $G(LA7SS)="MI" D OBX^LA7VIN7
. ;
. ; Process "BB" subscript results.
. ;I $G(LA7SS)="BB",$L($T(OBX^LA7VIN8)) D OBX^LA7VIN8
. ;
. ; Update test status on manifest
. I $G(LA7628),LA7UID'="",$G(LA7OTST) D UTS^LA7VHLU1(LA7628,LA7UID,LA7OTST)
;
; Process results that accompany orders
I LA7MTYP="ORM" D OBX^LA7VRIN5
;
; Set sequence flag
S LA7SEQ=40
Q
;
;
ORC ;; Process ORC segment
;
D KILLORC
;
; If not UI interface and no PID segment
I LA7INTYP'=1,LA7SEQ<10 D Q
. S (LA7ABORT,LA7ERR)=46
. D CREATE^LA7LOG(LA7ERR)
;
D ORC^LA7VRIN2
;
; Set sequence flag
S LA7SEQ=20
Q
;
;
PID ;; Process PID segment
;
D KILLPID
;
; no MSH segment
I LA7SEQ<1 D Q
. S (LA7ABORT,LA7ERR)=7
. D CREATE^LA7LOG(LA7ERR)
;
; Clear flag to process this segment
I LA7QUIT=1 S LA7QUIT=0
;
D PID^LA7VRIN2
;
; Set sequence flag
S LA7SEQ=10
Q
;
;
PV1 ;; Process PV1 segment
;
D KILLPV1
;
; no PID segment
I LA7SEQ<10 D Q
. S (LA7ABORT,LA7ERR)=46
. D CREATE^LA7LOG(LA7ERR)
;
D PV1^LA7VRIN2
;
; Set sequence flag
S LA7SEQ=11
Q
;
;
; The section below is designed to clean up variables that are created
; during the processing of a segment type and any created by processing
; of segments that are within the message definition.
;
KILLMSH ; Clean up variables used by MSH and following segments
K LA7CSITE,LA7CS,LA7ECH,LA7FS,LA7HLV,LA7MEDT,LA7MID,LA7MTYP
K LA7RAP,LA7RFAC,LA7SAP,LA7SEQ,LA7SFAC
K ^TMP("LA7-ID",$J),^TMP("LA7-ORM",$J),^TMP("LA7-ORU",$J)
;
KILLMSA ; Clean up variables used by MSA and following segments
K LA7MSATM
;
KILLPID ; Clean up variables used by PID and following segments
K DFN
K LA7DOB,LA7ICN,LA7PNM,LA7PRACE,LA7PTID2,LA7PTID3,LA7PTID4
K LA7SEX,LA7SPID,LA7SSN
K LRDFN,LRTDFN
;
KILLPV1 ; Clean up variables used by PV1 and following segments
K LA7LOC,LA7SPV1
;
KILLORC ; Clean up variables used by ORC and following segments
K LA7628,LA7629
K LA7CSITE,LA7DUR,LA7DURU,LA7ODUR,LA7ODURU,LA7EOL,LA7OCR,LA7ORDT
K LA7OTYPE,LA7OUR,LA7PEB,LA7PON,LA7POP,LA7PVB,LA7SM
;
KILLOBR ; Clean up variables used by OBR and following segments
K LA70070,LA760,LA761,LA762,LA7624,LA7696
K LA7AA,LA7AD,LA7ACC,LA7AN,LA7CDT,LA7FID,LA7ISQN,LA7LWL,LA7ONLT,LA7OTST
K LA7POC,LA7SAC,LA7SID,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7UID,LA7UR
;
KILLOBX ; Clean up variables used by OBX and following segments
K LA7ORS,LA7RLNC,LA7RMK,LA7RNLT,LA7RO,LA7SOBX
;
KILLBLG ;Clean up variables used by BLG and following segments
;
Q
LA7VRIN1 ;VA/DALOI/JMC - Process Incoming UI Msgs, continued ; 01/14/99
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;NOV 01, 1997
+2 ; This routine is a continuation of LA7VIN and is only called from there.
+3 ; It is called with each message found in the incoming queue.
+4 QUIT
+5 ;
NXTMSG ;
+1 NEW FDA,LA7ABORT,LA7CNT,LA7END,LA7ERR
+2 NEW LA7INDX,LA7QUIT,LA7SEG,LA7STYP
+3 ;
+4 SET LA7ERR=""
+5 SET (LA7ABORT,LA7CNT,LA7END,LA7INDX,LA7QUIT,LA7SEQ)=0
+6 SET DT=$$DT^XLFDT
+7 SET LA7ID="UNKNOWN-I-"
+8 ;
+9 ; Message built but no text.
+10 IF '$ORDER(^LAHM(62.49,LA76249,150,0))
Begin DoDot:1
+11 SET (LA7ABORT,LA7ERR)=6
+12 DO CREATE^LA7LOG(LA7ERR)
+13 DO SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN")
End DoDot:1
QUIT
+14 ;
+15 ; Process message segments
+16 ; Lab currently does not accept segments beginning with the letter "Z"
+17 ; which are reserved for locally-defined messages. "Z" segments will be
+18 ; ignored by this software.
+19 FOR
SET LA7END=$$GETSEG^LA7VHLU2(LA76249,.LA7INDX,.LA7SEG)
IF LA7END!(LA7ABORT)
QUIT
Begin DoDot:1
+20 ; Segment type
SET LA7STYP=$EXTRACT(LA7SEG(0),1,3)
+21 IF $EXTRACT(LA7STYP,1)="Z"
QUIT
+22 ; Not a valid segment type
+23 IF LA7STYP'?2U1UN
Begin DoDot:2
+24 SET LA7ERR=34
+25 DO CREATE^LA7LOG(LA7ERR)
End DoDot:2
QUIT
+26 ; Segment encoded wrong - field separator does not match
+27 IF "MSH^FSH^BHS^"'[(LA7STYP_"^")
IF $EXTRACT(LA7SEG(0),4)'=LA7FS
Begin DoDot:2
+28 SET LA7ERR=35
+29 DO CREATE^LA7LOG(LA7ERR)
End DoDot:2
QUIT
+30 ; No processing logic for this segment type
IF $TEXT(@LA7STYP)=""
QUIT
+31 DO @LA7STYP
End DoDot:1
+32 ;
+33 ; Set id if only MSH segment received.
+34 IF LA7SEQ<5
Begin DoDot:1
+35 DO SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN")
End DoDot:1
+36 ;
+37 ; Set status to purgeable if no errors.
+38 IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="E"
Begin DoDot:1
+39 SET FDA(1,62.49,LA76249_",",2)="X"
+40 DO FILE^DIE("","FDA(1)","LA7ERR(1)")
End DoDot:1
+41 ;
+42 ; Store identifier's found in message.
+43 DO UPID^LA7VHLU1(LA76249)
+44 ;
+45 ; Send new result alert for ORU messages if turned on.
+46 ; Currently only on LEDI (10) type interfaces.
+47 IF $GET(LA7MTYP)="ORU"
IF $DATA(^LAHM(62.48,+$GET(LA76248),20,"B",1))
Begin DoDot:1
+48 IF LA7INTYP=10
IF $DATA(^TMP("LA7-ORU",$JOB,LA76248))
DO XQA^LA7UXQA(1,LA76248)
End DoDot:1
+49 ;
+50 ; Send new order alert for ORM messages if turned on.
+51 IF $GET(LA7MTYP)="ORM"
IF $DATA(^LAHM(62.48,+$GET(LA76248),20,"B",3))
Begin DoDot:1
+52 NEW LA7ROOT
+53 SET LA7ROOT="^TMP(""LA7-ORM"",$J)"
+54 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
IF $QSUBSCRIPT(LA7ROOT,1)'="LA7-ORM"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
QUIT
Begin DoDot:2
+55 DO XQA^LA7UXQA(3,$QSUBSCRIPT(LA7ROOT,3),"",$QSUBSCRIPT(LA7ROOT,4),"",$QSUBSCRIPT(LA7ROOT,5))
End DoDot:2
End DoDot:1
+56 ;
+57 ; Cleanup shipping config test info used to process orders
+58 IF $GET(LA7MTYP)="ORM"
KILL ^TMP("LA7TC",$JOB)
+59 ;
+60 ; If amended results received then send bulletins
+61 IF $DATA(^TMP("LA7 AMENDED RESULTS",$JOB))
DO SENDARB^LA7VRN1A
+62 ;
+63 ; If cancelled orders received then send bulletins
+64 IF $DATA(^TMP("LA7 ORDER STATUS",$JOB))
DO SENDOSB^LA7VRN1A
+65 ;
+66 ; If units/normals changed then send bulletins
+67 IF $DATA(^TMP("LA7 UNITS/NORMALS CHANGED",$JOB))
DO SENDUNCB^LA7VRN1A
+68 ;
+69 ; If abnormal/critical results then send bulletins
+70 IF $DATA(^TMP("LA7 ABNORMAL RESULTS",$JOB))
DO SENDACB^LA7VRN1A
+71 ;
+72 DO KILLMSH
+73 ;
+74 QUIT
+75 ;
+76 ;
MSA ;; Process MSA segment
+1 ;
+2 DO KILLMSA
+3 ;
+4 DO MSA^LA7VRIN3
+5 ;
+6 ; Set sequence flag
+7 SET LA7SEQ=5
+8 QUIT
+9 ;
+10 ;
BSH ;; Process various HL7 header segments
FSH ;;
MSH ;;
+1 DO KILLMSH
+2 ;
+3 DO MSH^LA7VRIN2
+4 ;
+5 ; Set sequence flag
+6 SET LA7SEQ=1
+7 QUIT
+8 ;
+9 ;
NTE ;; Process NTE segment
+1 ;
+2 IF LA7SEQ<30
Begin DoDot:1
+3 ; Put code to log error - no OBR/OBX segment
End DoDot:1
QUIT
+4 ;
+5 ; Flag set that there was problem with OBR segment,
+6 ; skip associated NTE segments that follow OBR/OBX segments
+7 IF LA7QUIT=2
QUIT
+8 ;
+9 IF LA7MTYP="ORU"
DO NTE^LA7VRIN2
+10 IF LA7MTYP="ORM"
DO NTE^LA7VRIN2
+11 IF LA7MTYP="ORR"
DO NTE^LA7VRIN2
+12 ;
+13 QUIT
+14 ;
+15 ;
OBR ;; Process OBR segment
+1 ;
+2 DO KILLOBR
+3 ;
+4 ; Clear flag to process this segment
+5 IF LA7QUIT=2
SET LA7QUIT=0
+6 ;
+7 ; If not UI interface and no PID segment
+8 IF LA7INTYP'=1
IF LA7SEQ<10
Begin DoDot:1
+9 SET (LA7ABORT,LA7ERR)=46
+10 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+11 ;
+12 IF LA7MTYP="ORR"
DO OBR^LA7VRIN4
+13 IF LA7MTYP="ORU"
DO OBR^LA7VRIN4
+14 IF LA7MTYP="ORM"
DO OBR^LA7VORM
+15 ;
+16 ; Set sequence flag
+17 SET LA7SEQ=30
+18 QUIT
+19 ;
+20 ;
OBX ;; Process OBX segment
+1 ;
+2 DO KILLOBX
+3 ;
+4 ; No OBR segment, can't process OBX
+5 IF LA7SEQ<30
Begin DoDot:1
+6 SET (LA7ABORT,LA7ERR)=9
+7 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+8 ;
+9 ; Flag set that there was problem with OBR segment,
+10 ; skip associated OBX segments that follow OBR segment
+11 IF LA7QUIT=2
QUIT
+12 ;
+13 ; Process result messages (ORU).
+14 IF LA7MTYP="ORU"
Begin DoDot:1
+15 ; Process "CH" subscript results.
+16 IF $GET(LA7SS)="CH"
Begin DoDot:2
+17 ; No place to store results
IF '$GET(LA7ISQN)
QUIT
+18 DO OBX^LA7VRIN5
End DoDot:2
+19 ;
+20 ; Process "AP" subscript results.
+21 ;I $G(LA7SS)="AP",$L($T(OBX^LA7VIN6)) D OBX^LA7VIN6
+22 ;
+23 ; Process "MI" subscript results.
+24 ;I $G(LA7SS)="MI" D OBX^LA7VIN7
+25 ;
+26 ; Process "BB" subscript results.
+27 ;I $G(LA7SS)="BB",$L($T(OBX^LA7VIN8)) D OBX^LA7VIN8
+28 ;
+29 ; Update test status on manifest
+30 IF $GET(LA7628)
IF LA7UID'=""
IF $GET(LA7OTST)
DO UTS^LA7VHLU1(LA7628,LA7UID,LA7OTST)
End DoDot:1
+31 ;
+32 ; Process results that accompany orders
+33 IF LA7MTYP="ORM"
DO OBX^LA7VRIN5
+34 ;
+35 ; Set sequence flag
+36 SET LA7SEQ=40
+37 QUIT
+38 ;
+39 ;
ORC ;; Process ORC segment
+1 ;
+2 DO KILLORC
+3 ;
+4 ; If not UI interface and no PID segment
+5 IF LA7INTYP'=1
IF LA7SEQ<10
Begin DoDot:1
+6 SET (LA7ABORT,LA7ERR)=46
+7 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+8 ;
+9 DO ORC^LA7VRIN2
+10 ;
+11 ; Set sequence flag
+12 SET LA7SEQ=20
+13 QUIT
+14 ;
+15 ;
PID ;; Process PID segment
+1 ;
+2 DO KILLPID
+3 ;
+4 ; no MSH segment
+5 IF LA7SEQ<1
Begin DoDot:1
+6 SET (LA7ABORT,LA7ERR)=7
+7 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+8 ;
+9 ; Clear flag to process this segment
+10 IF LA7QUIT=1
SET LA7QUIT=0
+11 ;
+12 DO PID^LA7VRIN2
+13 ;
+14 ; Set sequence flag
+15 SET LA7SEQ=10
+16 QUIT
+17 ;
+18 ;
PV1 ;; Process PV1 segment
+1 ;
+2 DO KILLPV1
+3 ;
+4 ; no PID segment
+5 IF LA7SEQ<10
Begin DoDot:1
+6 SET (LA7ABORT,LA7ERR)=46
+7 DO CREATE^LA7LOG(LA7ERR)
End DoDot:1
QUIT
+8 ;
+9 DO PV1^LA7VRIN2
+10 ;
+11 ; Set sequence flag
+12 SET LA7SEQ=11
+13 QUIT
+14 ;
+15 ;
+16 ; The section below is designed to clean up variables that are created
+17 ; during the processing of a segment type and any created by processing
+18 ; of segments that are within the message definition.
+19 ;
KILLMSH ; Clean up variables used by MSH and following segments
+1 KILL LA7CSITE,LA7CS,LA7ECH,LA7FS,LA7HLV,LA7MEDT,LA7MID,LA7MTYP
+2 KILL LA7RAP,LA7RFAC,LA7SAP,LA7SEQ,LA7SFAC
+3 KILL ^TMP("LA7-ID",$JOB),^TMP("LA7-ORM",$JOB),^TMP("LA7-ORU",$JOB)
+4 ;
KILLMSA ; Clean up variables used by MSA and following segments
+1 KILL LA7MSATM
+2 ;
KILLPID ; Clean up variables used by PID and following segments
+1 KILL DFN
+2 KILL LA7DOB,LA7ICN,LA7PNM,LA7PRACE,LA7PTID2,LA7PTID3,LA7PTID4
+3 KILL LA7SEX,LA7SPID,LA7SSN
+4 KILL LRDFN,LRTDFN
+5 ;
KILLPV1 ; Clean up variables used by PV1 and following segments
+1 KILL LA7LOC,LA7SPV1
+2 ;
KILLORC ; Clean up variables used by ORC and following segments
+1 KILL LA7628,LA7629
+2 KILL LA7CSITE,LA7DUR,LA7DURU,LA7ODUR,LA7ODURU,LA7EOL,LA7OCR,LA7ORDT
+3 KILL LA7OTYPE,LA7OUR,LA7PEB,LA7PON,LA7POP,LA7PVB,LA7SM
+4 ;
KILLOBR ; Clean up variables used by OBR and following segments
+1 KILL LA70070,LA760,LA761,LA762,LA7624,LA7696
+2 KILL LA7AA,LA7AD,LA7ACC,LA7AN,LA7CDT,LA7FID,LA7ISQN,LA7LWL,LA7ONLT,LA7OTST
+3 KILL LA7POC,LA7SAC,LA7SID,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7UID,LA7UR
+4 ;
KILLOBX ; Clean up variables used by OBX and following segments
+1 KILL LA7ORS,LA7RLNC,LA7RMK,LA7RNLT,LA7RO,LA7SOBX
+2 ;
KILLBLG ;Clean up variables used by BLG and following segments
+1 ;
+2 QUIT
