HLTP01 ;AISC/SAW-Transaction Processor Module (Cont'd) ;02/16/2000  11:15
 ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,47,60**;Oct 13, 1995
 ;
 ;Validate message header
 D CHK^HLTPCK1(HLHDR,.HL,$S($G(HLMSA)'="":$P(HLMSA,$E(HLHDR,4),2,4),1:""))
 ;
 ;Change stored message ID to match that of the incoming message
 S HL("TMP")=$$CHNGMID^HLTF(HLMTIEN,HL("MID"))
 ;
 ;Remember new message ID if it was changed
 I ('HL("TMP")) S HLMID=HL("MID")
 ;
 ;Update zero node in Message Text file of incoming message
 D UPDATE^HLTF0(HLMTIEN,$S($D(HL("MTIENS")):HL("MTIENS"),1:HLMTIEN),"I",$G(HL("EID")),"",$G(HL("SAP")),"I")
 ;
 ;Update status of incoming message
 D STATUS^HLTF0(HLMTIEN,$S($G(HL):4,1:9),$S($G(HL):+HL,1:""),$S($G(HL):$P(HL,"^",2),1:""))
 ;
 ;Update Logical Link file statistics for message received through MailMan
 ;The protocols associated with dynamically addressed messages
 ;should not have a logical link defined.
 ;This results in the monitor not being updated correctly and
 ;acks cannot be addressed properly.
 ;Get sender from mailman variable XMFROM and try to resolve link from
 ;domain info (pointer in 870).
 I HLLD0="XM",$G(XMFROM)]"" D
 .N HLDOM,HLLINK,HLROUT
 .S HLDOM=$P(XMFROM,"@",2)
 .I $G(HL("EIDS"))]"" S HL("LL")=$P(^ORD(101,HL("EIDS"),770),U,7),HLROUT=$G(^ORD(101,HL("EIDS"),774))
 .Q:$G(HLROUT)=""
 .D LINK^HLUTIL3(HLDOM,.HLLINK,"D")
 .I $O(HLLINK(0)) S HL("LL")=$O(HLLINK(0))
 .;If Ack is required, dynamically address it to sender:
 .;Note-first piece (recipient) not required here
 .I $O(HLLINK(0)) S $P(HLL("LINKS",1),U,2)=HL("LL")
 I HLLD0="XM",$G(HL("LL"))]"" D
 . S X=$$ENQUEUE^HLCSQUE(HL("LL"),"IN")
 . D MONITOR^HLCSDR2("P",2,HL("LL"),$P(X,U,2),"IN")
 ;
 ;Quit if this is acknowledgment to acknowledgement message
 I $G(HL("ACK")) D  G EXIT
 .;Update status of original acknowledgment message to successfully
 .;  completed if no error occurred
 .I '$G(HL) D STATUS^HLTF0(HL("MTIENS"),3)
 ;
 ;Create message ID and Message Text IEN for subscriber entry in Message
 ;  Text file - carry over message ID of original message
 S HLMIDS=HLMID
 D CREATE^HLTF(.HLMIDS,.HLMTIENS,.HLDTS,.HLDT1S)
 K HLDTS,HLDT1S,HLMIDS
 ;
 ;Update zero node in Message Text file of subscriber entry
 D UPDATE^HLTF0(HLMTIENS,HLMTIEN,"I",$G(HL("EIDS")),$G(HL("RAP")),"","I")
 ;
 ;Create and send COMMIT acknowledgment if required
 I $G(HLMSA)="",$G(HL("RAP"))&$G(HL("SAP")) D
 .I '$D(HL("ACAT")),'$D(HL("APAT")),'HL Q
 .I $G(HL("ACAT"))="NE" Q
 .I $G(HL("ACAT"))="ER",'HL Q
 .I $G(HL("ACAT"))="SU",HL Q
 .;Version 2.1 messages always ORIGINAL MODE-application must generate
 .;ack. if error in hdr, hl7 rejects-quits.
 .S HLA("HLA",1)="MSA"_HL("FS")_$S(HL:$S(HL("VER")=2.1:"AR",1:"CR"),1:"CA")_HL("FS")_HL("MID")_HL("FS")_$P(HL,"^",2)
 .;I $D(HLA("HLA")) S HLP("MSACK")=1 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
 .S HLP("MSACK")=1
 .;added next line to save off HL* variables due to recursive call;sfciofo/ac
 .N HLSAVE M HLSAVE=HL
 .D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
 .I $D(HLSAVE) M HL=HLSAVE
 ;
 ;Quit processing if error with header
 ;Potential problem with patch 25 that may affect internal DHCP to DHCP
 ;messaging.  As a test, replaced next line with following line to correct:
 ;I HL'="" S HLRESLT=HL G EXIT
 I $G(HL)]"" S HLRESLT=HL G EXIT
 ;Comment out next line.  Potential problem with patch 34 affecting
 ;dhcp to dhcp messaging:
 ;I HL("TMP")'=0 S HLRESLT="13^"_$P(HL("TMP"),"^",2)
 I $G(HL("TMP")) S HLRESLT="13^"_$P(HL("TMP"),"^",2)
 ;
 ;Set special HL variables
 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
 ;
 ;Check if message is an acknowledgement
 I ($G(HLMSA)'="") D  G EXIT
 .;Update status of original subscriber message
 .D STATUS^HLTF0(HL("MTIENS"),$S("AA,CA"[$P(HLMSA,HL("FS"),2):3,1:4),"",$S("AA,CA"[$P(HLMSA,HL("FS"),2):"",1:$P(HLMSA,HL("FS"),3)))
 .D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
 ;
 ;Get entry action, exit action and processing routine
 K HLHDR,HLLD0,HLLD1,HLMSA
 I $G(HL("EIDS"))="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN**
 D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15))
 S HLPROU=$G(HLN(771)) I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) G EXIT
 ;
 ;Execute entry action of client protocol
 X:HLENROU]"" HLENROU K HLENROU
 ;
 ;Execute processing routine
 X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0))
EXIT K HL,HLHDR,HLMSA
 Q