HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133**;Oct 13, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
;
READMSG(HLCSTATE,HLMSTATE) ;
;This function uses the services provided by the transport layer to receive a message. The header is parsed. Does these checks:
; 1) Duplicate?
; 2) Wrong Receiving Facility?
; 3) Can the Receiving App accept this message, based message type & event?
; 4) Processing ID must match the receiving system
; 5) Must have an ID
; 6) Header must be BHS or MSH
;
;Output:
; Function returns 1 if the message was read fully, 0 otherwise
; HLMSTATE (pass by reference) the message. It will include the fields for the return ack in HLMSTATE("MSA")
;
N ACK,SEG,STORE,I
;
S STORE=1
Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
D SPLITHDR(.SEG)
;
;parse the header, stop if unsuccessful because the server cannot know what to do next
I '$$PARSEHDR^HLOPRS(.SEG) D Q 0
.S HLCSTATE("MESSAGE ENDED")=0
.D CLOSE^HLOT(.HLCSTATE)
D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
I HLMSTATE("ID")="" D
.S STORE=0
.I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
I STORE,$$DUP(.HLMSTATE) S STORE=0
;
;if the message is not to be stored, just read it and discard the segments
I 'STORE D
.F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
;
;else the message is to be stored
E D
.N FS
.S FS=HLMSTATE("HDR","FIELD SEPARATOR")
.F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D
..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID
..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
..I SEGTYPE="MSA" D
...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2)
...I $E(CODE,1)'="A" S SEGTYPE="" Q
...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
..I 'HLMSTATE("BATCH") D
...D:SEGTYPE="MSA"
....S HLMSTATE("ACK TO")=OLDMSGID
....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
..E D ;batch
...I SEGTYPE="MSH" D
....D SPLITHDR(.SEG)
....S NEWMSGID=$P(SEG(2),FS,5)
....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
...E D ;not MSH
....D:SEGTYPE="MSA"
.....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
.....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
.....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
.....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
.....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
.I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
;
I STORE,'HLCSTATE("MESSAGE ENDED") D
.;reading failed before the end, there is no need to keep anything
.D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
.S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
E D:STORE
.D CHECKMSG(.HLMSTATE)
.D ADDAC(.HLMSTATE) ;so that future duplicates can be detected
.D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
;
D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
Q HLCSTATE("MESSAGE ENDED")
;
ADDAC(HLMSTATE) ;adds the AC xref for the message that was just received
;The AC xref allows duplicates to be detected.
;
N FROM
S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
Q
;
DUP(HLMSTATE) ;
;Function returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
;Input:
; HLMSTATE (pass by reference) the message being read
;Output:
; Function returns 1 if the message is a duplicate, 0 otherwise
; HLMSTATE (pass by reference) IF the message is a duplicate:
; returns the prior MSA segment in HLMSTATE("MSA")
;!!!! put back if original mode implemented
; If original mode returns the ien of the app ack in HLMSTATE("ACK BY IEN")
;
N IEN,FROM,DUP
S (IEN,DUP)=0
;
;no way to determine! Bad header will be rejected
Q:(HLMSTATE("ID")="") 0
;
S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
F S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN D Q:DUP
.I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
.;need the MSA to return
.D Q
..N NODE
..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
..Q:$L(HLMSTATE("MSA",1))'=2
..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
..S DUP=1
;
Q DUP
;
CHECKMSG(HLMSTATE) ;
;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
;Input:
; HLMSTATE("HDR") - the parsed header segment
;Output:
; HLMSTATE("STATUS")="SE" if an error is detected
; HLMSTATE("STATUS","QUEUE") queue to put the message on
; HLMSTATE("STATUS","ACTION") <tag^rtn> that is the processing routine for the receiving application
; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
;
N WANTACK,PASS,ACTION,QUEUE
M HDR=HLMSTATE("HDR")
I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
.S WANTACK=0
E D
.S WANTACK=1
I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(HLMSTATE("ACK TO"))="" S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
;
;If this is an application ack, does the original message exist?
I $G(HLMSTATE("ACK TO"))]"" D Q:HLMSTATE("STATUS")="SE"
.N NODE
.S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
.I $G(NODE)="" S HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
.I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")
;
I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
;
;
;wrong receiving facility? This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
S PASS=0
D
.;if its an ack to an existing message, don't check the receiving facility
.I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
.I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
.I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
.I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
.I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
.I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
Q
;
DEL777(IEN777) ;delete a record from file 777 where the read did not complete
;
K ^HLA(IEN777,0)
Q
DEL778(IEN778) ;delete a record from file 778 where the read did not complete
;
K ^HLB(IEN778,0)
Q
;
SPLITHDR(HDR) ;
;splits hdr segment into two lines, first being just components 1-6
;
N TEMP,FS
D SQUISH(.HDR)
S FS=$E($G(HDR(1)),4)
S TEMP(1)=$P($G(HDR(1)),FS,1,6)
S TEMP(2)=""
I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
S HDR(2)=TEMP(2)_$G(HDR(2))
S HDR(1)=TEMP(1)
Q
;
SQUISH(SEG) ;
;reformat the segment array into full lines
;
;nothing to do if less than 2 lines
Q:'$O(SEG(1))
;
N A,I,J,K,MAX,COUNT,LEN
S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
S (COUNT,I)=0,J=1
F S I=$O(SEG(I)) Q:'I D
.S LEN=$L(SEG(I))
.F K=1:1:LEN D
..S A(J)=$G(A(J))_$E(SEG(I),K)
..S COUNT=COUNT+1
..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
K SEG
M SEG=A
Q
;
ERROR ;error trap
S $ETRAP="D UNWIND^%ZTER"
D END^HLOSRVR
;
;while debugging quit on all errors
I $G(^HLTMP("LOG ALL ERRORS")) D ^%ZTER QUIT
;
;don't log these common errors
I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
.;
E D
.D ^%ZTER
;
;concurrent server connections (multi-listener) should stop execution, only a single server may continue
Q:$P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S"
;
;a lot of errors of the same time may indicate an endless loop, so keep a count
S ^TMP("HL7 ERRORS",$J,$ECODE)=$G(^TMP("HL7 ERRORS",$J,$ECODE))+1
;
I ($G(^TMP("HL7 ERRORS",$J,$ECODE))>100) K ^TMP("HL7 ERRORS",$J) QUIT
;
;resume execution for the single listener
D UNWIND^%ZTER
Q
HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133**;Oct 13, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
READMSG(HLCSTATE,HLMSTATE) ;
+1 ;This function uses the services provided by the transport layer to receive a message. The header is parsed. Does these checks:
+2 ; 1) Duplicate?
+3 ; 2) Wrong Receiving Facility?
+4 ; 3) Can the Receiving App accept this message, based message type & event?
+5 ; 4) Processing ID must match the receiving system
+6 ; 5) Must have an ID
+7 ; 6) Header must be BHS or MSH
+8 ;
+9 ;Output:
+10 ; Function returns 1 if the message was read fully, 0 otherwise
+11 ; HLMSTATE (pass by reference) the message. It will include the fields for the return ack in HLMSTATE("MSA")
+12 ;
+13 NEW ACK,SEG,STORE,I
+14 ;
+15 SET STORE=1
+16 IF '$$READHDR^HLOT(.HLCSTATE,.SEG)
QUIT 0
+17 DO SPLITHDR(.SEG)
+18 ;
+19 ;parse the header, stop if unsuccessful because the server cannot know what to do next
+20 IF '$$PARSEHDR^HLOPRS(.SEG)
Begin DoDot:1
+21 SET HLCSTATE("MESSAGE ENDED")=0
+22 DO CLOSE^HLOT(.HLCSTATE)
End DoDot:1
QUIT 0
+23 DO NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
+24 IF HLMSTATE("ID")=""
Begin DoDot:1
+25 SET STORE=0
+26 IF HLMSTATE("HDR","ACCEPT ACK TYPE")="AL"
SET HLMSTATE("MSA",1)="CE"
SET HLMSTATE("MSA",3)="CONTROL ID MISSING"
End DoDot:1
+27 IF STORE
IF $$DUP(.HLMSTATE)
SET STORE=0
+28 ;
+29 ;if the message is not to be stored, just read it and discard the segments
+30 IF 'STORE
Begin DoDot:1
+31 FOR
IF '$$READSEG^HLOT(.HLCSTATE,.SEG)
QUIT
End DoDot:1
+32 ;
+33 ;else the message is to be stored
+34 IF '$TEST
Begin DoDot:1
+35 NEW FS
+36 SET FS=HLMSTATE("HDR","FIELD SEPARATOR")
+37 FOR
IF '$$READSEG^HLOT(.HLCSTATE,.SEG)
QUIT
Begin DoDot:2
+38 NEW MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID
+39 SET SEGTYPE=$EXTRACT($EXTRACT(SEG(1),1,3)_$EXTRACT($GET(SEG(2)),1,2),1,3)
+40 IF SEGTYPE="MSA"
Begin DoDot:3
+41 SET MSA=SEG(1)_$GET(SEG(2))_$GET(SEG(3))
+42 SET OLDMSGID=$PIECE(MSA,FS,3)
SET CODE=$PIECE(MSA,FS,2)
+43 IF $EXTRACT(CODE,1)'="A"
SET SEGTYPE=""
QUIT
+44 IF $PIECE(OLDMSGID,"-")]""
SET IEN=$ORDER(^HLB("B",$PIECE(OLDMSGID,"-"),0))
+45 IF $GET(IEN)
SET IEN=IEN_"^"_$PIECE(OLDMSGID,"-",2)
End DoDot:3
+46 IF 'HLMSTATE("BATCH")
Begin DoDot:3
+47 IF SEGTYPE="MSA"
Begin DoDot:4
+48 SET HLMSTATE("ACK TO")=OLDMSGID
+49 SET HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
+50 SET HLMSTATE("ACK TO","STATUS")=$SELECT(CODE="AA":"SU",1:"AE")
+51 IF $DATA(IEN)
SET HLMSTATE("ACK TO","IEN")=IEN
End DoDot:4
+52 DO ADDSEG^HLOMSG(.HLMSTATE,.SEG)
End DoDot:3
+53 ;batch
IF '$TEST
Begin DoDot:3
+54 IF SEGTYPE="MSH"
Begin DoDot:4
+55 DO SPLITHDR(.SEG)
+56 SET NEWMSGID=$PIECE(SEG(2),FS,5)
+57 DO ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
End DoDot:4
+58 ;not MSH
IF '$TEST
Begin DoDot:4
+59 IF SEGTYPE="MSA"
Begin DoDot:5
+60 NEW SUBIEN
SET SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
+61 SET HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
+62 SET HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
+63 SET HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$SELECT(CODE="AA":"SU",1:"AE")
+64 IF $DATA(IEN)
SET HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
End DoDot:5
+65 DO ADDSEG^HLOMSG(.HLMSTATE,.SEG)
End DoDot:4
End DoDot:3
End DoDot:2
+66 IF HLMSTATE("UNSTORED LINES")
IF HLCSTATE("MESSAGE ENDED")
IF $$SAVEMSG^HLOF778(.HLMSTATE)
End DoDot:1
+67 ;
+68 IF STORE
IF 'HLCSTATE("MESSAGE ENDED")
Begin DoDot:1
+69 ;reading failed before the end, there is no need to keep anything
+70 IF HLMSTATE("IEN")
DO DEL778(HLMSTATE("IEN"))
IF HLMSTATE("BODY")
DO DEL777(HLMSTATE("BODY"))
+71 SET HLMSTATE("IEN")=""
SET HLMSTATE("BODY")=""
End DoDot:1
+72 IF '$TEST
IF STORE
Begin DoDot:1
+73 DO CHECKMSG(.HLMSTATE)
+74 ;so that future duplicates can be detected
DO ADDAC(.HLMSTATE)
+75 DO COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$SELECT(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
End DoDot:1
+76 ;
+77 IF 'HLCSTATE("MESSAGE ENDED")
DO CLOSE^HLOT(.HLCSTATE)
+78 QUIT HLCSTATE("MESSAGE ENDED")
+79 ;
ADDAC(HLMSTATE) ;adds the AC xref for the message that was just received
+1 ;The AC xref allows duplicates to be detected.
+2 ;
+3 NEW FROM
+4 SET FROM=$SELECT(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+5 SET ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
+6 QUIT
+7 ;
DUP(HLMSTATE) ;
+1 ;Function returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
+2 ;Input:
+3 ; HLMSTATE (pass by reference) the message being read
+4 ;Output:
+5 ; Function returns 1 if the message is a duplicate, 0 otherwise
+6 ; HLMSTATE (pass by reference) IF the message is a duplicate:
+7 ; returns the prior MSA segment in HLMSTATE("MSA")
+8 ;!!!! put back if original mode implemented
+9 ; If original mode returns the ien of the app ack in HLMSTATE("ACK BY IEN")
+10 ;
+11 NEW IEN,FROM,DUP
+12 SET (IEN,DUP)=0
+13 ;
+14 ;no way to determine! Bad header will be rejected
+15 IF (HLMSTATE("ID")="")
QUIT 0
+16 ;
+17 SET FROM=$SELECT(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+18 FOR
SET IEN=$ORDER(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN))
IF 'IEN
QUIT
Begin DoDot:1
+19 IF HLMSTATE("HDR","ACCEPT ACK TYPE")="NE"
SET DUP=1
QUIT
+20 ;need the MSA to return
+21 Begin DoDot:2
+22 NEW NODE
+23 SET NODE=$PIECE($GET(^HLB(IEN,4)),"^",3,10)
+24 SET HLMSTATE("MSA",1)=$PIECE(NODE,"|",2)
+25 IF $LENGTH(HLMSTATE("MSA",1))'=2
QUIT
+26 SET HLMSTATE("MSA",2)=$PIECE(NODE,"|",3)
+27 SET HLMSTATE("MSA",3)=$PIECE(NODE,"|",4,10)
+28 SET DUP=1
End DoDot:2
QUIT
End DoDot:1
IF DUP
QUIT
+29 ;
+30 QUIT DUP
+31 ;
CHECKMSG(HLMSTATE) ;
+1 ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
+2 ;Input:
+3 ; HLMSTATE("HDR") - the parsed header segment
+4 ;Output:
+5 ; HLMSTATE("STATUS")="SE" if an error is detected
+6 ; HLMSTATE("STATUS","QUEUE") queue to put the message on
+7 ; HLMSTATE("STATUS","ACTION") <tag^rtn> that is the processing routine for the receiving application
+8 ; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
+9 ;
+10 NEW WANTACK,PASS,ACTION,QUEUE
+11 MERGE HDR=HLMSTATE("HDR")
+12 IF HDR("ACCEPT ACK TYPE")="NE"
IF 'HLMSTATE("ORIGINAL MODE")
Begin DoDot:1
+13 SET WANTACK=0
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET WANTACK=1
End DoDot:1
+16 IF HLMSTATE("ORIGINAL MODE")
SET HLMSTATE("MSA",1)="AE"
SET HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS"
SET HLMSTATE("STATUS")="SE"
QUIT
+17 IF '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE)
IF $GET(HLMSTATE("ACK TO"))=""
IF WANTACK
SET HLMSTATE("MSA",1)="CR"
SET HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED"
SET HLMSTATE("STATUS")="SE"
QUIT
+18 SET HLMSTATE("STATUS","ACTION")=$GET(ACTION)
SET HLMSTATE("STATUS","QUEUE")=$GET(QUEUE)
+19 ;
+20 ;If this is an application ack, does the original message exist?
+21 IF $GET(HLMSTATE("ACK TO"))]""
Begin DoDot:1
+22 NEW NODE
+23 IF +$GET(HLMSTATE("ACK TO","IEN"))
SET NODE=$GET(^HLB(+HLMSTATE("ACK TO","IEN"),0))
+24 IF $GET(NODE)=""
SET HLMSTATE("STATUS")="SE"
SET HLMSTATE("ACK TO","IEN")=""
IF WANTACK
SET HLMSTATE("MSA",1)="CE"
SET HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND"
QUIT
+25 IF ($PIECE(NODE,"^",11)]"")
SET HLMSTATE("STATUS","ACTION")=$PIECE(NODE,"^",10,11)
SET HLMSTATE("STATUS","QUEUE")=$SELECT($PIECE(NODE,"^",6)]"":$PIECE(NODE,"^",6),1:"DEFAULT")
End DoDot:1
IF HLMSTATE("STATUS")="SE"
QUIT
+26 ;
+27 IF HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID")
IF WANTACK
SET HLMSTATE("MSA",1)="CR"
SET HLMSTATE("STATUS")="SE"
SET HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID")
QUIT
+28 ;
+29 ;
+30 ;wrong receiving facility? This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
+31 SET PASS=0
+32 Begin DoDot:1
+33 ;if its an ack to an existing message, don't check the receiving facility
+34 IF $GET(HLMSTATE("ACK TO"))]""
SET PASS=1
QUIT
+35 IF HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION")
SET PASS=1
QUIT
+36 IF HDR("RECEIVING FACILITY",3)'="DNS"
SET PASS=1
QUIT
+37 IF HDR("RECEIVING FACILITY",2)=""
SET PASS=1
QUIT
+38 IF $PIECE(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN")
SET PASS=1
QUIT
+39 IF HLCSTATE("SYSTEM","DOMAIN")[$PIECE(HDR("RECEIVING FACILITY",2),":")
SET PASS=1
QUIT
End DoDot:1
+40 IF 'PASS
SET HLMSTATE("STATUS")="SE"
SET HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN")
IF WANTACK
SET HLMSTATE("MSA",1)="CE"
+41 IF PASS
IF WANTACK
SET HLMSTATE("MSA",1)="CA"
+42 QUIT
+43 ;
DEL777(IEN777) ;delete a record from file 777 where the read did not complete
+1 ;
+2 KILL ^HLA(IEN777,0)
+3 QUIT
DEL778(IEN778) ;delete a record from file 778 where the read did not complete
+1 ;
+2 KILL ^HLB(IEN778,0)
+3 QUIT
+4 ;
SPLITHDR(HDR) ;
+1 ;splits hdr segment into two lines, first being just components 1-6
+2 ;
+3 NEW TEMP,FS
+4 DO SQUISH(.HDR)
+5 SET FS=$EXTRACT($GET(HDR(1)),4)
+6 SET TEMP(1)=$PIECE($GET(HDR(1)),FS,1,6)
+7 SET TEMP(2)=""
+8 IF $LENGTH(TEMP(1))<$LENGTH($GET(HDR(1)))
SET TEMP(2)=FS_$PIECE($GET(HDR(1)),FS,7,20)
+9 SET HDR(2)=TEMP(2)_$GET(HDR(2))
+10 SET HDR(1)=TEMP(1)
+11 QUIT
+12 ;
SQUISH(SEG) ;
+1 ;reformat the segment array into full lines
+2 ;
+3 ;nothing to do if less than 2 lines
+4 IF '$ORDER(SEG(1))
QUIT
+5 ;
+6 NEW A,I,J,K,MAX,COUNT,LEN
+7 SET MAX=$SELECT($GET(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
+8 SET (COUNT,I)=0
SET J=1
+9 FOR
SET I=$ORDER(SEG(I))
IF 'I
QUIT
Begin DoDot:1
+10 SET LEN=$LENGTH(SEG(I))
+11 FOR K=1:1:LEN
Begin DoDot:2
+12 SET A(J)=$GET(A(J))_$EXTRACT(SEG(I),K)
+13 SET COUNT=COUNT+1
+14 IF (COUNT>(MAX-1))
SET COUNT=0
SET J=J+1
End DoDot:2
End DoDot:1
+15 KILL SEG
+16 MERGE SEG=A
+17 QUIT
+18 ;
ERROR ;error trap
+1 SET $ETRAP="D UNWIND^%ZTER"
+2 DO END^HLOSRVR
+3 ;
+4 ;while debugging quit on all errors
+5 IF $GET(^HLTMP("LOG ALL ERRORS"))
DO ^%ZTER
QUIT
+6 ;
+7 ;don't log these common errors
+8 IF ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR")
Begin DoDot:1
+9 ;
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 DO ^%ZTER
End DoDot:1
+12 ;
+13 ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
+14 IF $PIECE($GET(HLCSTATE("LINK","SERVER")),"^",2)'="S"
QUIT
+15 ;
+16 ;a lot of errors of the same time may indicate an endless loop, so keep a count
+17 SET ^TMP("HL7 ERRORS",$JOB,$ECODE)=$GET(^TMP("HL7 ERRORS",$JOB,$ECODE))+1
+18 ;
+19 IF ($GET(^TMP("HL7 ERRORS",$JOB,$ECODE))>100)
KILL ^TMP("HL7 ERRORS",$JOB)
QUIT
+20 ;
+21 ;resume execution for the single listener
+22 DO UNWIND^%ZTER
+23 QUIT
