HLTP01 ;AISC/SAW-Transaction Processor Module (Cont'd) ;02/16/2000 11:15 [ 04/02/2003 8:38 AM ]
;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
;;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
HLTP01 ;AISC/SAW-Transaction Processor Module (Cont'd) ;02/16/2000 11:15 [ 04/02/2003 8:38 AM ]
+1 ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
+2 ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,47,60**;Oct 13, 1995
+3 ;
+4 ;Validate message header
+5 DO CHK^HLTPCK1(HLHDR,.HL,$SELECT($GET(HLMSA)'="":$PIECE(HLMSA,$EXTRACT(HLHDR,4),2,4),1:""))
+6 ;
+7 ;Change stored message ID to match that of the incoming message
+8 SET HL("TMP")=$$CHNGMID^HLTF(HLMTIEN,HL("MID"))
+9 ;
+10 ;Remember new message ID if it was changed
+11 IF ('HL("TMP"))
SET HLMID=HL("MID")
+12 ;
+13 ;Update zero node in Message Text file of incoming message
+14 DO UPDATE^HLTF0(HLMTIEN,$SELECT($DATA(HL("MTIENS")):HL("MTIENS"),1:HLMTIEN),"I",$GET(HL("EID")),"",$GET(HL("SAP")),"I")
+15 ;
+16 ;Update status of incoming message
+17 DO STATUS^HLTF0(HLMTIEN,$SELECT($GET(HL):4,1:9),$SELECT($GET(HL):+HL,1:""),$SELECT($GET(HL):$PIECE(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 IF HLLD0="XM"
IF $GET(XMFROM)]""
Begin DoDot:1
+27 NEW HLDOM,HLLINK,HLROUT
+28 SET HLDOM=$PIECE(XMFROM,"@",2)
+29 IF $GET(HL("EIDS"))]""
SET HL("LL")=$PIECE(^ORD(101,HL("EIDS"),770),U,7)
SET HLROUT=$GET(^ORD(101,HL("EIDS"),774))
+30 IF $GET(HLROUT)=""
QUIT
+31 DO LINK^HLUTIL3(HLDOM,.HLLINK,"D")
+32 IF $ORDER(HLLINK(0))
SET HL("LL")=$ORDER(HLLINK(0))
+33 ;If Ack is required, dynamically address it to sender:
+34 ;Note-first piece (recipient) not required here
+35 IF $ORDER(HLLINK(0))
SET $PIECE(HLL("LINKS",1),U,2)=HL("LL")
End DoDot:1
+36 IF HLLD0="XM"
IF $GET(HL("LL"))]""
Begin DoDot:1
+37 SET X=$$ENQUEUE^HLCSQUE(HL("LL"),"IN")
+38 DO MONITOR^HLCSDR2("P",2,HL("LL"),$PIECE(X,U,2),"IN")
End DoDot:1
+39 ;
+40 ;Quit if this is acknowledgment to acknowledgement message
+41 IF $GET(HL("ACK"))
Begin DoDot:1
+42 ;Update status of original acknowledgment message to successfully
+43 ; completed if no error occurred
+44 IF '$GET(HL)
DO STATUS^HLTF0(HL("MTIENS"),3)
End DoDot:1
GOTO EXIT
+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 SET HLMIDS=HLMID
+49 DO CREATE^HLTF(.HLMIDS,.HLMTIENS,.HLDTS,.HLDT1S)
+50 KILL HLDTS,HLDT1S,HLMIDS
+51 ;
+52 ;Update zero node in Message Text file of subscriber entry
+53 DO UPDATE^HLTF0(HLMTIENS,HLMTIEN,"I",$GET(HL("EIDS")),$GET(HL("RAP")),"","I")
+54 ;
+55 ;Create and send COMMIT acknowledgment if required
+56 IF $GET(HLMSA)=""
IF $GET(HL("RAP"))&$GET(HL("SAP"))
Begin DoDot:1
+57 IF '$DATA(HL("ACAT"))
IF '$DATA(HL("APAT"))
IF 'HL
QUIT
+58 IF $GET(HL("ACAT"))="NE"
QUIT
+59 IF $GET(HL("ACAT"))="ER"
IF 'HL
QUIT
+60 IF $GET(HL("ACAT"))="SU"
IF HL
QUIT
+61 ;Version 2.1 messages always ORIGINAL MODE-application must generate
+62 ;ack. if error in hdr, hl7 rejects-quits.
+63 SET HLA("HLA",1)="MSA"_HL("FS")_$SELECT(HL:$SELECT(HL("VER")=2.1:"AR",1:"CR"),1:"CA")_HL("FS")_HL("MID")_HL("FS")_$PIECE(HL,"^",2)
+64 ;I $D(HLA("HLA")) S HLP("MSACK")=1 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
+65 SET HLP("MSACK")=1
+66 ;added next line to save off HL* variables due to recursive call;sfciofo/ac
+67 NEW HLSAVE
MERGE HLSAVE=HL
+68 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP)
+69 IF $DATA(HLSAVE)
MERGE HL=HLSAVE
End DoDot:1
+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 IF $GET(HL)]""
SET HLRESLT=HL
GOTO 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 IF $GET(HL("TMP"))
SET HLRESLT="13^"_$PIECE(HL("TMP"),"^",2)
+80 ;
+81 ;Set special HL variables
+82 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+83 ;
+84 ;Check if message is an acknowledgement
+85 IF ($GET(HLMSA)'="")
Begin DoDot:1
+86 ;Update status of original subscriber message
+87 DO STATUS^HLTF0(HL("MTIENS"),$SELECT("AA,CA"[$PIECE(HLMSA,HL("FS"),2):3,1:4),"",$SELECT("AA,CA"[$PIECE(HLMSA,HL("FS"),2):"",1:$PIECE(HLMSA,HL("FS"),3)))
+88 DO PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
End DoDot:1
GOTO EXIT
+89 ;
+90 ;Get entry action, exit action and processing routine
+91 KILL HLHDR,HLLD0,HLLD1,HLMSA
+92 ;**CIRN**
IF $GET(HL("EIDS"))=""
IF $GET(HLEIDS)]""
SET HL("EIDS")=HLEIDS
+93 DO EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
+94 SET HLENROU=$GET(HLN(20))
SET HLEXROU=$GET(HLN(15))
+95 SET HLPROU=$GET(HLN(771))
IF HLPROU']""
SET HLRESLT="10^"_$GET(^HL(771.7,10,0))
GOTO EXIT
+96 ;
+97 ;Execute entry action of client protocol
+98 IF HLENROU]""
XECUTE HLENROU
KILL HLENROU
+99 ;
+100 ;Execute processing routine
+101 XECUTE HLPROU
SET HLRESLT=0
IF ($DATA(HLERR))
SET HLRESLT="9^"_$GET(^HL(771.7,9,0))
EXIT KILL HL,HLHDR,HLMSA
+1 QUIT
