HLOSRVR1 ;IRMFO-ALB/CJM/OAK/PIJ - Reading messages, sending acks;03/24/2004 14:43 ;03/08/2012
;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137,138,139,143,146,147,152,158**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
READMSG(HLCSTATE,HLMSTATE) ;
;Reads a message. The header is parsed. Does these checks:
; 1) Duplicate?
; 2) Wrong Receiving Facility?
; 3) Can the Receiving App accept this message, based on the 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
ZB29 .S HLCSTATE("MESSAGE ENDED")=0
.D CLOSE^HLOT(.HLCSTATE)
;
S I=$S(SEG("SEGMENT TYPE")="MSH":$G(SEG("MESSAGE CONTROL ID")),1:$G(SEG("BATCH CONTROL ID")))
I I'="" L +HLO("MSGID",I):5 I '$T 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) D
ZB30 .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)
;
E D
.N FS,NEWMSGID
.S NEWMSGID=""
.S FS=HLMSTATE("HDR","FIELD SEPARATOR")
.F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D
..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,TEXT
..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)
...S TEXT=$$ESCAPE^HLOPBLD(.HLMSTATE,$P(MSA,FS,4))
...I $E(CODE,1)'="A" S SEGTYPE="" Q
...S IEN=$$ACKTOIEN^HLOMSG1("",OLDMSGID)
..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:"ER")
....I $G(IEN) D
.....S HLMSTATE("ACK TO IEN")=IEN
.....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
...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:"ER")
.....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, don't store
.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 future duplicates are 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 duplicates detection
;
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) ;
;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")
;
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")="ER" 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,ERROR
M HDR=HLMSTATE("HDR")
S ERROR=0
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")="ER" Q
I $G(HLMSTATE("ACK TO"))="" D Q:ERROR
.;
.I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q
.S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
E D Q:ERROR ;this is an app ack
.;does the original message exist?
.N NODE
.S:+$G(HLMSTATE("ACK TO IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO IEN"),0))
.I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",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,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
.;
.S HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")
.I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11) Q
.;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
.I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO IEN"))
.;
.I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION) S:HLMSTATE("STATUS","QUEUE")="DEFAULT" HLMSTATE("STATUS","QUEUE")=QUEUE
;
I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",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")="ER",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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOSRVR1 9437 printed Nov 22, 2024@17:09:16 Page 2
HLOSRVR1 ;IRMFO-ALB/CJM/OAK/PIJ - Reading messages, sending acks;03/24/2004 14:43 ;03/08/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137,138,139,143,146,147,152,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
READMSG(HLCSTATE,HLMSTATE) ;
+1 ;Reads 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 on the 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
ZB29 SET HLCSTATE("MESSAGE ENDED")=0
+1 DO CLOSE^HLOT(.HLCSTATE)
End DoDot:1
QUIT 0
+2 ;
+3 SET I=$SELECT(SEG("SEGMENT TYPE")="MSH":$GET(SEG("MESSAGE CONTROL ID")),1:$GET(SEG("BATCH CONTROL ID")))
+4 IF I'=""
LOCK +HLO("MSGID",I):5
IF '$TEST
Begin DoDot:1
+5 SET HLCSTATE("MESSAGE ENDED")=0
+6 DO CLOSE^HLOT(.HLCSTATE)
End DoDot:1
QUIT 0
+7 ;
+8 DO NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
+9 IF HLMSTATE("ID")=""
Begin DoDot:1
+10 SET STORE=0
+11 IF HLMSTATE("HDR","ACCEPT ACK TYPE")="AL"
SET HLMSTATE("MSA",1)="CE"
SET HLMSTATE("MSA",3)="CONTROL ID MISSING"
End DoDot:1
+12 IF STORE
IF $$DUP(.HLMSTATE)
Begin DoDot:1
ZB30 SET STORE=0
End DoDot:1
+1 ;
+2 ;if the message is not to be stored, just read it and discard the segments
+3 IF 'STORE
Begin DoDot:1
+4 FOR
if '$$READSEG^HLOT(.HLCSTATE,.SEG)
QUIT
End DoDot:1
+5 ;
+6 IF '$TEST
Begin DoDot:1
+7 NEW FS,NEWMSGID
+8 SET NEWMSGID=""
+9 SET FS=HLMSTATE("HDR","FIELD SEPARATOR")
+10 FOR
if '$$READSEG^HLOT(.HLCSTATE,.SEG)
QUIT
Begin DoDot:2
+11 NEW MSA,SEGTYPE,OLDMSGID,CODE,IEN,TEXT
+12 SET SEGTYPE=$EXTRACT($EXTRACT(SEG(1),1,3)_$EXTRACT($GET(SEG(2)),1,2),1,3)
+13 IF SEGTYPE="MSA"
Begin DoDot:3
+14 SET MSA=SEG(1)_$GET(SEG(2))_$GET(SEG(3))
+15 SET OLDMSGID=$PIECE(MSA,FS,3)
SET CODE=$PIECE(MSA,FS,2)
+16 SET TEXT=$$ESCAPE^HLOPBLD(.HLMSTATE,$PIECE(MSA,FS,4))
+17 IF $EXTRACT(CODE,1)'="A"
SET SEGTYPE=""
QUIT
+18 SET IEN=$$ACKTOIEN^HLOMSG1("",OLDMSGID)
End DoDot:3
+19 IF 'HLMSTATE("BATCH")
Begin DoDot:3
+20 if SEGTYPE="MSA"
Begin DoDot:4
+21 SET HLMSTATE("ACK TO")=OLDMSGID
+22 SET HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
+23 SET HLMSTATE("ACK TO","STATUS")=$SELECT(CODE="AA":"SU",1:"ER")
+24 IF $GET(IEN)
Begin DoDot:5
+25 SET HLMSTATE("ACK TO IEN")=IEN
+26 SET HLMSTATE("ACK TO","SEQUENCE QUEUE")=$PIECE($GET(^HLB(+IEN,5)),"^")
End DoDot:5
+27 SET HLMSTATE("ACK TO","ERROR TEXT")=TEXT
End DoDot:4
+28 DO ADDSEG^HLOMSG(.HLMSTATE,.SEG)
End DoDot:3
+29 ;batch
IF '$TEST
Begin DoDot:3
+30 IF SEGTYPE="MSH"
Begin DoDot:4
+31 DO SPLITHDR(.SEG)
+32 SET NEWMSGID=$PIECE(SEG(2),FS,5)
+33 DO ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
End DoDot:4
+34 ;not MSH
IF '$TEST
Begin DoDot:4
+35 if SEGTYPE="MSA"
Begin DoDot:5
+36 NEW SUBIEN
SET SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
+37 SET HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
+38 SET HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
+39 SET HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$SELECT(CODE="AA":"SU",1:"ER")
+40 if $DATA(IEN)
SET HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
End DoDot:5
+41 DO ADDSEG^HLOMSG(.HLMSTATE,.SEG)
End DoDot:4
End DoDot:3
End DoDot:2
+42 IF HLMSTATE("UNSTORED LINES")
IF HLCSTATE("MESSAGE ENDED")
IF $$SAVEMSG^HLOF778(.HLMSTATE)
End DoDot:1
+43 ;
+44 IF STORE
IF 'HLCSTATE("MESSAGE ENDED")
Begin DoDot:1
+45 ;reading failed, don't store
+46 if HLMSTATE("IEN")
DO DEL778(HLMSTATE("IEN"))
if HLMSTATE("BODY")
DO DEL777(HLMSTATE("BODY"))
+47 SET HLMSTATE("IEN")=""
SET HLMSTATE("BODY")=""
End DoDot:1
+48 IF '$TEST
if STORE
Begin DoDot:1
+49 DO CHECKMSG(.HLMSTATE)
+50 ;so future duplicates are detected
DO ADDAC(.HLMSTATE)
+51 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
+52 ;
+53 if 'HLCSTATE("MESSAGE ENDED")
DO CLOSE^HLOT(.HLCSTATE)
+54 QUIT HLCSTATE("MESSAGE ENDED")
+55 ;
ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
+1 ;
+2 NEW FROM
+3 SET FROM=$SELECT(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+4 SET ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
+5 QUIT
+6 ;
DUP(HLMSTATE) ;
+1 ;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 ;
+9 NEW IEN,FROM,DUP
+10 SET (IEN,DUP)=0
+11 ;
+12 ;no way to determine! Bad header will be rejected
+13 if (HLMSTATE("ID")="")
QUIT 0
+14 ;
+15 SET FROM=$SELECT(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+16 FOR
SET IEN=$ORDER(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN))
if 'IEN
QUIT
Begin DoDot:1
+17 IF HLMSTATE("HDR","ACCEPT ACK TYPE")="NE"
SET DUP=1
QUIT
+18 ;need the MSA to return
+19 Begin DoDot:2
+20 NEW NODE
+21 SET NODE=$PIECE($GET(^HLB(IEN,4)),"^",3,10)
+22 SET HLMSTATE("MSA",1)=$PIECE(NODE,"|",2)
+23 if $LENGTH(HLMSTATE("MSA",1))'=2
QUIT
+24 SET HLMSTATE("MSA",2)=$PIECE(NODE,"|",3)
+25 SET HLMSTATE("MSA",3)=$PIECE(NODE,"|",4,10)
+26 SET DUP=1
End DoDot:2
QUIT
End DoDot:1
if DUP
QUIT
+27 ;
+28 QUIT DUP
+29 ;
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")="ER" 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,ERROR
+11 MERGE HDR=HLMSTATE("HDR")
+12 SET ERROR=0
+13 IF HDR("ACCEPT ACK TYPE")="NE"
IF 'HLMSTATE("ORIGINAL MODE")
Begin DoDot:1
+14 SET WANTACK=0
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET WANTACK=1
End DoDot:1
+17 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")="ER"
QUIT
+18 IF $GET(HLMSTATE("ACK TO"))=""
Begin DoDot:1
+19 ;
+20 IF '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE)
SET ERROR=1
if WANTACK
SET HLMSTATE("MSA",1)="CR"
SET HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED"
SET HLMSTATE("STATUS")="ER"
QUIT
+21 SET HLMSTATE("STATUS","ACTION")=$GET(ACTION)
SET HLMSTATE("STATUS","QUEUE")=$GET(QUEUE)
End DoDot:1
if ERROR
QUIT
+22 ;this is an app ack
IF '$TEST
Begin DoDot:1
+23 ;does the original message exist?
+24 NEW NODE
+25 if +$GET(HLMSTATE("ACK TO IEN"))
SET NODE=$GET(^HLB(+HLMSTATE("ACK TO IEN"),0))
+26 IF $GET(NODE)=""
SET ERROR=1
SET HLMSTATE("STATUS")="ER"
SET HLMSTATE("ACK TO IEN")=""
if WANTACK
SET HLMSTATE("MSA",1)="CE"
SET HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND"
QUIT
+27 IF $PIECE(NODE,"^",7)'=""
IF $PIECE(NODE,"^",7)'=HLMSTATE("ID")
SET ERROR=1
SET HLMSTATE("STATUS")="ER"
SET HLMSTATE("ACK TO IEN")=""
if WANTACK
SET HLMSTATE("MSA",1)="CE"
SET HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED"
QUIT
+28 ;
+29 SET HLMSTATE("STATUS","QUEUE")=$SELECT($PIECE(NODE,"^",6)]"":$PIECE(NODE,"^",6),1:"DEFAULT")
+30 IF ($PIECE(NODE,"^",11)]"")
SET HLMSTATE("STATUS","ACTION")=$PIECE(NODE,"^",10,11)
QUIT
+31 ;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
+32 IF HLMSTATE("HDR","MESSAGE TYPE")="ACK"
IF HLMSTATE("HDR","EVENT")=""
SET HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO IEN"))
+33 ;
+34 IF $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE)
SET HLMSTATE("STATUS","ACTION")=$GET(ACTION)
if HLMSTATE("STATUS","QUEUE")="DEFAULT"
SET HLMSTATE("STATUS","QUEUE")=QUEUE
End DoDot:1
if ERROR
QUIT
+35 ;
+36 IF HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID")
if WANTACK
SET HLMSTATE("MSA",1)="CR"
SET HLMSTATE("STATUS")="ER"
SET HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID")
QUIT
+37 ;
+38 ;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.
+39 SET PASS=0
+40 Begin DoDot:1
+41 ;if its an ack to an existing message, don't check the receiving facility
+42 IF $GET(HLMSTATE("ACK TO"))]""
SET PASS=1
QUIT
+43 IF HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION")
SET PASS=1
QUIT
+44 IF HDR("RECEIVING FACILITY",3)'="DNS"
SET PASS=1
QUIT
+45 IF HDR("RECEIVING FACILITY",2)=""
SET PASS=1
QUIT
+46 IF $PIECE(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN")
SET PASS=1
QUIT
+47 IF HLCSTATE("SYSTEM","DOMAIN")[$PIECE(HDR("RECEIVING FACILITY",2),":")
SET PASS=1
QUIT
End DoDot:1
+48 IF 'PASS
SET HLMSTATE("STATUS")="ER"
SET HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN")
if WANTACK
SET HLMSTATE("MSA",1)="CE"
+49 IF PASS
IF WANTACK
SET HLMSTATE("MSA",1)="CA"
+50 QUIT
+51 ;
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
