source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP01.m@ 1310

Last change on this file since 1310 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1HLTP01 ;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))
102EXIT K HL,HLHDR,HLMSA
103 Q
Note: See TracBrowser for help on using the repository browser.