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