Routine: HLTP01

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

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

HLTP01.m