Routine: HLTP01

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTP01   4520     printed  Mar 13, 2025@21:04:51                                                                                                                                                                                                      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

HLTP01.m