LA7VIN1 ;DALOI/JMC - Process Incoming UI Msgs, continued ;04/06/16 15:51
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,88**;Sep 27, 1994;Build 10
;
; 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,LA7AERR,LA7CNT,LA7END,LA7ERR
N LA7INDX,LA7KILAH,LA7QUIT,LA7SEG,LA7STYP
;
S (LA7AERR,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",1)
;
; 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
;
; Send HL7 Application Acknowledgment message for selected interfaces/message types
I LA7MTYP="ORM",LA7INTYP=10 D SENDACK
I LA7MTYP="ORU",LA7INTYP=1,LA7AAT(1)'="" D
. I $G(LA76249("AR")) Q ; Auto Release will send application ACK.
. I LA7AAT(1)="NE" Q
. I LA7AAT(1)="SU",$G(LA7ERR)'="" Q
. I LA7AAT(1)="ER",$G(LA7ERR)="" Q
. D SENDACK
;
; Set id if only MSH segment received.
I LA7SEQ<5 D
. D SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN",1)
;
; 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.
I $G(LA7MTYP)="ORU",$D(^LAHM(62.48,+$G(LA76248),20,"B",1)) D
. N LA7MSG,LA7ROOT
. S LA7ROOT="^TMP(""LA7-ORU"",$J)"
. F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'="LA7-ORU"!($QS(LA7ROOT,2)'=$J) D
. . S LA7MSG(1)=$S($QS(LA7ROOT,5)="CH":"Chemistry/Hematology",$QS(LA7ROOT,5)="MI":"Microbiology",$QS(LA7ROOT,5)="SP":"Surgical Pathology",$QS(LA7ROOT,5)="CY":"Cytology",$QS(LA7ROOT,5)="EM":"Electron Microscopy",1:"")
. . I LA7MSG(1)'="" S LA7MSG(1)=" "_LA7MSG(1)
. . S LA7MSG="Lab Msg - New"_LA7MSG(1)_" results received for "_$P($G(^LAHM(62.48,$QS(LA7ROOT,3),0),"UNKNOWN"),"^")_"^"_$QS(LA7ROOT,5)
. . D XQA^LA7UXQA(1,$QS(LA7ROOT,3),"","",LA7MSG,"",0)
;
; 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: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))
;
; Create performing lab comment for entries in LAH.
;I $D(^TMP("LA7-PL-NTE",$J)) D PL^LA7VIN1B
;
; 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^LA7VIN1A
;
; If cancelled orders received then send bulletins
I $D(^TMP("LA7 ORDER STATUS",$J)) D SENDOSB^LA7VIN1B
;
; If units/normals changed then send bulletins
I $D(^TMP("LA7 UNITS/NORMALS CHANGED",$J)) D SENDUNCB^LA7VIN1A
;
; If abnormal/critical results then send bulletins
I $D(^TMP("LA7 ABNORMAL RESULTS",$J)) D SENDACB^LA7VIN1A
;
; If auto release move cross-references to ^LAH from ^TMP to signal available for processing if no error.
I $D(^TMP("LA7 AR",$J)),$P($G(^LAHM(62.49,LA76249,0)),"^",3)'="E" M ^LAH=^TMP("LA7 AR",$J)
;
D KILLMSH
;
Q
;
;
MSA ;; Process MSA segment
;
D KILLMSA
;
D MSA^LA7VIN3
;
; Set sequence flag
S LA7SEQ=5
Q
;
;
BSH ;; Process various HL7 header segments
FSH ;;
MSH ;;
D KILLMSH
;
D MSH^LA7VIN2
;
; 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^LA7VIN2
I LA7MTYP="ORM" D NTE^LA7VIN2
I LA7MTYP="ORR" D NTE^LA7VIN2
;
Q
;
;
OBR ;; Process OBR segment
;
D KILLOBR
;
; Clear flag to process this segment
I LA7QUIT>0 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^LA7VIN4
I LA7MTYP="ORU" D OBR^LA7VIN4
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
. I '$G(LA7ISQN) Q ; No place to store results
. ; Process "CH" subscript results.
. I $G(LA7SS)="CH" D OBX^LA7VIN5
. ;
. ; Process AP subscripts results. "AU" not currently supported
. I $G(LA7SS)?1(1"SP",1"CY",1"EM") D OBX^LA7VIN7
. ;
. ; Process "MI" subscript results.
. I $G(LA7SS)="MI" D OBX^LA7VIN7
. ;
. ; Process "BB" subscript results - not supported
. ;
. ; 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^LA7VIN5
;
; 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^LA7VIN2
;
; 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^LA7VIN2
;
; 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^LA7VIN2
;
; Set sequence flag
S LA7SEQ=11
Q
;
;
SENDACK ; Send HL7 Application Acknowledgment message for selected interfaces/message types
;
;ZEXCEPT: LA7624,LA76248,LA76249,LA7AERR,LA7ERR,LA7UID,PNM,SSN
;
N LA
S LA(62.48)=LA76248,LA(62.49)=LA76249
I $G(LA7624) S LA(62.4)=LA7624
S LA("ACK")=$S(+LA7ERR:"AE",1:"AA")
I $G(LA7UID)'="" S LA("ID",1)=LA7UID
I $G(LA7PNM)'="" S LA("ID",2)=LA7PNM
I $G(LA7SSN)'="" S LA("ID",3)=LA7SSN
I LA7AERR="" S LA7AERR=LA7ERR
I LA7AERR>0,$P(LA7AERR,"^",2)="" S $P(LA7AERR,"^",2)="See VistA Lab Universal Interface Log for specific error"
S LA("MSG")=$P(LA7AERR,"^",2)
;
; Build info for ERR segment
D BLDERR^LA7VHLU8(.LA,LA7AERR)
;
D ACK^LA7VHLU8(.LA)
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 LA7AAT,LA7CSITE,LA7CS,LA7ECH,LA7FS,LA7HLV,LA7MEDT,LA7MID,LA7MTYP
K LA7RAP,LA7RFAC,LA7SAP,LA7SEQ,LA7SFAC
K ^TMP("LA7 AR",$J),^TMP("LA7-ID",$J),^TMP("LA7-ORM",$J),^TMP("LA7-ORU",$J),^TMP("LA7-PL-NTE",$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,LAPSUBID
;
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,LA7ARI,LA7CDT,LA7FID,LA7ISQN,LA7LWL,LA7ONLT,LA7OTST
K LA7POC,LA7PRI,LA7RSDT,LA7SAC,LA7SID,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7TECH,LA7UID,LA7UR
K LA7OBR25,LA7OBR26,LA7OBR29,LA7OBR32,LA7OBR33,LA7OBR34,LA7OBR49,LA7VPSTG
;
KILLOBX ; Clean up variables used by OBX and following segments
K LA7AUTORELEASE,LA7ORS,LA7PRODID,LA7RLNC,LA7RMK,LA7RNLT,LA7RO,LA7SOBX,LA7SUBID
;
KILLBLG ; Clean up variables used by BLG and following segments
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN1 9171 printed Apr 09, 2024@20:48:11 Page 2
LA7VIN1 ;DALOI/JMC - Process Incoming UI Msgs, continued ;04/06/16 15:51
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,74,88**;Sep 27, 1994;Build 10
+2 ;
+3 ; This routine is a continuation of LA7VIN and is only called from there.
+4 ; It is called with each message found in the incoming queue.
+5 QUIT
+6 ;
NXTMSG ;
+1 NEW FDA,LA7ABORT,LA7AERR,LA7CNT,LA7END,LA7ERR
+2 NEW LA7INDX,LA7KILAH,LA7QUIT,LA7SEG,LA7STYP
+3 ;
+4 SET (LA7AERR,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",1)
End DoDot:1
QUIT
+14 ;
+15 ; Process message segments
+16 ; Lab currently does not accept segments beginning with the letter "Z" which are reserved for locally-defined messages.
+17 ; "Z" segments will be ignored by this software.
+18 FOR
SET LA7END=$$GETSEG^LA7VHLU2(LA76249,.LA7INDX,.LA7SEG)
if LA7END!(LA7ABORT)
QUIT
Begin DoDot:1
+19 ; Segment type
SET LA7STYP=$EXTRACT(LA7SEG(0),1,3)
+20 IF $EXTRACT(LA7STYP,1)="Z"
QUIT
+21 ; Not a valid segment type
+22 IF LA7STYP'?2U1UN
Begin DoDot:2
+23 SET LA7ERR=34
+24 DO CREATE^LA7LOG(LA7ERR)
End DoDot:2
QUIT
+25 ; Segment encoded wrong - field separator does not match
+26 IF "MSH^FSH^BHS^"'[(LA7STYP_"^")
IF $EXTRACT(LA7SEG(0),4)'=LA7FS
Begin DoDot:2
+27 SET LA7ERR=35
+28 DO CREATE^LA7LOG(LA7ERR)
End DoDot:2
QUIT
+29 ; No processing logic for this segment type
IF $TEXT(@LA7STYP)=""
QUIT
+30 DO @LA7STYP
End DoDot:1
+31 ;
+32 ; Send HL7 Application Acknowledgment message for selected interfaces/message types
+33 IF LA7MTYP="ORM"
IF LA7INTYP=10
DO SENDACK
+34 IF LA7MTYP="ORU"
IF LA7INTYP=1
IF LA7AAT(1)'=""
Begin DoDot:1
+35 ; Auto Release will send application ACK.
IF $GET(LA76249("AR"))
QUIT
+36 IF LA7AAT(1)="NE"
QUIT
+37 IF LA7AAT(1)="SU"
IF $GET(LA7ERR)'=""
QUIT
+38 IF LA7AAT(1)="ER"
IF $GET(LA7ERR)=""
QUIT
+39 DO SENDACK
End DoDot:1
+40 ;
+41 ; Set id if only MSH segment received.
+42 IF LA7SEQ<5
Begin DoDot:1
+43 DO SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN",1)
End DoDot:1
+44 ;
+45 ; Set status to purgeable if no errors.
+46 IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="E"
Begin DoDot:1
+47 SET FDA(1,62.49,LA76249_",",2)="X"
+48 DO FILE^DIE("","FDA(1)","LA7ERR(1)")
End DoDot:1
+49 ;
+50 ; Store identifier's found in message.
+51 DO UPID^LA7VHLU1(LA76249)
+52 ;
+53 ; Send new result alert for ORU messages if turned on.
+54 IF $GET(LA7MTYP)="ORU"
IF $DATA(^LAHM(62.48,+$GET(LA76248),20,"B",1))
Begin DoDot:1
+55 NEW LA7MSG,LA7ROOT
+56 SET LA7ROOT="^TMP(""LA7-ORU"",$J)"
+57 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'="LA7-ORU"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
QUIT
Begin DoDot:2
+58 SET LA7MSG(1)=$SELECT($QSUBSCRIPT(LA7ROOT,5)="CH":"Chemistry/Hematology",$QSUBSCRIPT(LA7ROOT,5)="MI":"Microbiology",$QSUBSCRIPT(LA7ROOT,5)="SP":"Surgical Pathology",$QSUBSCRIPT(LA7ROOT,5)="CY":"Cytology",...
... $QSUBSCRIPT(LA7ROOT,5)="EM":"Electron Microscopy",1:"")
+59 IF LA7MSG(1)'=""
SET LA7MSG(1)=" "_LA7MSG(1)
+60 SET LA7MSG="Lab Msg - New"_LA7MSG(1)_" results received for "_$PIECE($GET(^LAHM(62.48,$QSUBSCRIPT(LA7ROOT,3),0),"UNKNOWN"),"^")_"^"_$QSUBSCRIPT(LA7ROOT,5)
+61 DO XQA^LA7UXQA(1,$QSUBSCRIPT(LA7ROOT,3),"","",LA7MSG,"",0)
End DoDot:2
End DoDot:1
+62 ;
+63 ; Send new order alert for ORM messages if turned on.
+64 IF $GET(LA7MTYP)="ORM"
IF $DATA(^LAHM(62.48,+$GET(LA76248),20,"B",3))
Begin DoDot:1
+65 NEW LA7ROOT
+66 SET LA7ROOT="^TMP(""LA7-ORM"",$J)"
+67 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'="LA7-ORM"!($QSUBSCRIPT(LA7ROOT,2)'=$JOB)
QUIT
Begin DoDot:2
+68 DO XQA^LA7UXQA(3,$QSUBSCRIPT(LA7ROOT,3),"",$QSUBSCRIPT(LA7ROOT,4),"",$QSUBSCRIPT(LA7ROOT,5))
End DoDot:2
End DoDot:1
+69 ;
+70 ; Create performing lab comment for entries in LAH.
+71 ;I $D(^TMP("LA7-PL-NTE",$J)) D PL^LA7VIN1B
+72 ;
+73 ; Cleanup shipping config test info used to process orders
+74 IF $GET(LA7MTYP)="ORM"
KILL ^TMP("LA7TC",$JOB)
+75 ;
+76 ; If amended results received then send bulletins
+77 IF $DATA(^TMP("LA7 AMENDED RESULTS",$JOB))
DO SENDARB^LA7VIN1A
+78 ;
+79 ; If cancelled orders received then send bulletins
+80 IF $DATA(^TMP("LA7 ORDER STATUS",$JOB))
DO SENDOSB^LA7VIN1B
+81 ;
+82 ; If units/normals changed then send bulletins
+83 IF $DATA(^TMP("LA7 UNITS/NORMALS CHANGED",$JOB))
DO SENDUNCB^LA7VIN1A
+84 ;
+85 ; If abnormal/critical results then send bulletins
+86 IF $DATA(^TMP("LA7 ABNORMAL RESULTS",$JOB))
DO SENDACB^LA7VIN1A
+87 ;
+88 ; If auto release move cross-references to ^LAH from ^TMP to signal available for processing if no error.
+89 IF $DATA(^TMP("LA7 AR",$JOB))
IF $PIECE($GET(^LAHM(62.49,LA76249,0)),"^",3)'="E"
MERGE ^LAH=^TMP("LA7 AR",$JOB)
+90 ;
+91 DO KILLMSH
+92 ;
+93 QUIT
+94 ;
+95 ;
MSA ;; Process MSA segment
+1 ;
+2 DO KILLMSA
+3 ;
+4 DO MSA^LA7VIN3
+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^LA7VIN2
+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^LA7VIN2
+10 IF LA7MTYP="ORM"
DO NTE^LA7VIN2
+11 IF LA7MTYP="ORR"
DO NTE^LA7VIN2
+12 ;
+13 QUIT
+14 ;
+15 ;
OBR ;; Process OBR segment
+1 ;
+2 DO KILLOBR
+3 ;
+4 ; Clear flag to process this segment
+5 IF LA7QUIT>0
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^LA7VIN4
+13 IF LA7MTYP="ORU"
DO OBR^LA7VIN4
+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 ; No place to store results
IF '$GET(LA7ISQN)
QUIT
+16 ; Process "CH" subscript results.
+17 IF $GET(LA7SS)="CH"
DO OBX^LA7VIN5
+18 ;
+19 ; Process AP subscripts results. "AU" not currently supported
+20 IF $GET(LA7SS)?1(1"SP",1"CY",1"EM")
DO OBX^LA7VIN7
+21 ;
+22 ; Process "MI" subscript results.
+23 IF $GET(LA7SS)="MI"
DO OBX^LA7VIN7
+24 ;
+25 ; Process "BB" subscript results - not supported
+26 ;
+27 ; Update test status on manifest
+28 IF $GET(LA7628)
IF LA7UID'=""
IF $GET(LA7OTST)
DO UTS^LA7VHLU1(LA7628,LA7UID,LA7OTST)
End DoDot:1
+29 ;
+30 ; Process results that accompany orders
+31 IF LA7MTYP="ORM"
DO OBX^LA7VIN5
+32 ;
+33 ; Set sequence flag
+34 SET LA7SEQ=40
+35 QUIT
+36 ;
+37 ;
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^LA7VIN2
+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^LA7VIN2
+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^LA7VIN2
+10 ;
+11 ; Set sequence flag
+12 SET LA7SEQ=11
+13 QUIT
+14 ;
+15 ;
SENDACK ; Send HL7 Application Acknowledgment message for selected interfaces/message types
+1 ;
+2 ;ZEXCEPT: LA7624,LA76248,LA76249,LA7AERR,LA7ERR,LA7UID,PNM,SSN
+3 ;
+4 NEW LA
+5 SET LA(62.48)=LA76248
SET LA(62.49)=LA76249
+6 IF $GET(LA7624)
SET LA(62.4)=LA7624
+7 SET LA("ACK")=$SELECT(+LA7ERR:"AE",1:"AA")
+8 IF $GET(LA7UID)'=""
SET LA("ID",1)=LA7UID
+9 IF $GET(LA7PNM)'=""
SET LA("ID",2)=LA7PNM
+10 IF $GET(LA7SSN)'=""
SET LA("ID",3)=LA7SSN
+11 IF LA7AERR=""
SET LA7AERR=LA7ERR
+12 IF LA7AERR>0
IF $PIECE(LA7AERR,"^",2)=""
SET $PIECE(LA7AERR,"^",2)="See VistA Lab Universal Interface Log for specific error"
+13 SET LA("MSG")=$PIECE(LA7AERR,"^",2)
+14 ;
+15 ; Build info for ERR segment
+16 DO BLDERR^LA7VHLU8(.LA,LA7AERR)
+17 ;
+18 DO ACK^LA7VHLU8(.LA)
+19 QUIT
+20 ;
+21 ;
+22 ; The section below is designed to clean up variables that are created during the processing of a segment type
+23 ; and any created by processing of segments that are within the message definition.
+24 ;
KILLMSH ; Clean up variables used by MSH and following segments
+1 KILL LA7AAT,LA7CSITE,LA7CS,LA7ECH,LA7FS,LA7HLV,LA7MEDT,LA7MID,LA7MTYP
+2 KILL LA7RAP,LA7RFAC,LA7SAP,LA7SEQ,LA7SFAC
+3 KILL ^TMP("LA7 AR",$JOB),^TMP("LA7-ID",$JOB),^TMP("LA7-ORM",$JOB),^TMP("LA7-ORU",$JOB),^TMP("LA7-PL-NTE",$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,LAPSUBID
+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,LA7ARI,LA7CDT,LA7FID,LA7ISQN,LA7LWL,LA7ONLT,LA7OTST
+3 KILL LA7POC,LA7PRI,LA7RSDT,LA7SAC,LA7SID,LA7SOBR,LA7SPEC,LA7SPTY,LA7SS,LA7TECH,LA7UID,LA7UR
+4 KILL LA7OBR25,LA7OBR26,LA7OBR29,LA7OBR32,LA7OBR33,LA7OBR34,LA7OBR49,LA7VPSTG
+5 ;
KILLOBX ; Clean up variables used by OBX and following segments
+1 KILL LA7AUTORELEASE,LA7ORS,LA7PRODID,LA7RLNC,LA7RMK,LA7RNLT,LA7RO,LA7SOBX,LA7SUBID
+2 ;
KILLBLG ; Clean up variables used by BLG and following segments
+1 ;
+2 QUIT
