| 1 | HLTP01 ;AISC/SAW-Transaction Processor Module (Cont'd) ;02/16/2000 11:15
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,47,60**;Oct 13, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | ;Validate message header
|
|---|
| 5 | D CHK^HLTPCK1(HLHDR,.HL,$S($G(HLMSA)'="":$P(HLMSA,$E(HLHDR,4),2,4),1:""))
|
|---|
| 6 | ;
|
|---|
| 7 | ;Change stored message ID to match that of the incoming message
|
|---|
| 8 | S HL("TMP")=$$CHNGMID^HLTF(HLMTIEN,HL("MID"))
|
|---|
| 9 | ;
|
|---|
| 10 | ;Remember new message ID if it was changed
|
|---|
| 11 | I ('HL("TMP")) S HLMID=HL("MID")
|
|---|
| 12 | ;
|
|---|
| 13 | ;Update zero node in Message Text file of incoming message
|
|---|
| 14 | D UPDATE^HLTF0(HLMTIEN,$S($D(HL("MTIENS")):HL("MTIENS"),1:HLMTIEN),"I",$G(HL("EID")),"",$G(HL("SAP")),"I")
|
|---|
| 15 | ;
|
|---|
| 16 | ;Update status of incoming message
|
|---|
| 17 | D STATUS^HLTF0(HLMTIEN,$S($G(HL):4,1:9),$S($G(HL):+HL,1:""),$S($G(HL):$P(HL,"^",2),1:""))
|
|---|
| 18 | ;
|
|---|
| 19 | ;Update Logical Link file statistics for message received through MailMan
|
|---|
| 20 | ;The protocols associated with dynamically addressed messages
|
|---|
| 21 | ;should not have a logical link defined.
|
|---|
| 22 | ;This results in the monitor not being updated correctly and
|
|---|
| 23 | ;acks cannot be addressed properly.
|
|---|
| 24 | ;Get sender from mailman variable XMFROM and try to resolve link from
|
|---|
| 25 | ;domain info (pointer in 870).
|
|---|
| 26 | I HLLD0="XM",$G(XMFROM)]"" D
|
|---|
| 27 | .N HLDOM,HLLINK,HLROUT
|
|---|
| 28 | .S HLDOM=$P(XMFROM,"@",2)
|
|---|
| 29 | .I $G(HL("EIDS"))]"" S HL("LL")=$P(^ORD(101,HL("EIDS"),770),U,7),HLROUT=$G(^ORD(101,HL("EIDS"),774))
|
|---|
| 30 | .Q:$G(HLROUT)=""
|
|---|
| 31 | .D LINK^HLUTIL3(HLDOM,.HLLINK,"D")
|
|---|
| 32 | .I $O(HLLINK(0)) S HL("LL")=$O(HLLINK(0))
|
|---|
| 33 | .;If Ack is required, dynamically address it to sender:
|
|---|
| 34 | .;Note-first piece (recipient) not required here
|
|---|
| 35 | .I $O(HLLINK(0)) S $P(HLL("LINKS",1),U,2)=HL("LL")
|
|---|
| 36 | I HLLD0="XM",$G(HL("LL"))]"" D
|
|---|
| 37 | . S X=$$ENQUEUE^HLCSQUE(HL("LL"),"IN")
|
|---|
| 38 | . D MONITOR^HLCSDR2("P",2,HL("LL"),$P(X,U,2),"IN")
|
|---|
| 39 | ;
|
|---|
| 40 | ;Quit if this is acknowledgment to acknowledgement message
|
|---|
| 41 | I $G(HL("ACK")) D G EXIT
|
|---|
| 42 | .;Update status of original acknowledgment message to successfully
|
|---|
| 43 | .; completed if no error occurred
|
|---|
| 44 | .I '$G(HL) D STATUS^HLTF0(HL("MTIENS"),3)
|
|---|
| 45 | ;
|
|---|
| 46 | ;Create message ID and Message Text IEN for subscriber entry in Message
|
|---|
| 47 | ; Text file - carry over message ID of original message
|
|---|
| 48 | S HLMIDS=HLMID
|
|---|
| 49 | D CREATE^HLTF(.HLMIDS,.HLMTIENS,.HLDTS,.HLDT1S)
|
|---|
| 50 | K HLDTS,HLDT1S,HLMIDS
|
|---|
| 51 | ;
|
|---|
| 52 | ;Update zero node in Message Text file of subscriber entry
|
|---|
| 53 | D UPDATE^HLTF0(HLMTIENS,HLMTIEN,"I",$G(HL("EIDS")),$G(HL("RAP")),"","I")
|
|---|
| 54 | ;
|
|---|
| 55 | ;Create and send COMMIT acknowledgment if required
|
|---|
| 56 | I $G(HLMSA)="",$G(HL("RAP"))&$G(HL("SAP")) D
|
|---|
| 57 | .I '$D(HL("ACAT")),'$D(HL("APAT")),'HL Q
|
|---|
| 58 | .I $G(HL("ACAT"))="NE" Q
|
|---|
| 59 | .I $G(HL("ACAT"))="ER",'HL Q
|
|---|
| 60 | .I $G(HL("ACAT"))="SU",HL Q
|
|---|
| 61 | .;Version 2.1 messages always ORIGINAL MODE-application must generate
|
|---|
| 62 | .;ack. if error in hdr, hl7 rejects-quits.
|
|---|
| 63 | .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)
|
|---|
| 64 | .;I $D(HLA("HLA")) S HLP("MSACK")=1 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
|
|---|
| 65 | .S HLP("MSACK")=1
|
|---|
| 66 | .;added next line to save off HL* variables due to recursive call;sfciofo/ac
|
|---|
| 67 | .N HLSAVE M HLSAVE=HL
|
|---|
| 68 | .D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
|
|---|
| 69 | .I $D(HLSAVE) M HL=HLSAVE
|
|---|
| 70 | ;
|
|---|
| 71 | ;Quit processing if error with header
|
|---|
| 72 | ;Potential problem with patch 25 that may affect internal DHCP to DHCP
|
|---|
| 73 | ;messaging. As a test, replaced next line with following line to correct:
|
|---|
| 74 | ;I HL'="" S HLRESLT=HL G EXIT
|
|---|
| 75 | I $G(HL)]"" S HLRESLT=HL G EXIT
|
|---|
| 76 | ;Comment out next line. Potential problem with patch 34 affecting
|
|---|
| 77 | ;dhcp to dhcp messaging:
|
|---|
| 78 | ;I HL("TMP")'=0 S HLRESLT="13^"_$P(HL("TMP"),"^",2)
|
|---|
| 79 | I $G(HL("TMP")) S HLRESLT="13^"_$P(HL("TMP"),"^",2)
|
|---|
| 80 | ;
|
|---|
| 81 | ;Set special HL variables
|
|---|
| 82 | S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
|
|---|
| 83 | ;
|
|---|
| 84 | ;Check if message is an acknowledgement
|
|---|
| 85 | I ($G(HLMSA)'="") D G EXIT
|
|---|
| 86 | .;Update status of original subscriber message
|
|---|
| 87 | .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)))
|
|---|
| 88 | .D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
|
|---|
| 89 | ;
|
|---|
| 90 | ;Get entry action, exit action and processing routine
|
|---|
| 91 | K HLHDR,HLLD0,HLLD1,HLMSA
|
|---|
| 92 | I $G(HL("EIDS"))="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN**
|
|---|
| 93 | D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
|
|---|
| 94 | S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15))
|
|---|
| 95 | S HLPROU=$G(HLN(771)) I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) G EXIT
|
|---|
| 96 | ;
|
|---|
| 97 | ;Execute entry action of client protocol
|
|---|
| 98 | X:HLENROU]"" HLENROU K HLENROU
|
|---|
| 99 | ;
|
|---|
| 100 | ;Execute processing routine
|
|---|
| 101 | X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0))
|
|---|
| 102 | EXIT K HL,HLHDR,HLMSA
|
|---|
| 103 | Q
|
|---|
