LA7POC ;DALOI/JMC - Lab HL7 Point of Care ;05/04/10 16:13
;;5.2;AUTOMATED LAB INSTRUMENTS;**67,74**;Sep 27, 1994;Build 229
;
; Reference to HLL("SET FOR APP ACK") supported by patch HL*1.6*117
Q
;
RTRA ; Setup links and subscriber array for HL7 ADT message generation
; for those LA7POC* entries in file #62.48 which indicate they want to
; subscribe to ADT messages. Interface types POCA in file #62.48
; will be subscribers to VistA HL7 ADT messages.
;
; Called by subscriber protocol LA7POC ADT RTR which functions as a
; router.
;
N LA76248,LA7Y
;
; Check entries with root 'LA7POC" as name and interface type POCA (21)
; to subscribe to ADT message feed from VistA.
S LA76248=0
F S LA76248=$O(^LAHM(62.48,LA76248)) Q:'LA76248 D
. S LA76248(0)=$G(^LAHM(62.48,LA76248,0)),LA7Y=$P(LA76248(0),"^")
. I $E(LA7Y,1,6)'="LA7POC" Q
. I $P(LA76248(0),"^",3)'=1 Q ; Inactive status
. I $P(LA76248(0),"^",9)'=21 Q
. S HLL("LINKS",LA76248)=LA7Y_" ADT SUBS^"_LA7Y_"A"
Q
;
;
ACK(LA7) ; Returns the application acknowledgement to the sending POC
; application. Indicates any error encountered in processing the POC
; results. Setup link for HL7 ACK message generation for LA7POC* entries
; in file #62.48 when POC ORU message has been processed in VistA.
;
; Called by routine LA7VPOC
;
; Call with LA7 array passed by reference
; LA7(62.48)=ien of related configuration in file #62.48
; LA7(62.49)=ien of message in file #62.49 being acknowledged
; LA7("ACK")=acknowledgment status (AA, AE, AR)
; LA7("MSG")=text of error message to be returned
;
N HL,HLMTIENS,I,LA6249,LA76248,LA7X,LA7Y
;
; Check for entry in 62.48
S LA76248=+$G(LA7(62.48))
I '$G(LA76248)!('$D(^LAHM(62.48,LA76248,0))) Q
S LA76248(0)=$G(^LAHM(62.48,LA7(62.48),0)),LA7X=$P(LA76248(0),"^")
;
; Check for entry in 62.49
S LA6249=+$G(LA7(62.49))
I '$G(LA6249)!('$D(^LAHM(62.49,LA6249,0))) Q
F I=0,700 S LA6249(I)=$G(^LAHM(62.49,LA6249,I))
;
; Store Accession's UID on incoming message being processed
I LA7("ACK")="AA",$P(LA7("MSG"),"^")'="" D
. D SETID^LA7VHLU1(LA6249,"",$P(LA7("MSG"),"^"),0)
. D UPID^LA7VHLU1(LA6249)
;
; Call reprocess message to build and send ACK and clear purge flag
S LA7Y=$$REPROC^HLUTIL($P(LA6249(700),";",2),"D BLDACK^LA7POC")
I LA7Y=0 S HLMTIENS=$P(LA6249(700),";",2),LA7X=$$TOPURG^HLUTIL()
;
Q
;
;
BLDACK ; Create/initialize HL ACK message
;
;ZEXCEPT:LA7,LA76248
;
N GBL,HLL,HLP,I,X
N LA76249,LA7AERR,LA7DATA,LA7ECH,LA7FS,LA7ID,LA7MID,LA7MSA,LA7MSH,LA7X,LA7Y
;
; No application acknowledgement
I HL("APAT")="NE" Q
;
; Other system only wants ACK on successful completion condition and we found an error.
I LA7("ACK")'="AA",HL("APAT")="SU" Q
;
; Other system only wants ACK on error/reject condition
I LA7("ACK")="AA",HL("APAT")="ER" Q
;
S GBL="^TMP(""HLA"","_$J_")"
K @GBL
S LA76249=$$INIT6249^LA7VHLU
D RSPINIT^HLFNC2(HL("EIDS"),.HL)
S LA7FS=HL("RFS"),LA7ECH=HL("RECH")
;
; Build pseudo MSH for file #62.49 entry
S LA7MSH(0)="MSH",LA7MSH(1)=LA7ECH,LA7MSH(2)=HL("RAN"),LA7MSH(3)=HL("RAF"),LA7MSH(4)=HL("SAN"),LA7MSH(5)=HL("SAF")
S LA7MSH(9)=HL("RMTN")_$E(LA7ECH,1)_HL("RETN"),LA7MSH(11)=HL("PID"),LA7MSH(12)=HL("VER")
S LA7MSH(15)="AL",LA7MSH(16)="NE"
D BUILDSEG^LA7VHLU(.LA7MSH,.LA7DATA,LA7FS)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
;
; Build and file MSA segment
K LA7DATA
S LA7MSA(0)="MSA",LA7MSA(1)=LA7("ACK"),LA7MSA(2)=HL("MID")
I $G(LA7("MSG"))'="" D
. S LA7MSA(3)=$$CHKDATA^LA7VHLU3($P(LA7("MSG"),"^"),LA7FS_LA7ECH)
. I LA7("ACK")="AA",$P(LA7("MSG"),"^")'="" D SETID^LA7VHLU1(LA76249,"",$P(LA7("MSG"),"^"),0)
. I $P(LA7("MSG"),"^",2)="" Q
. S $P(LA7MSA(3),$E(LA7ECH),2)=$$CHKDATA^LA7VHLU3($P(LA7("MSG"),"^",2),LA7FS_LA7ECH)
;
; Save message ids in file #62.49
S LA7ID=$P(LA76248(0),"^",1)_"-O-ACK-"_LA7MSA(2)
D SETID^LA7VHLU1(LA76249,"",LA7ID,1)
D SETID^LA7VHLU1(LA76249,"",LA7MSA(2),0)
;
D BUILDSEG^LA7VHLU(.LA7MSA,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
;
; Send the HL7 message.
S HLL("SET FOR APP ACK")=1
S HLL("LINKS",1)=HL("EIDS")_"^"_$P(LA76248(0),"^")
S HLP("NAMESPACE")="LA"
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.LA7MID,"",.HLP)
;
S HL("MTN")=HL("RMTN"),HL("SAN")=HL("RAN"),HL("SAF")=HL("RAF"),HL("APAT")=""
D UPDT6249^LA7VORM1
L -^LAHM(62.49,LA76249)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7POC 4477 printed Sep 23, 2025@19:15:13 Page 2
LA7POC ;DALOI/JMC - Lab HL7 Point of Care ;05/04/10 16:13
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**67,74**;Sep 27, 1994;Build 229
+2 ;
+3 ; Reference to HLL("SET FOR APP ACK") supported by patch HL*1.6*117
+4 QUIT
+5 ;
RTRA ; Setup links and subscriber array for HL7 ADT message generation
+1 ; for those LA7POC* entries in file #62.48 which indicate they want to
+2 ; subscribe to ADT messages. Interface types POCA in file #62.48
+3 ; will be subscribers to VistA HL7 ADT messages.
+4 ;
+5 ; Called by subscriber protocol LA7POC ADT RTR which functions as a
+6 ; router.
+7 ;
+8 NEW LA76248,LA7Y
+9 ;
+10 ; Check entries with root 'LA7POC" as name and interface type POCA (21)
+11 ; to subscribe to ADT message feed from VistA.
+12 SET LA76248=0
+13 FOR
SET LA76248=$ORDER(^LAHM(62.48,LA76248))
if 'LA76248
QUIT
Begin DoDot:1
+14 SET LA76248(0)=$GET(^LAHM(62.48,LA76248,0))
SET LA7Y=$PIECE(LA76248(0),"^")
+15 IF $EXTRACT(LA7Y,1,6)'="LA7POC"
QUIT
+16 ; Inactive status
IF $PIECE(LA76248(0),"^",3)'=1
QUIT
+17 IF $PIECE(LA76248(0),"^",9)'=21
QUIT
+18 SET HLL("LINKS",LA76248)=LA7Y_" ADT SUBS^"_LA7Y_"A"
End DoDot:1
+19 QUIT
+20 ;
+21 ;
ACK(LA7) ; Returns the application acknowledgement to the sending POC
+1 ; application. Indicates any error encountered in processing the POC
+2 ; results. Setup link for HL7 ACK message generation for LA7POC* entries
+3 ; in file #62.48 when POC ORU message has been processed in VistA.
+4 ;
+5 ; Called by routine LA7VPOC
+6 ;
+7 ; Call with LA7 array passed by reference
+8 ; LA7(62.48)=ien of related configuration in file #62.48
+9 ; LA7(62.49)=ien of message in file #62.49 being acknowledged
+10 ; LA7("ACK")=acknowledgment status (AA, AE, AR)
+11 ; LA7("MSG")=text of error message to be returned
+12 ;
+13 NEW HL,HLMTIENS,I,LA6249,LA76248,LA7X,LA7Y
+14 ;
+15 ; Check for entry in 62.48
+16 SET LA76248=+$GET(LA7(62.48))
+17 IF '$GET(LA76248)!('$DATA(^LAHM(62.48,LA76248,0)))
QUIT
+18 SET LA76248(0)=$GET(^LAHM(62.48,LA7(62.48),0))
SET LA7X=$PIECE(LA76248(0),"^")
+19 ;
+20 ; Check for entry in 62.49
+21 SET LA6249=+$GET(LA7(62.49))
+22 IF '$GET(LA6249)!('$DATA(^LAHM(62.49,LA6249,0)))
QUIT
+23 FOR I=0,700
SET LA6249(I)=$GET(^LAHM(62.49,LA6249,I))
+24 ;
+25 ; Store Accession's UID on incoming message being processed
+26 IF LA7("ACK")="AA"
IF $PIECE(LA7("MSG"),"^")'=""
Begin DoDot:1
+27 DO SETID^LA7VHLU1(LA6249,"",$PIECE(LA7("MSG"),"^"),0)
+28 DO UPID^LA7VHLU1(LA6249)
End DoDot:1
+29 ;
+30 ; Call reprocess message to build and send ACK and clear purge flag
+31 SET LA7Y=$$REPROC^HLUTIL($PIECE(LA6249(700),";",2),"D BLDACK^LA7POC")
+32 IF LA7Y=0
SET HLMTIENS=$PIECE(LA6249(700),";",2)
SET LA7X=$$TOPURG^HLUTIL()
+33 ;
+34 QUIT
+35 ;
+36 ;
BLDACK ; Create/initialize HL ACK message
+1 ;
+2 ;ZEXCEPT:LA7,LA76248
+3 ;
+4 NEW GBL,HLL,HLP,I,X
+5 NEW LA76249,LA7AERR,LA7DATA,LA7ECH,LA7FS,LA7ID,LA7MID,LA7MSA,LA7MSH,LA7X,LA7Y
+6 ;
+7 ; No application acknowledgement
+8 IF HL("APAT")="NE"
QUIT
+9 ;
+10 ; Other system only wants ACK on successful completion condition and we found an error.
+11 IF LA7("ACK")'="AA"
IF HL("APAT")="SU"
QUIT
+12 ;
+13 ; Other system only wants ACK on error/reject condition
+14 IF LA7("ACK")="AA"
IF HL("APAT")="ER"
QUIT
+15 ;
+16 SET GBL="^TMP(""HLA"","_$JOB_")"
+17 KILL @GBL
+18 SET LA76249=$$INIT6249^LA7VHLU
+19 DO RSPINIT^HLFNC2(HL("EIDS"),.HL)
+20 SET LA7FS=HL("RFS")
SET LA7ECH=HL("RECH")
+21 ;
+22 ; Build pseudo MSH for file #62.49 entry
+23 SET LA7MSH(0)="MSH"
SET LA7MSH(1)=LA7ECH
SET LA7MSH(2)=HL("RAN")
SET LA7MSH(3)=HL("RAF")
SET LA7MSH(4)=HL("SAN")
SET LA7MSH(5)=HL("SAF")
+24 SET LA7MSH(9)=HL("RMTN")_$EXTRACT(LA7ECH,1)_HL("RETN")
SET LA7MSH(11)=HL("PID")
SET LA7MSH(12)=HL("VER")
+25 SET LA7MSH(15)="AL"
SET LA7MSH(16)="NE"
+26 DO BUILDSEG^LA7VHLU(.LA7MSH,.LA7DATA,LA7FS)
+27 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+28 ;
+29 ; Build and file MSA segment
+30 KILL LA7DATA
+31 SET LA7MSA(0)="MSA"
SET LA7MSA(1)=LA7("ACK")
SET LA7MSA(2)=HL("MID")
+32 IF $GET(LA7("MSG"))'=""
Begin DoDot:1
+33 SET LA7MSA(3)=$$CHKDATA^LA7VHLU3($PIECE(LA7("MSG"),"^"),LA7FS_LA7ECH)
+34 IF LA7("ACK")="AA"
IF $PIECE(LA7("MSG"),"^")'=""
DO SETID^LA7VHLU1(LA76249,"",$PIECE(LA7("MSG"),"^"),0)
+35 IF $PIECE(LA7("MSG"),"^",2)=""
QUIT
+36 SET $PIECE(LA7MSA(3),$EXTRACT(LA7ECH),2)=$$CHKDATA^LA7VHLU3($PIECE(LA7("MSG"),"^",2),LA7FS_LA7ECH)
End DoDot:1
+37 ;
+38 ; Save message ids in file #62.49
+39 SET LA7ID=$PIECE(LA76248(0),"^",1)_"-O-ACK-"_LA7MSA(2)
+40 DO SETID^LA7VHLU1(LA76249,"",LA7ID,1)
+41 DO SETID^LA7VHLU1(LA76249,"",LA7MSA(2),0)
+42 ;
+43 DO BUILDSEG^LA7VHLU(.LA7MSA,.LA7DATA,LA7FS)
+44 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+45 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+46 ;
+47 ; Send the HL7 message.
+48 SET HLL("SET FOR APP ACK")=1
+49 SET HLL("LINKS",1)=HL("EIDS")_"^"_$PIECE(LA76248(0),"^")
+50 SET HLP("NAMESPACE")="LA"
+51 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.LA7MID,"",.HLP)
+52 ;
+53 SET HL("MTN")=HL("RMTN")
SET HL("SAN")=HL("RAN")
SET HL("SAF")=HL("RAF")
SET HL("APAT")=""
+54 DO UPDT6249^LA7VORM1
+55 LOCK -^LAHM(62.49,LA76249)
+56 QUIT
