source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m@ 1397

HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/04/2007  14:34
 ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132,122**;Oct 13, 1995;Build 14
 ;Per VHA Directive 2004-038, this routine should not be modified.
 ;
 ;The SEND function is invoked by the transaction processor.
 ;It's function is to $O through the ITEM multiple of the Event Driver
 ;Protocol and create child entries in the Message Text file (#772)
 ;for the message at HLMTIEN.  These child messages point back
 ;to the parent message so that message text does not need to
 ;be duplicated when a message is sent to multiple applications.
 ;
 ;The SENDACK function is also invoked by the transaction processor.
 ;It's function is to create a child entry in the Message Text file
 ;for the message at HLMTIENA and deliver the message to the
 ;application the requested/sent information.
 ;
 ;For DHCP to DHCP messaging (i.e. internal to internal), an incoming
 ;message is created in the Message Text file which is a duplication
 ;of the outgoing message.  The incoming message is then processed by
 ;calling the transaction processor.
 ;
 ;For DHCP to COTS messaging (i.e. internal to external), the message
 ;is filed in the Message Text file with the Logical Link defined and
 ;a status of PENDING TRANSMISSION.  These entries are picked up by
 ;the background filer and transmitted to the appropriate COTS system.
 ;
SEND(HLMTIEN,HLEID,HLRESULT) ;Send an HL7 message
 ;HLMTIEN=The IEN of the parent message in file # 772
 ;HLEID=The IEN of the Event Driver protocol in file #101
 ;HLRESULT=Variable for any error text (pass by reference)
 ;
 ;Declare variables
 N HLARY,HLERROR,HLEIDS,HLCLIENT,HLOGLINK,HLMTIENS,HLMSGPTR
 S HLERROR=""
 ;Direct connect
 I HLPRIO="I" D  Q
 . D DC^HLMA2
 . S HLRESULT=HLERROR
 ;Get all subscribers to the message
 D ITEM^HLUTIL2(HLEID,"PTR")
 ;Quit if no subscribers (considered successful delivery)
 G:($G(HLARY(0))'>0) EXIT
 ;Deliver message to each subscriber
 S HLEIDS=0
 F  S HLEIDS=$O(HLARY(HLEIDS)) Q:(HLEIDS'>0)  D
 .;
 .;**132 excluded subscribers **
 .N I,EXCLUDE
 .S (EXCLUDE,I)=0
 . ;
 . ; patch HL*1.6*122
 . ; F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
 . F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  D  Q:EXCLUDE
 .. N TEMP
 .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
 .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
 .. I TEMP=HLEIDS S EXCLUDE=1
 . ; patch HL*1.6*122
 . ;
 .Q:EXCLUDE
 .;** 132 end **
 .;
 .;Get pointer to receiving application
 .S HLCLIENT=+HLARY(HLEIDS),HL("EIDS")=HLEIDS,HLERROR=""
 .Q:(HLCLIENT'>0)
 .;Check and execute ROUTING LOGIC **CIRN**
 .S HLX=$G(^ORD(101,HLEIDS,774))
 .I HLX]"" D  Q
 ..N HLQUIT,HLNODE,HLNEXT
 ..S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
 ..X HLX I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN**
 .;Get pointer to logical link
 .S HLOGLINK=$P(HLARY(HLEIDS),"^",2)
 .;Determine if receiving application is internal or external
 .;  Logical link has a value for external applications
 .;  Logical link is NULL for internal applications
 .I (HLOGLINK) D COTS Q
 .;Create 'incoming' message based on 'outgoing' message (internal)
 .D DHCP(HLMTIEN,HLEIDS,HLCLIENT)
 .Q:(HLERROR)
 .;Process the 'incoming' message
 .S HLERROR=""
 .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR)
 .;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED
 .; or ERROR DURING TRANSMISSION
 .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:""),,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0))
 .I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN**
 D ADD^HLCS2 ;**CIRN**
EXIT S HLRESULT=HLERROR
 Q
COTS ;Internal to external communication
 ;Create child entry in Message Text file
 N HLTCP,HLTCPI,HLTCPO
 D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS,HLOGLINK)
 I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q
 ;'Pass' message to background filer by setting status of child
 ;  to PENDING TRANSMISSION
 D STATUS^HLTF0(HLMTIENS,1)
 Q
DHCP(HLMTIEN,HLEIDS,HLCLIENT) ;Internal to internal communication
 ;
 ;Input  : HLMTIEN - Pointer to parent outgoing message (file #772)
 ;         HLEIDS - Pointer to subscribing protocol (file #101)
 ;         HLCLIENT - Pointer to receiving application (file # 771)
 ;
 ;Output : HLMTIENS - Pointer to child outgoing message (file #772)
 ;         HLMSGPTR - Pointer to [parent] incoming message (file #772)
 ;         HLERROR - ErrorCode ^ ErrorText
 ;
 ;Notes  : This module only copies the outgoing message into an incoming
 ;         message.  Delivery of the message (i.e. processing of it)
 ;         must be done by the calling application.
 ;       : Message/batch header (MSH/BSH) is built and placed in the
 ;         incoming message
 ;       : HLMTIENS, HLMSGPTR, and HLERROR will be initialized
 ;       : Existance and validity of input is assumed
 ;
 ;Declare variables
 N MSGID,MSGDT,MSGDTH,HDR2BLD,TMP,HLHDR,BHSHDR
 S HLERROR=""
 S HLMTIENS=0
 S HLMSGPTR=0
 ;Create child entry in Message Text file
 D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS)
 I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q
 ;'Receive' message by making an incoming message
 ;Determine type of header to build
 S TMP=$G(^HL(772,HLMTIEN,0))
 S HDR2BLD=$P(TMP,"^",14)
 ;Build message header (MSH)
 I (HDR2BLD="M") D  Q:(HLERROR)
 .S TMP=""
 .D HEADER^HLCSHDR(HLMTIENS,.TMP)
 .Q:(TMP="")
 .;Error building header
 .S HLERROR="4^Unable to build message header => "_TMP
 .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2))
 ;Build batch header (BHS or FHS)
 I (HDR2BLD'="M") D  Q:(HLERROR)
 .S TMP=""
 .D BHSHDR^HLCSHDR(HLMTIENS)
 .S:($E(HLHDR(1),1)="-") TMP=$P(HLHDR(1),"^",2)
 .Q:(TMP="")
 .;Error building header
 .S HLERROR="4^Unable to build batch header => "_TMP
 .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2))
 ;Create entry for 'incoming' message
 D CREATE^HLTF(.MSGID,.HLMSGPTR,.MSGDT,.MSGDTH)
 ;Move header and rest of message into 'incoming' message
 I (HDR2BLD="M") D
 .;Use MSH as header
 .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"HLHDR")
 I (HDR2BLD'="M") D
 .;Use BHS or FHS as header
 .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"BHSHDR")
 ;Set status of outgoing message to AWAITING ACKNOWLEDGEMENT
 D STATUS^HLTF0(HLMTIENS,$S($P(^HL(772,HLMTIEN,0),U,7):3,1:2))
 ;Set status of 'incoming' message to AWAITING PROCESSING
 D STATUS^HLTF0(HLMSGPTR,9)
 Q
SENDACK(HLMTIENA,HLEID,HLEIDS,HLRESULT) ;Send an HL7 acknowledgement/response
 ;HLMTIENA=The IEN of the parent acknowledgment/response message in
 ;         file # 772
 ;HLEIDS=The IEN of the Subscribing protocol in file # 101
 ;HLEID=The IEN of the Event Driver protocol in file #101
 ;HLRESULT=Variable for any error text (pass by reference)
 ;
 N HLERROR,HLOGLINK,HLCLIENT,HLMTIENS,HLMSGPTR,HLCLNODE
 I $G(HLMTIENA)=""!($G(HLEID)="")!($G(HLEIDS)="") S HLERROR="0^7^"_$G(^HL(771.7,7,0))_"at SENDACK^HLCS entry point" G EXIT2
 S HLCLNODE=$G(^ORD(101,HLEID,770))
 ;Get pointers to Logical Link & receiving application
 S HLOGLINK=$P($G(^ORD(101,HLEIDS,770)),U,7)
 ;Application needed to dynamically address the ACK (tcp/ip)
 ;(set HLL("LINKS") array before calling GENACK)
 I $D(HLL("LINKS")) D  Q:'HLOGLINK
 .S HLOGLINK=$P(HLL("LINKS",1),"^",2) Q:HLOGLINK=""
 .K HLL("LINKS")
 .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0))
 S HLCLIENT=$P(HLCLNODE,U,1)
 Q:('HLCLIENT)
 ;Determine if receiving application is internal or external
 ;  Logical link has a value for external applications
 ;  Logical link is NULL for internal applications
 I (HLOGLINK) D COTSACK Q
 ;Create 'incoming' message based on 'outgoing' message (internal)
 D DHCP(HLMTIENA,HLEID,HLCLIENT)
 ;Process the 'incoming' message
 I (HLMSGPTR) D
 .S HLERROR=""
 .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR)
 ;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED
 ; or ERROR DURING TRANSMISSION
 D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:""))
EXIT2 ;
 S HLRESULT=$G(HLERROR)
 Q
COTSACK ;Internal to external communication of acknowledgements/responses
 ;Create child entry in Message Text file
 D SEND^HLMA2(HLEID,HLMTIENA,HLCLIENT,"D",.HLMTIENS,HLOGLINK)
 ;'Pass' message to background filer by setting status of child
 ;  to PENDING TRANSMISSION
 D STATUS^HLTF0(HLMTIENS,1)
 Q