Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m

-              r613
+              r623
+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
+HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132**;Oct 13, 1995;Build 6
+ ;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
+ .F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
+ .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

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m

-              r613
+              r623
+HLCS2   ;SF/JC - More Communication Server utilities ; 10/04/2007  14:31
+        ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+FWD     ; Add supplemental clients from HLL("LINKS") to HLSUP array
+        ;This enhancement also supports distribution of a message to
+        ;the same client over multiple logical links.
+        Q:'$D(HLL("LINKS"))
+        N CNT,LNK,CLIAP
+        S CNT=0,ROUTINE=1 F  S CNT=$O(HLL("LINKS",CNT)) Q:CNT<1  D
+        . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2)
+        . Q:PTR=""  I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1
+        . ;
+        . ; patch HL*1.6*122: excluding subscribers defined in
+        . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber
+        . N I,EXCLUDE
+        . S (EXCLUDE,I)=0
+        . 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=PTR S EXCLUDE=1
+        . Q:EXCLUDE
+        . ;
+        . Q:LNK=""  I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1
+        . Q:'$D(^HLCS(870,LNK))
+        . S CLIAP=$$PTR^HLUTIL2(PTR)
+        . ; patch HL*1.6*122: add the 3rd component as receiving facility
+        . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
+        . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3))
+        Q
+ADD     ;Deliver message to supplemental client list.
+        ;Invoked by HLTP before and after processing normal clients
+        ;Only processes remote links. Local clients must be subscribing
+        ;protocols.
+        Q:'$D(HLSUP("S"))
+        N HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS
+        S ZHLEIDS=0 F  S ZHLEIDS=$O(HLSUP("S",ZHLEIDS)) Q:ZHLEIDS<1  D
+        .S ZLOGLINK=0 F  S ZLOGLINK=$O(HLSUP("S",ZHLEIDS,ZLOGLINK)) Q:ZLOGLINK<1  D
+        ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
+        ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q
+        .. ; patch HL*1.6*122 start
+        .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
+        .. S HLOGLINK=ZLOGLINK
+        .. ; 3rd component for receiving facility
+        .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3)
+        .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK)
+        .. D STATUS^HLTF0(+ZMTIENS,1)
+        .. ; patch HL*1.6*122 end
+        .. ;
+        K HLL("LINKS"),HLSUP
+        Q
+STALL   ;STOP ALL LINKS AND FILERS
+        N DIR,Y
+        W ! S DIR(0)="Y",DIR("A")="Okay to shut down all Links and Filers"
+        D ^DIR
+        I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"Shutdown Aborted!" Q
+        W !,"Shutting down all Links and Filers..."
+        D CLEAR
+        D LLP(1)
+        Q
+QUE     ;Restart Filers and AUTOSTART Logical Links after system re-boot
+        N DIR,Y
+        I '$D(ZTQUEUED) D  Q:'Y!($D(DIRUT))!($D(DUOUT))
+        .W ! S DIR(0)="Y",DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay"
+        .D ^DIR
+        .I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"RESTART Aborted!" Q
+        .W !,"Restarting all Autostart-Enabled Links and Filers..."
+        D CLEAR
+        D STARTF
+        D LLP(0)
+        D STRT
+        Q
+CLEAR   ;Reset state of 869.3
+        S DA(1)=1,DA=0,DIK="^HLCS(869.3,1,2,"
+        F  S DA=$O(^HLCS(869.3,DA(1),2,DA)) Q:DA<1  D ^DIK
+        S DA=0,DIK="^HLCS(869.3,1,3,"
+        F  S DA=$O(^HLCS(869.3,DA(1),3,DA)) Q:DA<1  D ^DIK
+        Q
+STARTF  ;Start filers
+        ;Get Defaults
+        N TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1
+        S PTR=+$O(^HLCS(869.3,0)) Q:'PTR
+        ;default # of incoming filers
+        S HLNODE1=$G(^HLCS(869.3,PTR,1)),DEFCNT=+$P(HLNODE1,U) S:'DEFCNT DEFCNT=1
+        F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("IN")
+        ;default # of outgoing filers
+        S DEFCNT=+$P(HLNODE1,U,2) S:'DEFCNT DEFCNT=1
+        F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("OUT")
+        Q
+LLP(ALL)        ;Stop Logical Links
+        ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped
+        N HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y S HLDP=0
+        F  S HLDP=$O(^HLCS(870,HLDP)) Q:'HLDP  S HLDP0=$G(^(HLDP,0)),X=+$P(HLDP0,U,3) D:X
+        .;skip this link if not stopping all and Autostart not enabled
+        . I 'ALL&('$P(HLDP0,U,6)) Q
+        . S HLPARM4=$G(^HLCS(870,HLDP,400))
+        . ; patch HL*1.6*122
+        . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
+        . ; or Cache/VMS
+        . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
+        . ;
+        . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
+        . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+        . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting"
+        . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown"
+        . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109
+        . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
+        .. ; pass task number to stop listener
+        .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12))
+        ; patch HL*1.6*122 start
+        ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+        ; .. I POP D HOME^%ZIS Q
+        ; .. D CLOSE^%ZISTCP
+        ; patch HL*1.6*122 end
+        Q
+STRT    ;Start Links
+        N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU
+        S HLDP=0
+        F  S HLDP=$O(^HLCS(870,HLDP)) Q:HLDP<1  S HLDP0=$G(^(HLDP,0)) D
+        . S HLPARM4=$G(^HLCS(870,HLDP,400))
+        . ;quit if no parameters or AUTOSTART is disabled
+        . Q:'$P(HLDP0,U,6)
+        . ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check
+        . S HLDAPP=$P(HLDP0,U),HLTYPTR=+$P(HLDP0,U,3),HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200))
+        . ;quit if no LL type or no routine
+        . Q:'HLTYPTR!(HLBGR="")
+        . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
+        . ; patch HL*1.6*122
+        . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
+        . ; or Cache/VMS
+        . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
+        . ;
+        . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  Q
+        .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+        .. ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+        .. N HLJ,X
+        .. I $P(HLDP0,U,15)=0 Q
+        .. L +^HLCS(870,HLDP,0):2
+        .. E  Q
+        .. S X="HLJ(870,"""_HLDP_","")"
+        .. S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+        .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6*109
+        .. L -^HLCS(870,HLDP,0)
+        .. Q
+        . S ZTRTN=$P(HLBGR," ",2),ZTIO="",ZTDTH=$H,HLTRACE=""
+        . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+        . ;get startup node
+        . I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U)
+        . D ^%ZTLOAD
+        Q
+SITEP   ;Edit Site Parameters
+        S DDSFILE=869.3,DA=1,DR="[HL SITE PARAMETERS]" D ^DDS
+        Q
+PARAM() ;Return HL7 site parameters
+        ;HLPARAM=domain ien^domain name^production or test^institution ien^
+        ;institution name^institution number^mail group ien^mail group name^
+        ;purge completed messages^purge awaiting ack messages^purge all msgs^
+        ;default retention
+        N HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET
+        S HLX=$G(^HLCS(869.3,1,0))
+        S HLX4=$G(^HLCS(869.3,1,4))
+        S HLX5=$G(^HLCS(869.3,1,5))
+        S HLDOMP=$P(HLX,U,2) I HLDOMP S HLDOMN=$P(^DIC(4.2,HLDOMP,0),U)
+        S HLPROD=$P(HLX,U,3)
+        S HLINSP=$P(HLX,U,4) I HLINSP S HLINSN=$P(^DIC(4,HLINSP,0),U),HLINSNM=$P($G(^DIC(4,HLINSP,99)),U)
+        S HLMAILP=$P(HLX,U,5) I HLMAILP S HLMAILN=$P(^XMB(3.8,HLMAILP,0),U)
+        S HLPRGCMP=$P(HLX4,U),HLPRGAA=$P(HLX4,U,2),HLPRGALL=$P(HLX4,U,3)
+        S HLDEFRET=$P(HLX5,U)
+        S HLPARAM=HLDOMP_U_$G(HLDOMN)_U_$G(HLPROD)_U_HLINSP_U_$G(HLINSN)_U_$G(HLINSNM)_U_HLMAILP_U_$G(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET
+        Q HLPARAM
+        ;
+GETAPP(HLAPP)   ;Function to Retrieve parameters pertaining to a specific sending or receiving application
+        ;HLAPP=APPLICATION NAME OR IEN OF FILE 771
+        ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive)
+        S HLAPP=$G(HLAPP)
+        I HLAPP]"",'HLAPP S HLAPP=$O(^HL(771,"B",$E(HLAPP,1,30),0))
+        I 'HLAPP Q ""
+        I HLAPP S HLM=$P(^HL(771,HLAPP,0),U,4)
+        I HLM S HLM=$P($G(^XMB(3.8,HLM,0)),U)
+        Q $G(HLM)_U_$P(^HL(771,HLAPP,0),U,2)
+HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/2003  17:50
+ ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109**;Oct 13, 1995
+FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array
+ ;This enhancement also supports distribution of a message to
+ ;the same client over multiple logical links.
+ Q:'$D(HLL("LINKS"))
+ N CNT,LNK,CLIAP
+ S CNT=0,ROUTINE=1 F  S CNT=$O(HLL("LINKS",CNT)) Q:CNT<1  D
+ . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2)
+ . Q:PTR=""  I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1
+ . Q:LNK=""  I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1
+ . Q:'$D(^HLCS(870,LNK))
+ . S CLIAP=$$PTR^HLUTIL2(PTR)
+ . S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
+ Q
+ADD ;Deliver message to supplemental client list.
+ ;Invoked by HLTP before and after processing normal clients
+ ;Only processes remote links. Local clients must be subscribing
+ ;protocols.
+ Q:'$D(HLSUP("S"))
+ N HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS
+ S ZHLEIDS=0 F  S ZHLEIDS=$O(HLSUP("S",ZHLEIDS)) Q:ZHLEIDS<1  D
+ .S ZLOGLINK=0 F  S ZLOGLINK=$O(HLSUP("S",ZHLEIDS,ZLOGLINK)) Q:ZLOGLINK<1  D
+ ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
+ ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q
+ ..S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
+ K HLL("LINKS"),HLSUP
+ Q
+STALL ;STOP ALL LINKS AND FILERS
+ N DIR,Y
+ W ! S DIR(0)="Y",DIR("A")="Okay to shut down all Links and Filers"
+ D ^DIR
+ I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"Shutdown Aborted!" Q
+ W !,"Shutting down all Links and Filers..."
+ D CLEAR
+ D LLP(1)
+ Q
+QUE ;Restart Filers and AUTOSTART Logical Links after system re-boot
+ N DIR,Y
+ I '$D(ZTQUEUED) D  Q:'Y!($D(DIRUT))!($D(DUOUT))
+ .W ! S DIR(0)="Y",DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay"
+ .D ^DIR
+ .I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"RESTART Aborted!" Q
+ .W !,"Restarting all Autostart-Enabled Links and Filers..."
+ D CLEAR
+ D STARTF
+ D LLP(0)
+ D STRT
+ Q
+CLEAR ;Reset state of 869.3
+ S DA(1)=1,DA=0,DIK="^HLCS(869.3,1,2,"
+ F  S DA=$O(^HLCS(869.3,DA(1),2,DA)) Q:DA<1  D ^DIK
+ S DA=0,DIK="^HLCS(869.3,1,3,"
+ F  S DA=$O(^HLCS(869.3,DA(1),3,DA)) Q:DA<1  D ^DIK
+ Q
+STARTF ;Start filers
+ ;Get Defaults
+ N TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1
+ S PTR=+$O(^HLCS(869.3,0)) Q:'PTR
+ ;default # of incoming filers
+ S HLNODE1=$G(^HLCS(869.3,PTR,1)),DEFCNT=+$P(HLNODE1,U) S:'DEFCNT DEFCNT=1
+ F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("IN")
+ ;default # of outgoing filers
+ S DEFCNT=+$P(HLNODE1,U,2) S:'DEFCNT DEFCNT=1
+ F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("OUT")
+ Q
+LLP(ALL) ;Stop Logical Links
+ ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped
+ N HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y S HLDP=0
+ F  S HLDP=$O(^HLCS(870,HLDP)) Q:'HLDP  S HLDP0=$G(^(HLDP,0)),X=+$P(HLDP0,U,3) D:X
+ .;skip this link if not stopping all and Autostart not enabled
+ . I 'ALL&('$P(HLDP0,U,6)) Q
+ . S HLPARM4=$G(^HLCS(870,HLDP,400))
+ . ;TCP Multi listener for non-Cache uses UCX
+ . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
+ . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
+ . S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+ . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown"
+ . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109
+ . ;Cache system, need to open TCP port to release job
+ . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
+ .. ;pass task number to stop listener
+ .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12))
+ .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ .. I POP D HOME^%ZIS Q
+ .. D CLOSE^%ZISTCP
+ Q
+STRT ;Start Links
+ N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU
+ S HLDP=0
+ F  S HLDP=$O(^HLCS(870,HLDP)) Q:HLDP<1  S HLDP0=$G(^(HLDP,0)) D
+ . S HLPARM4=$G(^HLCS(870,HLDP,400))
+ . ;quit if no parameters or AUTOSTART is disabled
+ . Q:'$P(HLDP0,U,6)
+ . ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check
+ . S HLDAPP=$P(HLDP0,U),HLTYPTR=+$P(HLDP0,U,3),HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200))
+ . ;quit if no LL type or no routine
+ . Q:'HLTYPTR!(HLBGR="")
+ . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
+ . ;TCP Multi listener for non-Cache uses UCX
+ . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
+ . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  Q
+ .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+ .. ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+ .. N HLJ,X
+ .. I $P(HLDP0,U,15)=0 Q
+ .. L +^HLCS(870,HLDP,0):2
+ .. E  Q
+ .. S X="HLJ(870,"""_HLDP_","")"
+ .. S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+ .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6*109
+ .. L -^HLCS(870,HLDP,0)
+ .. Q
+ . S ZTRTN=$P(HLBGR," ",2),ZTIO="",ZTDTH=$H,HLTRACE=""
+ . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+ . ;get startup node
+ . I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U)
+ . D ^%ZTLOAD
+ Q
+SITEP ;Edit Site Parameters
+ S DDSFILE=869.3,DA=1,DR="[HL SITE PARAMETERS]" D ^DDS
+ Q
+PARAM() ;Return HL7 site parameters
+ ;HLPARAM=domain ien^domain name^production or test^institution ien^
+ ;institution name^institution number^mail group ien^mail group name^
+ ;purge completed messages^purge awaiting ack messages^purge all msgs^
+ ;default retention
+ N HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET
+ S HLX=$G(^HLCS(869.3,1,0))
+ S HLX4=$G(^HLCS(869.3,1,4))
+ S HLX5=$G(^HLCS(869.3,1,5))
+ S HLDOMP=$P(HLX,U,2) I HLDOMP S HLDOMN=$P(^DIC(4.2,HLDOMP,0),U)
+ S HLPROD=$P(HLX,U,3)
+ S HLINSP=$P(HLX,U,4) I HLINSP S HLINSN=$P(^DIC(4,HLINSP,0),U),HLINSNM=$P($G(^DIC(4,HLINSP,99)),U)
+ S HLMAILP=$P(HLX,U,5) I HLMAILP S HLMAILN=$P(^XMB(3.8,HLMAILP,0),U)
+ S HLPRGCMP=$P(HLX4,U),HLPRGAA=$P(HLX4,U,2),HLPRGALL=$P(HLX4,U,3)
+ S HLDEFRET=$P(HLX5,U)
+ S HLPARAM=HLDOMP_U_$G(HLDOMN)_U_$G(HLPROD)_U_HLINSP_U_$G(HLINSN)_U_$G(HLINSNM)_U_HLMAILP_U_$G(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET
+ Q HLPARAM
+ ;
+GETAPP(HLAPP) ;Function to Retrieve parameters pertaining to a specific sending or receiving application
+ ;HLAPP=APPLICATION NAME OR IEN OF FILE 771
+ ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive)
+ S HLAPP=$G(HLAPP)
+ I HLAPP]"",'HLAPP S HLAPP=$O(^HL(771,"B",$E(HLAPP,1,30),0))
+ I 'HLAPP Q ""
+ I HLAPP S HLM=$P(^HL(771,HLAPP,0),U,4)
+ I HLM S HLM=$P($G(^XMB(3.8,HLM,0)),U)
+ Q $G(HLM)_U_$P(^HL(771,HLAPP,0),U,2)

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m

-              r613
+              r623
+HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM,
+        ;    HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port
+        ;    number.
+        ; 2. find the ien of #870(logical link file) for the multi-listener
+        Q
+        ;
+IEN(HLPORT)     ;
+        ; HLIEN870: ien in #870 (logical link file)
+        ; HLPRTS: port number in entry to be tested
+        ;
+        N HLPRTS,HLIEN870
+        I '$G(HLPORT) D ^%ZTER Q
+        S HLIEN870=0
+        F  S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870  D  Q:(HLPRTS=HLPORT)
+        . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2)
+        I 'HLIEN870 D ^%ZTER Q
+        ;
+        Q HLIEN870
+        ;
+GTMLNX  ; From Linux xinetd script
+        ;Get port from ZSHOW "D"
+        S U="^",$ZT="",$ET="D ^%ZTER HALT" ;Setup the error trap
+        ; GTM specific code
+        S IO=$P X "U IO:(nowrap:nodelimiter:IOERROR=""TRAP"")" ;Setup device
+        S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+        K ^TMP($J) ZSHOW "D":^TMP($J)
+        F %=1:1 Q:'$D(^TMP($J,"D",%))  S X=^(%) Q:X["LOCAL"
+        S IO("IP")=$P($P(X,"REMOTE=",2),"@"),IO("PORT")=+$P($P(X,"LOCAL=",2),"@",2)
+        S %=$P($ZTRNLNM("SSH_CLIENT")," ") S:%="" %=$ZTRNLNM("REMOTEHOST")
+        S HLDP=$$IEN(IO("PORT"))
+        ;
+        D LISTEN^HLCSTCP
+        Q
+        ;
+        ;Sample Linux script
+        ;#!/bin/bash
+        ;#HL7 Listener
+        ;cd /home/vista/dev/
+        ;. ./gtmprofile
+        ;#env > hl7log.txt
+        ;$gtm_dist/mumps -r GTMLNX^HLCSGTM
+        ;exit 0
+        ;
+        ;Sample xinetd config file
+        ;service hl7tcp
+        ;{
+        ;        socket_type     = stream
+        ;        user            = gtmuser
+        ;        wait            = no
+        ;        disable         = no
+        ;        server          = /bin/bash
+        ;        server_args     = -l /home/vista/dev/hl7tcp.sh
+        ;        passenv         = REMOTE_HOST
+        ;}
+HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM,
+ ;    HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port
+ ;    number.
+ ; 2. find the ien of #870(logical link file) for the multi-listener
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ Q
+ ;
+IEN(HLPORT) ;
+ ; HLIEN870: ien in #870 (logical link file)
+ ; HLPRTS: port number in entry to be tested
+ ;
+ N HLPRTS,HLIEN870
+ I '$G(HLPORT) D ^%ZTER Q
+ S HLIEN870=0
+ F  S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870  D  Q:(HLPRTS=HLPORT)
+ . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2)
+ I 'HLIEN870 D ^%ZTER Q
+ ;
+ Q HLIEN870
+ ;
+GTMLNX ; From Linux xinetd script
+ ;Get port from ZSHOW "D"
+ S U="^",$ZT="",$ET="D ^%ZTER HALT" ;Setup the error trap
+ ; GTM specific code
+ S IO=$P X "U IO:(nowrap:nodelimiter:IOERROR=""TRAP"")" ;Setup device
+ S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+ K ^TMP($J) ZSHOW "D":^TMP($J)
+ F %=1:1 Q:'$D(^TMP($J,"D",%))  S X=^(%) Q:X["LOCAL"
+ S IO("IP")=$P($P(X,"REMOTE=",2),"@"),IO("PORT")=+$P($P(X,"LOCAL=",2),"@",2)
+ S %=$P($ZTRNLNM("SSH_CLIENT")," ") S:%="" %=$ZTRNLNM("REMOTEHOST")
+ S HLDP=$$IEN(IO("PORT"))
+ ;
+ D LISTEN^HLCSTCP
+ Q
+ ;
+ ;Sample Linux script
+ ;#!/bin/bash
+ ;#HL7 Listener
+ ;cd /home/vista/dev/
+ ;. ./gtmprofile
+ ;#env > hl7log.txt
+ ;$gtm_dist/mumps -r GTMLNX^HLCSGTM
+ ;exit 0
+ ;
+ ;Sample xinetd config file
+ ;service hl7tcp
+ ;{
+ ;        socket_type     = stream
+ ;        user            = gtmuser
+ ;        wait            = no
+ ;        disable         = no
+ ;        server          = /bin/bash
+ ;        server_args     = -l /home/vista/dev/hl7tcp.sh
+ ;        passenv         = REMOTE_HOST
+ ;}

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m

-              r613
+              r623
+HLCSHDR1        ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+HEADER(IEN,CLIENT,HLERROR)      ; Create an HL7 MSH segment
+        ;
+        ;Input  : IEN - Pointer to entry in Message Administration file (#773)
+        ;               that HL7 MSH segment is being built for
+        ;         CLIENT - IEN of the receiving application
+        ;         HLERROR - Variable to return possible error text in
+        ;                   (pass by reference - only used when needed)
+        ;
+        ;Output : HLHDR(1) - HL7 MSH segment
+        ;         HLHDR(2) - Continuation of HL7 MSH segment (if needed)
+        ;         HLHDR(3) - Continuation of HL7 MSH segment (if needed)
+        ;
+        ;Notes  : HLERROR will only be defined [on output] if an error occurs
+        ;       : HLHDR() will not be defined [on output] if an error occurs
+        ;       : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
+        ;         and will only be used/defined when needed
+        ;
+        N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN
+        N COMFLAG ; patch HL*1.6*120
+        S HLERROR=""
+        S HLPARAM=$$PARAM^HLCS2
+        D VAR Q:$G(HLERROR)]""
+        ; The following line commented by HL*1.6*72
+        ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+        ;Append event type
+        I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
+        ;Append message structure component
+        I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
+        ;Build MSH array
+        D RESET^HLCSHDR3 ;HL*1.6*93
+        ;
+        ; patch HL*1.6*120 start
+        ; escape delimiters for SERAPP and CLNTAPP
+        ; escape component separator if the field is not consisted
+        ; of 3 components
+        S EC(1)=$E(EC,1)
+        S EC(2)=$E(EC,2)
+        S EC(3)=$E(EC,3)
+        S EC(4)=$E(EC,4)
+        S COMFLAG=1
+        I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
+        I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
+        . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
+        S COMFLAG=1
+        I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
+        I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
+        . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
+        ; patch HL*1.6*120 end
+        ;
+        S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
+        F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X)
+        ;in preceeding line, "" is for sequence number - not supported
+        Q
+        ;
+MSH(X)  ;add X to HLHDR
+        S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
+        S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
+        Q
+BHSHDR(IEN,CLIENT,HLERROR)      ; Create Batch Header Segment
+        ; The BHS has 12 segments, of which 4 are blank.
+        ; INPUT: IEN - IEN of entry in file #772
+        ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
+        ;   ready for adding to a message directly.
+        N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
+        N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
+        N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
+        N COMFLAG ; patch HL*1.6*120
+        S HLERROR=""
+        ;
+        S HLPARAM=$$PARAM^HLCS2
+        D VAR Q:$G(HLERROR)]""
+        ; The following line commented by HL*1.6*72
+        ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+        ;
+        ;Append event type
+        I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
+        ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
+        S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80
+        ;for batch ACK
+        I ACKTO D  S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
+        . ;get msg id and status of message that is being ACKed
+        . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
+        . ;set type of ACK based on status
+        . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
+        ;
+        D RESET^HLCSHDR3 ;HL*1.6*93
+        ;
+        ; patch HL*1.6*120 start
+        ; escape delimiters for SERAPP and CLNTAPP
+        ; escape component separator if the field is not consisted
+        ; of 3 components
+        S EC(1)=$E(EC,1)
+        S EC(2)=$E(EC,2)
+        S EC(3)=$E(EC,3)
+        S EC(4)=$E(EC,4)
+        S COMFLAG=1
+        I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
+        I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
+        . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
+        S COMFLAG=1
+        I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
+        I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
+        . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
+        ; patch HL*1.6*120 end
+        ;
+        S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
+        F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
+        Q
+VAR     ;Check input
+        N APPPRM,HLPROTS,HLPROT
+        S IEN=+$G(IEN)
+        I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
+        I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
+        ;Get child, text pointer,text entry, and sending app.
+        S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
+        I ('SEND) S HLERROR="Could not determine sending application" Q
+        ;Get info for sending & receiving applications
+        D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
+        ;Get name of sending application, facility, and country
+        S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
+        ;Get name of receiving application and facility
+        S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
+        ;
+        ; patch HL*1.6*120
+        ; for dynamic addressing, overide the receiving facility from the
+        ; 3rd component of HLL("LINKS") array
+        I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
+        ;
+        ;Get field separator & encoding characters
+        S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
+        S:(EC="") EC="~|\&" S:(FS="") FS="^"
+        ;Determine if it's a response/ACK to another message
+        S ACKTO=+$P(CHILD,U,10)
+        ;subscriber protocol is from child (file 773)
+        ;If response, get MType from subscriber
+        S HLPROTS=+$P(CHILD,U,8)
+        S PROTS=$$TYPE^HLUTIL2(HLPROTS)
+        I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
+        ;Get accept ack & application ack type (based on server protocol) it
+        ; is always in file 772, TXPT0
+        ;If original message, get MT from Event Driver Protocol
+        S HLPROT=+$P(TXTP0,U,10)
+        S PROT=$$TYPE^HLUTIL2(HLPROT)
+        S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
+        S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
+        ;
+        ; patch HL*1.6*122
+        ; setting the MSH-15 and MSH-16 from subscriber protocol
+        I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
+        . S ACCACK=$P(PROTS,U,7)
+        . S APPACK=$P(PROTS,U,8)
+        ;
+PID     ;Processing ID
+        ;I PID not 'debug' get from site params
+        ;If event driver set to 'debug' get from protocol
+        ;'production' or 'training' comes from site params
+        S HLPID=$P(PROT,U,5)
+        I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
+        ;
+        ; patch HL*1.6*120: to include processing mode
+        I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
+        . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
+        ;
+        I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
+        ;acknowledgements have no application ack, link open no commit ack
+        I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
+        ;Get date/time, Message ID, and security
+        S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
+HDR23   ;generate extended facility field info based on 'facility required'
+        ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
+        ;application parameter entry overrides default
+        N HLEP773,HLS773
+        S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
+        S HLEP773=+$G(^ORD(101,HLPROTS,773))
+        S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
+        Q:'HLEP773&('HLS773)
+        D GEN^HLCSHDR2
+        I ACKTO D  Q
+        .;Find original message
+        .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
+        .I X["MSH" D
+        ..;
+        ..; patch HL*1.6*120 start
+        .. N HLEC
+        ..S HLFS=$E(X,4),HLEC=$E(X,5)
+        ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
+        ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
+        ..S EC("COMPONENT")=$E($G(EC),1)
+        ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
+        ... ; change the the component separator in the sending and
+        ... ; receiving facilities for the outgoing message
+        ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
+        ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
+        ; patch HL*1.6*120 end
+        ;
+        I HLEP773,SERFAC="" D EP^HLCSHDR2
+        I HLS773,CLNTFAC="" D S^HLCSHDR2
+        Q
+        ;
+ESCAPE(INPUT,COMPONET)  ;
+        ; patch HL*1.6*120 - escape delimiters:
+        ; - field separator
+        ; - component separator
+        ; - repetition separator
+        ; - escape character
+        ; - subcomponent separator
+        ;
+        ; input:
+        ;     INPUT - string data to be escaped
+        ;  COMPONET - if 1, escape component separator
+        ;             if 0, do not escape component separator
+        ;        FS - field separator character
+        ;        EC - encoding characters
+        ; result: return the escaped string
+        ;
+        N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
+        S HLDATA=$G(INPUT)
+        S COMFLAG=$G(COMPONET)
+        Q:$L($G(FS))'=1 HLDATA
+        ;
+        ; patch HL*1.6*133
+        ; Q:$L($G(EC))'=4 HLDATA
+        Q:($L($G(EC))<3) HLDATA
+        Q:HLDATA']"" HLDATA
+        ;
+        S HLESCAPE=FS_EC
+        S HLESCAPE("F")=FS
+        S HLESCAPE("S")=$E(EC,1)
+        S HLESCAPE("R")=$E(EC,2)
+        S HLESCAPE("E")=$E(EC,3)
+        S HLESCAPE("T")=$E(EC,4)
+        S HLEN=$L(HLDATA)
+        S HLOUT=""
+        F HLI=1:1:HLEN D
+        . S HLCHAR=$E(HLDATA,HLI)
+        . I HLESCAPE[HLCHAR D  Q
+        .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
+        .. I HLCHAR=HLESCAPE("S") D  Q
+        ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
+        ... S HLOUT=HLOUT_HLCHAR
+        .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
+        .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
+        .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
+        . ;
+        . S HLOUT=HLOUT_HLCHAR
+        Q HLOUT
+HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment
+ ;
+ ;Input  : IEN - Pointer to entry in Message Administration file (#773)
+ ;               that HL7 MSH segment is being built for
+ ;         CLIENT - IEN of the receiving application
+ ;         HLERROR - Variable to return possible error text in
+ ;                   (pass by reference - only used when needed)
+ ;
+ ;Output : HLHDR(1) - HL7 MSH segment
+ ;         HLHDR(2) - Continuation of HL7 MSH segment (if needed)
+ ;         HLHDR(3) - Continuation of HL7 MSH segment (if needed)
+ ;
+ ;Notes  : HLERROR will only be defined [on output] if an error occurs
+ ;       : HLHDR() will not be defined [on output] if an error occurs
+ ;       : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
+ ;         and will only be used/defined when needed
+ ;
+ N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN
+ N COMFLAG ; patch HL*1.6*120
+ S HLERROR=""
+ S HLPARAM=$$PARAM^HLCS2
+ D VAR Q:$G(HLERROR)]""
+ ; The following line commented by HL*1.6*72
+ ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+ ;Append event type
+ I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
+ ;Append message structure component
+ I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
+ ;Build MSH array
+ D RESET^HLCSHDR3 ;HL*1.6*93
+ ;
+ ; patch HL*1.6*120 start
+ ; escape delimiters for SERAPP and CLNTAPP
+ ; escape component separator if the field is not consisted
+ ; of 3 components
+ S EC(1)=$E(EC,1)
+ S EC(2)=$E(EC,2)
+ S EC(3)=$E(EC,3)
+ S EC(4)=$E(EC,4)
+ S COMFLAG=1
+ I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
+ I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
+ . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
+ S COMFLAG=1
+ I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
+ I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
+ . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
+ ; patch HL*1.6*120 end
+ ;
+ S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
+ F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X)
+ ;in preceeding line, "" is for sequence number - not supported
+ Q
+ ;
+MSH(X) ;add X to HLHDR
+ S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
+ S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
+ Q
+BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment
+ ; The BHS has 12 segments, of which 4 are blank.
+ ; INPUT: IEN - IEN of entry in file #772
+ ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
+ ;   ready for adding to a message directly.
+ N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
+ N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
+ N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
+ N COMFLAG ; patch HL*1.6*120
+ S HLERROR=""
+ ;
+ S HLPARAM=$$PARAM^HLCS2
+ D VAR Q:$G(HLERROR)]""
+ ; The following line commented by HL*1.6*72
+ ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+ ;
+ ;Append event type
+ I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
+ ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
+ S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80
+ ;for batch ACK
+ I ACKTO D  S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
+ . ;get msg id and status of message that is being ACKed
+ . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
+ . ;set type of ACK based on status
+ . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
+ ;
+ D RESET^HLCSHDR3 ;HL*1.6*93
+ ;
+ ; patch HL*1.6*120 start
+ ; escape delimiters for SERAPP and CLNTAPP
+ ; escape component separator if the field is not consisted
+ ; of 3 components
+ S EC(1)=$E(EC,1)
+ S EC(2)=$E(EC,2)
+ S EC(3)=$E(EC,3)
+ S EC(4)=$E(EC,4)
+ S COMFLAG=1
+ I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
+ I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
+ . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
+ S COMFLAG=1
+ I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
+ I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
+ . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
+ ; patch HL*1.6*120 end
+ ;
+ S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
+ F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
+ Q
+VAR ;Check input
+ N APPPRM,HLPROTS,HLPROT
+ S IEN=+$G(IEN)
+ I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
+ I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
+ ;Get child, text pointer,text entry, and sending app.
+ S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
+ I ('SEND) S HLERROR="Could not determine sending application" Q
+ ;Get info for sending & receiving applications
+ D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
+ ;Get name of sending application, facility, and country
+ S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
+ ;Get name of receiving application and facility
+ S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
+ ;
+ ; patch HL*1.6*120
+ ; for dynamic addressing, overide the receiving facility from the
+ ; 3rd component of HLL("LINKS") array
+ I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
+ ;
+ ;Get field separator & encoding characters
+ S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
+ S:(EC="") EC="~|\&" S:(FS="") FS="^"
+ ;Determine if it's a response/ACK to another message
+ S ACKTO=+$P(CHILD,U,10)
+ ;subscriber protocol is from child (file 773)
+ ;If response, get MType from subscriber
+ S HLPROTS=+$P(CHILD,U,8)
+ S PROTS=$$TYPE^HLUTIL2(HLPROTS)
+ I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
+ ;Get accept ack & application ack type (based on server protocol) it
+ ; is always in file 772, TXPT0
+ ;If original message, get MT from Event Driver Protocol
+ S HLPROT=+$P(TXTP0,U,10)
+ S PROT=$$TYPE^HLUTIL2(HLPROT)
+ S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
+ S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
+PID ;Processing ID
+ ;I PID not 'debug' get from site params
+ ;If event driver set to 'debug' get from protocol
+ ;'production' or 'training' comes from site params
+ S HLPID=$P(PROT,U,5)
+ I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
+ ;
+ ; patch HL*1.6*120: to include processing mode
+ I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
+ . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
+ ;
+ I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
+ ;acknowledgements have no application ack, link open no commit ack
+ I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
+ ;Get date/time, Message ID, and security
+ S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
+HDR23 ;generate extended facility field info based on 'facility required'
+ ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
+ ;application parameter entry overrides default
+ N HLEP773,HLS773
+ S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
+ S HLEP773=+$G(^ORD(101,HLPROTS,773))
+ S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
+ Q:'HLEP773&('HLS773)
+ D GEN^HLCSHDR2
+ I ACKTO D  Q
+ .;Find original message
+ .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
+ .I X["MSH" D
+ ..;
+ ..; patch HL*1.6*120 start
+ .. N HLEC
+ ..S HLFS=$E(X,4),HLEC=$E(X,5)
+ ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
+ ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
+ ..S EC("COMPONENT")=$E($G(EC),1)
+ ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
+ ... ; change the the component separator in the sending and
+ ... ; receiving facilities for the outgoing message
+ ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
+ ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
+ ; patch HL*1.6*120 end
+ ;
+ I HLEP773,SERFAC="" D EP^HLCSHDR2
+ I HLS773,CLNTFAC="" D S^HLCSHDR2
+ Q
+ ;
+ESCAPE(INPUT,COMPONET) ;
+ ; patch HL*1.6*120 - escape delimiters:
+ ; - field separator
+ ; - component separator
+ ; - repetition separator
+ ; - escape character
+ ; - subcomponent separator
+ ;
+ ; input:
+ ;     INPUT - string data to be escaped
+ ;  COMPONET - if 1, escape component separator
+ ;             if 0, do not escape component separator
+ ;        FS - field separator character
+ ;        EC - encoding characters
+ ; result: return the escaped string
+ ;
+ N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
+ S HLDATA=$G(INPUT)
+ S COMFLAG=$G(COMPONET)
+ Q:$L($G(FS))'=1 HLDATA
+ ;
+ ; patch HL*1.6*133
+ ; Q:$L($G(EC))'=4 HLDATA
+ Q:($L($G(EC))<3) HLDATA
+ Q:HLDATA']"" HLDATA
+ ;
+ S HLESCAPE=FS_EC
+ S HLESCAPE("F")=FS
+ S HLESCAPE("S")=$E(EC,1)
+ S HLESCAPE("R")=$E(EC,2)
+ S HLESCAPE("E")=$E(EC,3)
+ S HLESCAPE("T")=$E(EC,4)
+ S HLEN=$L(HLDATA)
+ S HLOUT=""
+ F HLI=1:1:HLEN D
+ . S HLCHAR=$E(HLDATA,HLI)
+ . I HLESCAPE[HLCHAR D  Q
+ .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
+ .. I HLCHAR=HLESCAPE("S") D  Q
+ ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
+ ... S HLOUT=HLOUT_HLCHAR
+ .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
+ .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
+ .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
+ . ;
+ . S HLOUT=HLOUT_HLCHAR
+ Q HLOUT

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m

-              r613
+              r623
+HLCSHDR4        ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05
+        ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified
+        ;
+DEBUG(STORE)    ; If HLP set up for debugging, capture VIEW...
+        ; HLMSH773 -- req
+        ;
+        N NOW,NUM,VAR,VARS,X,XTMP
+        ;
+        ; 1=some, 2=all
+        S STORE=$S(STORE=1:1,STORE=2:2,1:0) QUIT:'STORE  ;->
+        ;
+        S NOW=$$NOW^XLFDT
+        ;
+        S XTMP="HLCSHDR3 "_HLMSH773
+        S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,4)_U_NOW_U_"Debug data created by DEBUG~HLCSHDR4"
+        ;
+        S NUM=$O(^XTMP(XTMP,":"),-1)+1
+        ;
+        ; Grab only critical (some) variables?
+        I STORE=1 D
+        .
+        .  ; Sending information...
+        .  S ^XTMP(XTMP,NUM,"SA")=HLMSHSAO_U_HLSAN_U_HLMSHSAN
+        .  S ^XTMP(XTMP,NUM,"SF")=HLMSHSFO_U_HLSFN_U_HLMSHSFN
+        .
+        .  ; Receiving information...
+        .  S ^XTMP(XTMP,NUM,"RA")=HLMSHRAO_U_HLRAN_U_HLMSHRAN
+        .  S ^XTMP(XTMP,NUM,"RF")=HLMSHRFO_U_HLRFN_U_HLMSHRFN
+        .
+        .  ; Other information...    (HLMSHPRE and HLMSHPRS hold 2 pieces!)
+        .  S ^XTMP(XTMP,NUM,0)=NOW_U_HLMSH772_U_HLMSHPRE_U_HLMSHPRS
+        .  S ^XTMP(XTMP,NUM,1)=HLMSHPRO
+        ;
+        ; Grab all variables?
+        I STORE=2 D
+        .  S X="^XTMP("""_XTMP_""","_NUM_","
+        .  D DOLRO^%ZOSV
+        ;
+        QUIT
+        ;
+SHOW    N I773
+        F  R !!,"Enter 773 IEN: ",I773:60 Q:I773'>0  D
+        .  D SHOW773(I773)
+        QUIT
+        ;
+SHOW773(I773)   ; Show Dynamic Routing MSH Field Reset Details
+        N DIV,MSH,N90,N91
+        ;
+        S N90=$G(^HLMA(+I773,90)),N91=$G(^HLMA(+I773,91))
+        I (N90_N91)']"" D  QUIT  ;->
+        .  W "  no debug data found..."
+        ;
+        S MSH=$G(^HLMA(+I773,"MSH",1,0)) QUIT:MSH']""  ;->
+        S DIV=$E(MSH,4)
+        ;
+        W !!,$$CJ^XLFSTR(" 773 # "_I773_" ",IOM,"=")
+        ;
+        D HDR(90,N90)
+        ;
+        W !
+        D HDR(91,N91)
+        ;
+        W !!,$E(MSH,1,IOM)
+        ;
+        S C1=10,C2=30,C3=50
+        W !!,?C1,"Original (91)",?2,"Array (90)",?3,"MSH-Segment"
+        W !,$$REPEAT^XLFSTR("-",IOM)
+        D LINE("snd app",1,2,3)
+        D LINE("snd fac",3,3,4)
+        D LINE("rec app",5,4,5)
+        D LINE("rec fac",7,5,6)
+        ;
+        QUIT
+        ;
+LINE(HDR,PCE1,PCE2,PCE3)        ; Print one comparison line...
+        N P1,P2,P3,P4
+        S P1=$P(N91,U,PCE1),P2=$P(N90,U,PCE2),P3=$P(MSH,DIV,PCE3),P4=$P(N91,U,PCE1+1)
+        W !,HDR,":",?C1,P1,?2,P2,?3,P3,$S(P4]"":" ["_P4_"]",1:"")
+        QUIT
+        ;
+HDR(NUM,DATA)   N TXT
+        S TXT=$S(NUM=90:"Array (90)",NUM=91:"Original (91)",1:"")
+        W !,$$CJ^XLFSTR("---------- "_TXT_" ----------",IOM)
+        W $$CJ^XLFSTR(DATA,IOM)
+        QUIT
+        ;
+SET(NEW,VAR,PCE)        ; This subroutine performs these actions:
+        ; (1) Resets variables used in MSH segment
+        ; (2) Resets SERAPP and CLNTAPP in ^HLMA(#,0)
+        ; (3) Sets HLMSH91 nodes if overwrite occurs by ARRAY value.
+        ;     If overwrite occurs by M code, the overwrite has already
+        ;     been recorded in HLMSH91.  (An overwrite produced by M code
+        ;     is never overwritten by ARRAY data.)
+        ;
+        N IEN771N,IEN771O,HLTCP
+        ;
+        ; VAR is the name of the variable, and not it's value...
+        S PRE=@VAR ; PRE is now the value of the VAR (pre-overwrite) variable...
+        ;
+        ; Tests whether anything was changed...
+        QUIT:NEW']""  ;-> No new value exists to change to...
+        QUIT:NEW=PRE  ;-> New value = Original value.  Nothing changed...
+        ;
+        ; THIS IS THE EPICENTER!!  This is where the variables used in
+        ; the MSH segment is overwritten.
+        S @VAR=NEW
+        ;
+        ; If PRE exists at this point, it was done by M code...
+        QUIT:$P(HLMSH91,U,PCE)]""  ;->
+        ;
+        ; Change was made, but not by M code.  Must be by array...
+        S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A"
+        ;
+        ; patch HL*1.6*122: for "^" as component separater
+        S $P(HLMSH91,U,PCE+2,999)=""
+        ;
+        ; Upgrade ^HLMA(#,0)...
+        QUIT:PCE'=1&(PCE'=5)  ;->
+        ;
+        ; patch HL*1.6*108 start
+        ;S IEN771O=$O(^HL(771,"B",PRE,0)) QUIT:IEN771O'>0  ;-> Orig IEN
+        ;S IEN771N=$O(^HL(771,"B",NEW,0)) QUIT:IEN771N'>0  ;-> New IEN
+        S IEN771O=$O(^HL(771,"B",$E(PRE,1,30),0)) QUIT:IEN771O'>0  ;-> Orig IEN
+        S IEN771N=$O(^HL(771,"B",$E(NEW,1,30),0)) QUIT:IEN771N'>0  ;-> New IEN
+        ; patch HL*1.6*108 end
+        ;
+        QUIT:'IEN771O!('IEN771N)!(IEN771O=IEN771N)  ;->
+        S HLTCP=1 ; So 773 is updated...
+        I PCE=1 D UPDATE^HLTF0(MTIENS,"","O","","",IEN771N)
+        I PCE=5 D UPDATE^HLTF0(MTIENS,"","O","",IEN771N)
+        ;
+        QUIT
+        ;
+FIELDS  ; Display the Protocol file fields used by the VistA HL7 package,
+        ; when messages are received, to find the event and subscriber
+        ; protocols.
+        N BY,DIC,DIOEND,L
+        ;
+        D HD
+        ;
+        W !
+        ;
+        S L="",DIC="^ORD(101,",BY="[HL PROTOCOL MESSAGING FIELDS]"
+        S DIOEND="D EXPL^HLCSHDR4"
+        D EN1^DIP
+        ;
+        Q
+        ;
+HD      W @IOF,$$CJ^XLFSTR("HL7 Protocol Messaging Fields",IOM)
+        W !,$$REPEAT^XLFSTR("=",IOM)
+        W !,"This 'HL7 Protocol Messaging Fields' report holds information that will help"
+        W !,"you determine the effects from changes to routing-related fields in the MSH"
+        W !,"segment when messages are sent between or within VistA HL7 systems."
+        W !,"Additional explanation is included at the bottom of the report."
+        Q
+        ;
+EXPL    N I,T QUIT:'$$EXPL1("Press RETURN for 'printout help', or '^' to exit... ")  X "F I=1:1 S T=$T(EXPL+I) QUIT:T'["";;""  W !,$P(T,"";;"",2,99)" S I=$$EXPL1("Press RETURN to exit... ",1)
+        ;;
+        ;;When messages are received, their SENDING APPLICATION (MSH-3), MESSAGE
+        ;;TYPE (MSH-9), EVENT TYPE (MSH-9), and HL7 VERSION (MSH-12) fields are used to
+        ;;find the event driver protocol to be used in processing the just-received
+        ;;message. After the event protocol is found, that protocol's subscriber
+        ;;protocols are evaluated.  The subscriber protocol with a RECEIVING
+        ;;APPLICATION value that matches the RECEIVING APPLICATION field in the MSH
+        ;;segment (MSH-5) is used.
+        ;;
+        ;;The first line for every "section" in the printout is the event driver
+        ;;protocol. Lines preceded by dashes, are related subscriber protocols.  An
+        ;;example is shown below.
+        ;;
+        ;;Snd/Rec App's    mTYP   eTYP   Ver        Protocol                     Link
+        ;;------------------------------------------------------------------------------
+        ;;AC-VOICERAD      ORU    R01    2.3    |   AC ORU SERVER
+        ;;-AC-RADIOLOGY    ORU    R01    2.3    |   AC ORU CLIENT                NC  TCP
+        ;;
+        ;;In this example, the 'AC-VOICERAD' line holds information for the 'AC ORU
+        ;;SERVER' event protocol.  And, the '-AC-RADIOLOGY' line holds information for
+        ;;the 'AC ORU CLIENT' subscriber protocol.
+        Q
+        ;
+EXPL1(PMT,FF)   ;
+        N DIR,DIRUT,DTOUT,DUOUT,X,Y
+        QUIT:$E($G(IOST),1,2)'="C-" 1 ;->
+        F X=1:1:$G(FF) W !
+        S DIR(0)="EA",DIR("A")=PMT
+        D ^DIR
+        QUIT $S(Y=1:1,1:"")
+        ;
+M       ; Covered by Integration Agreement #3988
+        ; Application developers may call here when creating new messages,
+        ; when experimenting with M code to evaluate and conditionally change
+        ; routing-related fields.
+        ;
+        ; This API is called immediately before the MSH segment is created.
+        N IOINHI,IOINORM,MSHOLD,MSHNEW,MSHPRE,X
+        ;
+        S X="IOINHI;IOINORM" D ENDR^%ZISS
+        ;
+        S MSHOLD=$$MSHBUILD(0),MSHPRE=$$MSHBUILD(1)
+        W !!,"The original MSH segment is...",!!,IOINHI,MSHOLD,IOINORM
+        I MSHPRE'=MSHOLD D
+        .  W !!,"The MSH segment, after modification by passed-in data, is..."
+        .  W !!,IOINHI,MSHPRE,IOINORM
+        ;
+        D MVAR("SENDING APPLICATION","HLMSHSAN","SERAPP")
+        D MVAR("SENDING FACILITY","HLMSHSFN","SERFAC")
+        D MVAR("RECEIVING APPLICATION","HLMSHRAN","CLNTAPP")
+        D MVAR("RECEIVING FACILITY","HLMSHRFN","CLNTFAC")
+        ;
+        S MSHNEW=$$MSHBUILD
+        I MSHNEW'=MSHPRE D
+        .  W !!,"Before your changes above, the modified MSH segment was..."
+        .  W !!,IOINHI,MSHPRE,IOINORM
+        .  W !!,"After your changes, the MSH segment is..."
+        .  W !!,IOINHI,MSHNEW,IOINORM
+        W !!,$$REPEAT^XLFSTR("-",IOM)
+        W !!,"Message being sent..."
+        W !
+        ;
+        Q
+        ;
+MVAR(FLD,VAR,VARO)      ; Generic resetting of variable...
+        ;IOINHI,IOINORM -- req
+        N ANS
+        W !!,?4,"Protocol-derived value of ",FLD,": "
+        W IOINHI,@VARO,IOINORM
+        W !,"Passed-in value of ",FLD," (",VAR,"): "
+        W IOINHI,@VAR,IOINORM
+        W !,?10,"Enter new value for ",FLD,": "
+        R ANS:60 Q:'$T  ;->
+        I ANS[U!(ANS']"") D
+        .  W !!,?10,"No changes will be made..."
+        I ANS'[U&(ANS]"") D
+        .  S @VAR=ANS
+        .  W !!,?10,"The variable ",IOINHI,VAR,IOINORM
+        .  W " will be changed to '",IOINHI,ANS,IOINORM,"'."
+        .  W !,?10,"This value will be stored in the ",FLD
+        .  W !,?10,"field in the MSH segment..."
+        .  W !!,$$REPEAT^XLFSTR("-",IOM)
+        Q
+        ;
+MSHBUILD(TYPE)  ; Build MSH using current variables...
+        N MSH,PCE,RAN,RFN,SAN,SFN
+        S MSH="MSH"_FS_EC
+        I $G(TYPE)=0 F PCE=SERAPP,SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
+        .  S MSH=MSH_FS_PCE
+        I $G(TYPE)'=0 D
+        .  S SAN=HLMSHSAN,SAN=$S(SAN]"":SAN,1:SERAPP)
+        .  S SFN=HLMSHSFN,SFN=$S(SFN]"":SFN,1:SERFAC)
+        .  S RAN=HLMSHRAN,RAN=$S(RAN]"":RAN,1:CLNTAPP)
+        .  S RFN=HLMSHRFN,RFN=$S(RFN]"":RFN,1:CLNTFAC)
+        .  F PCE=SAN,SFN,RAN,RFN,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
+        .  .  S MSH=MSH_FS_PCE
+        QUIT MSH
+        ;
+EOR     ;HLCSHDR4 - Reset MSH Segment Fields ;9/12/02 11:50
+HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;3/24/2004 14:27
+ ;;1.6;HEALTH LEVEL SEVEN;**93,108**;Oct 13, 1995
+ ;
+DEBUG(STORE) ; If HLP set up for debugging, capture VIEW...
+ ; HLMSH773 -- req
+ ;
+ N NOW,NUM,VAR,VARS,X,XTMP
+ ;
+ ; 1=some, 2=all
+ S STORE=$S(STORE=1:1,STORE=2:2,1:0) QUIT:'STORE  ;->
+ ;
+ S NOW=$$NOW^XLFDT
+ ;
+ S XTMP="HLCSHDR3 "_HLMSH773
+ S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,4)_U_NOW_U_"Debug data created by DEBUG~HLCSHDR4"
+ ;
+ S NUM=$O(^XTMP(XTMP,":"),-1)+1
+ ;
+ ; Grab only critical (some) variables?
+ I STORE=1 D
+ .
+ .  ; Sending information...
+ .  S ^XTMP(XTMP,NUM,"SA")=HLMSHSAO_U_HLSAN_U_HLMSHSAN
+ .  S ^XTMP(XTMP,NUM,"SF")=HLMSHSFO_U_HLSFN_U_HLMSHSFN
+ .
+ .  ; Receiving information...
+ .  S ^XTMP(XTMP,NUM,"RA")=HLMSHRAO_U_HLRAN_U_HLMSHRAN
+ .  S ^XTMP(XTMP,NUM,"RF")=HLMSHRFO_U_HLRFN_U_HLMSHRFN
+ .
+ .  ; Other information...    (HLMSHPRE and HLMSHPRS hold 2 pieces!)
+ .  S ^XTMP(XTMP,NUM,0)=NOW_U_HLMSH772_U_HLMSHPRE_U_HLMSHPRS
+ .  S ^XTMP(XTMP,NUM,1)=HLMSHPRO
+ ;
+ ; Grab all variables?
+ I STORE=2 D
+ .  S X="^XTMP("""_XTMP_""","_NUM_","
+ .  D DOLRO^%ZOSV
+ ;
+ QUIT
+ ;
+SHOW N I773
+ F  R !!,"Enter 773 IEN: ",I773:60 Q:I773'>0  D
+ .  D SHOW773(I773)
+ QUIT
+ ;
+SHOW773(I773) ; Show Dynamic Routing MSH Field Reset Details
+ N DIV,MSH,N90,N91
+ ;
+ S N90=$G(^HLMA(+I773,90)),N91=$G(^HLMA(+I773,91))
+ I (N90_N91)']"" D  QUIT  ;->
+ .  W "  no debug data found..."
+ ;
+ S MSH=$G(^HLMA(+I773,"MSH",1,0)) QUIT:MSH']""  ;->
+ S DIV=$E(MSH,4)
+ ;
+ W !!,$$CJ^XLFSTR(" 773 # "_I773_" ",IOM,"=")
+ ;
+ D HDR(90,N90)
+ ;
+ W !
+ D HDR(91,N91)
+ ;
+ W !!,$E(MSH,1,IOM)
+ ;
+ S C1=10,C2=30,C3=50
+ W !!,?C1,"Original (91)",?2,"Array (90)",?3,"MSH-Segment"
+ W !,$$REPEAT^XLFSTR("-",IOM)
+ D LINE("snd app",1,2,3)
+ D LINE("snd fac",3,3,4)
+ D LINE("rec app",5,4,5)
+ D LINE("rec fac",7,5,6)
+ ;
+ QUIT
+ ;
+LINE(HDR,PCE1,PCE2,PCE3) ; Print one comparison line...
+ N P1,P2,P3,P4
+ S P1=$P(N91,U,PCE1),P2=$P(N90,U,PCE2),P3=$P(MSH,DIV,PCE3),P4=$P(N91,U,PCE1+1)
+ W !,HDR,":",?C1,P1,?2,P2,?3,P3,$S(P4]"":" ["_P4_"]",1:"")
+ QUIT
+ ;
+HDR(NUM,DATA) N TXT
+ S TXT=$S(NUM=90:"Array (90)",NUM=91:"Original (91)",1:"")
+ W !,$$CJ^XLFSTR("---------- "_TXT_" ----------",IOM)
+ W $$CJ^XLFSTR(DATA,IOM)
+ QUIT
+ ;
+SET(NEW,VAR,PCE) ; This subroutine performs these actions:
+ ; (1) Resets variables used in MSH segment
+ ; (2) Resets SERAPP and CLNTAPP in ^HLMA(#,0)
+ ; (3) Sets HLMSH91 nodes if overwrite occurs by ARRAY value.
+ ;     If overwrite occurs by M code, the overwrite has already
+ ;     been recorded in HLMSH91.  (An overwrite produced by M code
+ ;     is never overwritten by ARRAY data.)
+ ;
+ N IEN771N,IEN771O,HLTCP
+ ;
+ ; VAR is the name of the variable, and not it's value...
+ S PRE=@VAR ; PRE is now the value of the VAR (pre-overwrite) variable...
+ ;
+ ; Tests whether anything was changed...
+ QUIT:NEW']""  ;-> No new value exists to change to...
+ QUIT:NEW=PRE  ;-> New value = Original value.  Nothing changed...
+ ;
+ ; THIS IS THE EPICENTER!!  This is where the variables used in
+ ; the MSH segment is overwritten.
+ S @VAR=NEW
+ ;
+ ; If PRE exists at this point, it was done by M code...
+ QUIT:$P(HLMSH91,U,PCE)]""  ;->
+ ;
+ ; Change was made, but not by M code.  Must be by array...
+ S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A"
+ ;
+ ; Upgrade ^HLMA(#,0)...
+ QUIT:PCE'=1&(PCE'=5)  ;->
+ ;
+ ; patch HL*1.6*108 start
+ ;S IEN771O=$O(^HL(771,"B",PRE,0)) QUIT:IEN771O'>0  ;-> Orig IEN
+ ;S IEN771N=$O(^HL(771,"B",NEW,0)) QUIT:IEN771N'>0  ;-> New IEN
+ S IEN771O=$O(^HL(771,"B",$E(PRE,1,30),0)) QUIT:IEN771O'>0  ;-> Orig IEN
+ S IEN771N=$O(^HL(771,"B",$E(NEW,1,30),0)) QUIT:IEN771N'>0  ;-> New IEN
+ ; patch HL*1.6*108 end
+ ;
+ QUIT:'IEN771O!('IEN771N)!(IEN771O=IEN771N)  ;->
+ S HLTCP=1 ; So 773 is updated...
+ I PCE=1 D UPDATE^HLTF0(MTIENS,"","O","","",IEN771N)
+ I PCE=5 D UPDATE^HLTF0(MTIENS,"","O","",IEN771N)
+ ;
+ QUIT
+ ;
+FIELDS ; Display the Protocol file fields used by the VistA HL7 package,
+ ; when messages are received, to find the event and subscriber
+ ; protocols.
+ N BY,DIC,DIOEND,L
+ ;
+ D HD
+ ;
+ W !
+ ;
+ S L="",DIC="^ORD(101,",BY="[HL PROTOCOL MESSAGING FIELDS]"
+ S DIOEND="D EXPL^HLCSHDR4"
+ D EN1^DIP
+ ;
+ Q
+ ;
+HD W @IOF,$$CJ^XLFSTR("HL7 Protocol Messaging Fields",IOM)
+ W !,$$REPEAT^XLFSTR("=",IOM)
+ W !,"This 'HL7 Protocol Messaging Fields' report holds information that will help"
+ W !,"you determine the effects from changes to routing-related fields in the MSH"
+ W !,"segment when messages are sent between or within VistA HL7 systems."
+ W !,"Additional explanation is included at the bottom of the report."
+ Q
+ ;
+EXPL N I,T QUIT:'$$EXPL1("Press RETURN for 'printout help', or '^' to exit... ")  X "F I=1:1 S T=$T(EXPL+I) QUIT:T'["";;""  W !,$P(T,"";;"",2,99)" S I=$$EXPL1("Press RETURN to exit... ",1)
+ ;;
+ ;;When messages are received, their SENDING APPLICATION (MSH-3), MESSAGE
+ ;;TYPE (MSH-9), EVENT TYPE (MSH-9), and HL7 VERSION (MSH-12) fields are used to
+ ;;find the event driver protocol to be used in processing the just-received
+ ;;message. After the event protocol is found, that protocol's subscriber
+ ;;protocols are evaluated.  The subscriber protocol with a RECEIVING
+ ;;APPLICATION value that matches the RECEIVING APPLICATION field in the MSH
+ ;;segment (MSH-5) is used.
+ ;;
+ ;;The first line for every "section" in the printout is the event driver
+ ;;protocol. Lines preceded by dashes, are related subscriber protocols.  An
+ ;;example is shown below.
+ ;;
+ ;;Snd/Rec App's    mTYP   eTYP   Ver        Protocol                     Link
+ ;;------------------------------------------------------------------------------
+ ;;AC-VOICERAD      ORU    R01    2.3    |   AC ORU SERVER
+ ;;-AC-RADIOLOGY    ORU    R01    2.3    |   AC ORU CLIENT                NC  TCP
+ ;;
+ ;;In this example, the 'AC-VOICERAD' line holds information for the 'AC ORU
+ ;;SERVER' event protocol.  And, the '-AC-RADIOLOGY' line holds information for
+ ;;the 'AC ORU CLIENT' subscriber protocol.
+ Q
+ ;
+EXPL1(PMT,FF) ;
+ N DIR,DIRUT,DTOUT,DUOUT,X,Y
+ QUIT:$E($G(IOST),1,2)'="C-" 1 ;->
+ F X=1:1:$G(FF) W !
+ S DIR(0)="EA",DIR("A")=PMT
+ D ^DIR
+ QUIT $S(Y=1:1,1:"")
+ ;
+M ; Covered by Integration Agreement #3988
+ ; Application developers may call here when creating new messages,
+ ; when experimenting with M code to evaluate and conditionally change
+ ; routing-related fields.
+ ;
+ ; This API is called immediately before the MSH segment is created.
+ N IOINHI,IOINORM,MSHOLD,MSHNEW,MSHPRE,X
+ ;
+ S X="IOINHI;IOINORM" D ENDR^%ZISS
+ ;
+ S MSHOLD=$$MSHBUILD(0),MSHPRE=$$MSHBUILD(1)
+ W !!,"The original MSH segment is...",!!,IOINHI,MSHOLD,IOINORM
+ I MSHPRE'=MSHOLD D
+ .  W !!,"The MSH segment, after modification by passed-in data, is..."
+ .  W !!,IOINHI,MSHPRE,IOINORM
+ ;
+ D MVAR("SENDING APPLICATION","HLMSHSAN","SERAPP")
+ D MVAR("SENDING FACILITY","HLMSHSFN","SERFAC")
+ D MVAR("RECEIVING APPLICATION","HLMSHRAN","CLNTAPP")
+ D MVAR("RECEIVING FACILITY","HLMSHRFN","CLNTFAC")
+ ;
+ S MSHNEW=$$MSHBUILD
+ I MSHNEW'=MSHPRE D
+ .  W !!,"Before your changes above, the modified MSH segment was..."
+ .  W !!,IOINHI,MSHPRE,IOINORM
+ .  W !!,"After your changes, the MSH segment is..."
+ .  W !!,IOINHI,MSHNEW,IOINORM
+ W !!,$$REPEAT^XLFSTR("-",IOM)
+ W !!,"Message being sent..."
+ W !
+ ;
+ Q
+ ;
+MVAR(FLD,VAR,VARO) ; Generic resetting of variable...
+ ;IOINHI,IOINORM -- req
+ N ANS
+ W !!,?4,"Protocol-derived value of ",FLD,": "
+ W IOINHI,@VARO,IOINORM
+ W !,"Passed-in value of ",FLD," (",VAR,"): "
+ W IOINHI,@VAR,IOINORM
+ W !,?10,"Enter new value for ",FLD,": "
+ R ANS:60 Q:'$T  ;->
+ I ANS[U!(ANS']"") D
+ .  W !!,?10,"No changes will be made..."
+ I ANS'[U&(ANS]"") D
+ .  S @VAR=ANS
+ .  W !!,?10,"The variable ",IOINHI,VAR,IOINORM
+ .  W " will be changed to '",IOINHI,ANS,IOINORM,"'."
+ .  W !,?10,"This value will be stored in the ",FLD
+ .  W !,?10,"field in the MSH segment..."
+ .  W !!,$$REPEAT^XLFSTR("-",IOM)
+ Q
+ ;
+MSHBUILD(TYPE) ; Build MSH using current variables...
+ N MSH,PCE,RAN,RFN,SAN,SFN
+ S MSH="MSH"_FS_EC
+ I $G(TYPE)=0 F PCE=SERAPP,SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
+ .  S MSH=MSH_FS_PCE
+ I $G(TYPE)'=0 D
+ .  S SAN=HLMSHSAN,SAN=$S(SAN]"":SAN,1:SERAPP)
+ .  S SFN=HLMSHSFN,SFN=$S(SFN]"":SFN,1:SERFAC)
+ .  S RAN=HLMSHRAN,RAN=$S(RAN]"":RAN,1:CLNTAPP)
+ .  S RFN=HLMSHRFN,RFN=$S(RFN]"":RFN,1:CLNTFAC)
+ .  F PCE=SAN,SFN,RAN,RFN,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D
+ .  .  S MSH=MSH_FS_PCE
+ QUIT MSH
+ ;
+EOR ;HLCSHDR4 - Reset MSH Segment Fields ;9/12/02 11:50

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m

-              r613
+              r623
+HLCSIN  ;ALB/JRP - INCOMING FILER;01-MAY-95 ;03/17/2008  17:15
+        ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115,122,140**;Oct 13, 1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+STARTIN ;Main entry point for incoming background filer
+        ;Create/find entry denoting this filer in the INCOMING FILER TASK
+        ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER
+        ; file (#869.3)
+        N HLFLG,HLEXIT,HLPTRFLR
+        ;
+        ; patch HL*1.6*122
+        ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
+        N HLDUZ
+        S HLDUZ=+$G(DUZ)
+        ;
+        S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN")
+        ;Loop through Logical Links and check for incoming messages
+        S HLEXIT=0
+        ; patch HL*1.6*122 TEST v2: DUZ code removed
+        ; patch HL*1.6*122, set DUZ for application proxy user
+        ;; D PROXY^HLCSTCP4
+        S HLPTRFLR("$J")=$J
+        F  D  Q:HLEXIT
+        . S HLFLG=0
+        . D DEFACK(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT
+        . D ACKNOW(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT
+        . Q:HLFLG
+        . I $$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTDEL")),2)>3600 D  Q
+        . . S HLPTRFLR("LASTDEL")=$H    ; maintain queue sizes
+        . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour.
+        . ; patch HL*1.6*122
+        . ; H 5
+        . H 1
+        . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+        S ZTSTOP=1 ;Asked to stop
+        D DELFLR^HLCSUTL1(HLPTRFLR,"IN") ;Delete entry denoting this filer
+        S ZTREQ="@"
+        Q
+DEFACK(HLPTRFLR,HLFLG,HLEXIT)   ; Process TCP links with a deferred response
+        N HLXX,HLD0,HLPCT
+        S HLXX=0
+        F  S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX  D  Q:HLEXIT
+        . ; HL*1.6*122, check the in-queue stop flag
+        . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
+        . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+        . ; patch HL*1.6*109: Does another filer have this?
+        . ; L +^HLMA("AC","I",HLXX):0 Q:'$T
+        . ; patch HL*1.6*140 - change the lock node, it conflicts with
+        . ; lock defined in routine, HLCSREP.
+        . ; L +^HLMA("AC","I",HLXX):2 Q:'$T  ; patch HL*1.6*122
+        . L +^HLMA("IN-FILER","AC","I",HLXX):2 Q:'$T  ; patch HL*1.6*122
+        . S HLD0=0,HLFLG=1
+        . ; HL*1.6*109 changes in for loop below, and post-quit code placed
+        . ; on following lines.
+        . S HLPCT=0 ; Counter whether filer should stop every 100th entry.
+        .;**109 - insure queue last processed at least 2 seconds ago
+        . ; patch HL*1.6*140
+        . ; I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q
+        . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("IN-FILER","AC","I",HLXX) Q
+        . F  S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT)  D
+        .. ; patch HL*1.6*122 start
+        .. ; patch HL*1.6*122 TEST v2: DUZ code removed
+        .. ; DUZ comparison/reset for application proxy user
+        .. ;; D HLDUZ^HLCSTCP4
+        .. D HLDUZ2^HLCSTCP4
+        .. ; protect HLDUZ
+        .. N HLDUZ
+        .. S HLPCT=HLPCT+1
+        .. I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+        .. ; L +^HLMA(HLD0):0 Q:'$T
+        .. F  L +^HLMA(HLD0):30 Q:$T  H 1
+        .. I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
+        .. D DEFACK^HLTP3(HLXX,HLD0)
+        .. D DEQUE^HLCSREP(HLXX,"I",HLD0)
+        .. L -^HLMA(HLD0)
+        . ; patch HL*1.6*122 end
+        . ;**109 -add dt/tm stamp to time queue last processed
+        . S ^XTMP("HL7-AC","I",HLXX)=$H
+        . ;**109 -unlock the queue
+        . ; patch HL*1.6*140
+        . ; L -^HLMA("AC","I",HLXX)
+        . L -^HLMA("IN-FILER","AC","I",HLXX)
+        Q
+        ;
+CHECKAC(WAY,IEN870,IEN773)      ; If AC xref shouldn't exist, kill it...
+        ;
+        ; Check status and if 3 (processed) kill XREF...
+        I $P($G(^HLMA(+IEN773,"P")),U)=3 D  QUIT "" ;->
+        .  D DEQUE^HLCSREP(IEN870,WAY,IEN773)
+        ;
+        ; Add other checks here in the future...
+        ;
+        Q 1
+        ;
+ACKNOW(HLPTRFLR,HLFLG,HLEXIT)   ; Process Logical Link's IN-queue for received message
+        N HLXX,HLD0,HLD1
+        S HLXX=0
+        F  S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX  D  Q:HLEXIT
+        . ; HL*1.6*122, check the in-queue stop flag
+        . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
+        . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+        . ; HL*1.6*109: Does another filer have this?
+        . ; L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T
+        . L +^HLCS(870,HLXX,"INFILER"):2 Q:'$T  ; patch HL*1.6*122
+        . F  D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT  S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0  D
+        .. ;
+        .. ; patch HL*1.6*122 start
+        .. ; clean variables except Kernel related variables
+        .. D
+        ... ; protect variables defined in STARTIN^HLCSIN
+        ... N HLFLG,HLEXIT,HLPTRFLR
+        ... N HLDUZ
+        ... ; protect variables defined in ACKNOW^HLCSIN
+        ... N HLXX,HLD0,HLD1
+        ... D KILL^XUSCLEAN
+        .. ;
+        .. ; patch HL*1.6*122 TEST v2: DUZ code removed
+        .. ; DUZ comparison/reset for application proxy user
+        .. ;; D HLDUZ^HLCSTCP4
+        .. D HLDUZ2^HLCSTCP4
+        .. ; protect HLDUZ
+        .. N HLDUZ
+        .. ;Make sure message is ready to be received
+        .. S HLFLG=1
+        .. S HLD1=$P(HLD0,"^",2)
+        .. S HLD0=+HLD0 ; At this point, HLD0=HLXX
+        .. I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
+        ... D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+        .. D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
+        .. D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+        . ; patch HL*1.6*122 end
+        . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D
+        . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around.
+        . . F  S HLD1=$O(^HLCS(870,"AISTAT","P",HLXX,HLD1)) Q:'HLD1  D
+        . . . ;I '$D(^HLCS(870,HLXX,1,HLD1,0)) K ^HLCS(870,"AISTAT","P",HLXX,HLD1)
+        . . . I $P($G(^HLCS(870,HLXX,1,HLD1,0)),U,2)'="P" K ^HLCS(870,"AISTAT","P",HLXX,HLD1)
+        . L -^HLCS(870,HLXX,"INFILER")
+        Q
+DELQUE(HLPTRFLR,HLEXIT) ; Delete messages outside the 'queue size' window.
+        N HLDIR,HLXX,HLFRONT
+        S HLDIR=1,HLXX=0
+        F  S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX  D  Q:HLEXIT
+        . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+        . ; patch HL*1.6*122, comment out, no need to lock
+        . ; L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
+        . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
+        . ; patch HL*1.6*122, comment out
+        . ; L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+        . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT)
+        Q
+CHKUPD(HLPTRFLR,HLEXIT) ;
+        Q:$$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTUP")),2)<15
+        D SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") ; Update LAST KNOWN $H (field #.03) for filer
+        S HLPTRFLR("LASTUP")=$H
+        D CHK4STOP^HLCSUTL2(HLPTRFLR,"IN",.HLEXIT) Q:HLEXIT
+        Q
+HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;11/15/2000  09:37
+ ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oct 13, 1995
+STARTIN ;Main entry point for incoming background filer
+ ;Create/find entry denoting this filer in the INCOMING FILER TASK
+ ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER
+ ; file (#869.3)
+ ;N HLOGLINK,HLNODE,HLPARENT,HLST1,TMP ; These vbls aren't used!
+ N HLFLG,HLEXIT,HLPTRFLR
+ S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN")
+ ;Loop through Logical Links and check for incoming messages
+ S HLEXIT=0
+ F  D  Q:HLEXIT
+ . S HLFLG=0
+ . D DEFACK(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT
+ . D ACKNOW(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT
+ . Q:HLFLG
+ . I $$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTDEL")),2)>3600 D  Q
+ . . S HLPTRFLR("LASTDEL")=$H    ; maintain queue sizes
+ . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour.
+ . H 5
+ . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ S ZTSTOP=1 ;Asked to stop
+ D DELFLR^HLCSUTL1(HLPTRFLR,"IN") ;Delete entry denoting this filer
+ S ZTREQ="@"
+ Q
+DEFACK(HLPTRFLR,HLFLG,HLEXIT) ; Process TCP links with a deferred response
+ N HLXX,HLD0,HLPCT
+ S HLXX=0
+ F  S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX  D  Q:HLEXIT
+ . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ . ; HL*1.6*109
+ . L +^HLMA("AC","I",HLXX):0 Q:'$T  ;*109*Does another filer have this?
+ . S HLD0=0,HLFLG=1
+ . ; HL*1.6*109 changes in for loop below, and post-quit code placed
+ . ; on following lines.
+ . S HLPCT=0 ; Counter whether filer should stop every 100th entry.
+ .;**109 - insure queue last processed at least 2 seconds ago
+ . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q
+ . F  S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT)  D
+ . . S HLPCT=HLPCT+1
+ . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ . . L +^HLMA(HLD0):0 Q:'$T
+ . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
+ . . D DEFACK^HLTP3(HLXX,HLD0)
+ . . D DEQUE^HLCSREP(HLXX,"I",HLD0)
+ . . L -^HLMA(HLD0)
+ . ;**109 -add dt/tm stamp to time queue last processed
+ . S ^XTMP("HL7-AC","I",HLXX)=$H
+ . ;**109 -unlock the queue
+ . L -^HLMA("AC","I",HLXX)
+ Q
+ ;
+CHECKAC(WAY,IEN870,IEN773) ; If AC xref shouldn't exist, kill it...
+ ;
+ ; Check status and if 3 (processed) kill XREF...
+ I $P($G(^HLMA(+IEN773,"P")),U)=3 D  QUIT "" ;->
+ .  D DEQUE^HLCSREP(IEN870,WAY,IEN773)
+ ;
+ ; Add other checks here in the future...
+ ;
+ Q 1
+ ;
+ACKNOW(HLPTRFLR,HLFLG,HLEXIT) ; Process Logical Link's IN-queue for received message
+ N HLXX,HLD0,HLD1
+ S HLXX=0
+ F  S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX  D  Q:HLEXIT
+ . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ .; HL*1.6*109
+ . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T  ;Does another filer have this?
+ . F  D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT  S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0  D
+ . . ;Make sure message is ready to be received
+ . . S HLFLG=1
+ . . S HLD1=$P(HLD0,"^",2)
+ . . S HLD0=+HLD0 ; At this point, HLD0=HLXX
+ . . I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
+ . . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+ . . D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
+ . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+ . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D
+ . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around.
+ . . F  S HLD1=$O(^HLCS(870,"AISTAT","P",HLXX,HLD1)) Q:'HLD1  D
+ . . . ;I '$D(^HLCS(870,HLXX,1,HLD1,0)) K ^HLCS(870,"AISTAT","P",HLXX,HLD1)
+ . . . I $P($G(^HLCS(870,HLXX,1,HLD1,0)),U,2)'="P" K ^HLCS(870,"AISTAT","P",HLXX,HLD1)
+ . L -^HLCS(870,HLXX,"INFILER")
+ Q
+DELQUE(HLPTRFLR,HLEXIT) ; Delete messages outside the 'queue size' window.
+ N HLDIR,HLXX,HLFRONT
+ S HLDIR=1,HLXX=0
+ F  S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX  D  Q:HLEXIT
+ . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
+ . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
+ . L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+ . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT)
+ Q
+CHKUPD(HLPTRFLR,HLEXIT) ;
+ Q:$$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTUP")),2)<15
+ D SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") ; Update LAST KNOWN $H (field #.03) for filer
+ S HLPTRFLR("LASTUP")=$H
+ D CHK4STOP^HLCSUTL2(HLPTRFLR,"IN",.HLEXIT) Q:HLEXIT
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m

-              r613
+              r623
+HLCSLM  ;SFCIOFO/AC - HL7 LINK MANAGER ;03/19/2008  10:01
+        ;;1.6;HEALTH LEVEL SEVEN;**49,57,109,123,140**;Oct 13, 1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+EN      ;Entry point for start up task
+        N %,HLEVLCHK,HLTSKCNT
+        F %=1:1:10 L +^HLCS("HLCSLM"):2 Q:$T
+        E  Q
+        I $G(ZTQUEUED) S Y=$$PSET^%ZTLOAD(ZTQUEUED)
+        D INIT,SAVDOLRH
+        D SETNM^%ZOSV($E("HLmgr:"_$G(ZTQUEUED),1,15))
+        ;
+LOOP    ;
+        D CHKQUE
+        I $$CKLMSTOP G EXIT
+        D SAVDOLRH
+        D CHECKMST^HLEVMST ;HL*1.6*109 - Make sure event monitor current
+        ; patch HL*1.6*140
+        ; H 10
+        H 5
+        G LOOP
+        ;
+EXIT    N HLJ,X
+        S X=1
+        F  L +^HLCS(869.3,X,5):2 Q:$T
+        ;52=Link Manager task number
+        S HLJ(869.3,X_",",52)="@"
+        D FILE^HLDIE("","HLJ","","EXIT","HLCSLM") ;HL*1.6*109
+        L -^HLCS(869.3,X,5)
+        L -^HLCS("HLCSLM")
+        Q
+        ;
+SAVDOLRH        ;Save Last Known $H
+        N HLJ,X
+        S X=1
+        F  L +^HLCS(869.3,X,5):2 Q:$T
+        ;54=LM LAST KNOWN $H
+        S HLJ(869.3,X_",",54)=$H
+        D FILE^HLDIE("","HLJ","","SAVDOLRH","HLCSLM") ;HL*1.6*109
+        L -^HLCS(869.3,X,5)
+        Q
+        ;
+CHKQUE  ;Check queues for messages to send
+        ;HLTSKCNT(logical link)=task #^$H
+        N HLDA,HLDP,HLMSG,HLTSK,Y
+        S (HLDA,HLMSG)=""
+        F HLDP=0:0 S HLDP=+$O(^HLMA("AC","O",HLDP)) Q:HLDP'>0  S HLMSG=+$O(^(HLDP,0)) I HLMSG D  L -^HLCS("HLCSLSM",HLDP)
+        .;quit if persistent link
+        .Q:$P($G(^HLCS(870,HLDP,400)),U,4)="Y"
+        .L +^HLCS("HLCSLSM",HLDP):0 E  K HLTSKCNT(HLDP) Q
+        .Q:'$$LLOK(+HLDP)
+        .;get tasknumber from file 870 and HLTSKCNT array
+        .S Y=$$TASKNUM(HLDP),HLTSK=$G(HLTSKCNT(HLDP))
+        . ;
+        . ;patch HL*1.6*123 start
+        . S HLDP("TASK-ACTIVE")=0
+        . ;
+        . I Y D
+        .. N ZTSK
+        .. S ZTSK=Y
+        .. ; Check status of task
+        .. D STAT^%ZTLOAD
+        .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1
+        . Q:HLDP("TASK-ACTIVE")
+        . ;
+        . I HLTSK D
+        .. N ZTSK
+        .. S ZTSK=+HLTSK
+        .. ; Check status of task
+        .. D STAT^%ZTLOAD
+        .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1
+        . Q:HLDP("TASK-ACTIVE")
+        . ;
+        . ;no tasknumber, link not running nor queued, task it
+        . I 'HLTSK!'Y D TASKLSUB(HLDP),SAVTSK(HLDP) Q
+        ; comment out the following lines
+        ; .;link was tasked, check time
+        ; .S Y=$P(HLTSK,U,2)
+        ; .;check that time task is less than 30 minutes
+        ; .Q:$$HDIFF^XLFDT($H,Y,2)<1800
+        ; .;shutdown and send alert
+        ; .D SDFLD^HLCSTCP,EXITS^HLCSTCP("Shutdown"),SNDALERT
+        ; loop through links that have been tasked
+        ; F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0  K:'$D(^HLMA("AC","O",HLDP)) HLTSKCNT(HLDP)
+        F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0  D
+        . N ZTSK
+        . S ZTSK=+HLTSKCNT(HLDP)
+        . ; Check status of task
+        . D STAT^%ZTLOAD
+        . ; kill HLTSKCNT(HLDP) if process is not active
+        . I "12"'[ZTSK(1) K HLTSKCNT(HLDP)
+        ; patch HL*1.6*123 end
+        Q
+        ;
+INIT    ;Create Task number and clear Stop flag.
+        N HLJ,X
+        S X=1
+        F  L +^HLCS(869.3,X,5):2 Q:$T
+        ;52=Link Manager task number,53=Stop Link Manager
+        S HLJ(869.3,X_",",52)=$G(ZTQUEUED)
+        S HLJ(869.3,X_",",53)="@"
+        D FILE^HLDIE("","HLJ","","INIT","HLCSLM") ;HL*1.6*109
+        L -^HLCS(869.3,X,5)
+        Q
+TASKNUM(X)      ;Look-up task number
+        N %,DA,Y
+        S DA=X
+        ;
+        ;**109**
+        ;F  L +^HLCS(870,+DA,0):2 Q:$T
+        ;
+        S Y=$$GET1^DIQ(870,DA_",",11)
+        ;
+        ;**109
+        ;L -^HLCS(870,+DA,0)
+        ;
+        Q Y
+STATUS(X)       ;Status of task
+        N Y,ZTSK
+        S ZTSK=X
+        D STAT^%ZTLOAD
+        S Y=ZTSK(1)
+        Q Y
+        ;
+LLOK(X) ;Function to check whether LL ok.
+        ;return value 1 = ok, 0 = not ok.
+        Q:'$G(X)
+        N HLDP,HLDP0,HLPARM4,HLTYPTR
+        S HLDP=+X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) Q:HLDP0="" 0
+        ;must be a client
+        Q:$P(HLPARM4,U,3)'="C" 0
+        ;
+        ; patch HL*1.6*123
+        ;shutdown LLP must be 0
+        ; Q:$P(HLDP0,U,15)'=0 0
+        ; change to 1, in case the data is empty
+        Q:$P(HLDP0,U,15)=1 0
+        ;
+        ;must have LLP Type of TCP
+        S HLTYPTR=+$P(HLDP0,U,3) Q:$P($G(^HLCS(869.1,HLTYPTR,0)),U)'="TCP" 0
+        Q 1
+        ;
+SAVTSK(X)       ;
+        N HLDP,HLJ
+        S HLDP=X
+        ;
+        ;**109**
+        F  L +^HLCS(870,HLDP,0):2 Q:$T
+        ;
+        ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Online ?
+        S X=$NA(HLJ(870,HLDP_",")),@X@(11)=$G(ZTSK)
+        ;S HLJ(870,HLDP_",",11)=$G(ZTSK)
+        D FILE^HLDIE("","HLJ","","SAVTSK","HLCSLM") ; HL*1.6*109
+        S HLTSKCNT(HLDP)=$G(ZTSK)_"^"_$H
+        ;
+        ;**109**
+        L -^HLCS(870,HLDP,0)
+        ;
+        Q
+        ;
+STRTSTOP        ;ENTRY POINT TO START/STOP TCP LINK MANAGER
+        N DIR,DIRUT,Y
+        L +^HLCS("HLCSLM"):3 E  D  Q
+        .W !,*7,"Link Manager already running!"
+        .W ! S DIR(0)="YO",DIR("A")="Would you like to stop the Link Manager now",DIR("B")="NO" D ^DIR K DIR
+        .I $D(DIRUT)!'Y Q
+        .D STOPLM
+        W !,*7,"Link Manager is NOT currently running!"
+        W ! S DIR(0)="YO",DIR("A")="Would you like to start the Link Manager now",DIR("B")="YES" D ^DIR K DIR
+        I '$D(DIRUT)&Y D TASKLM
+        L -^HLCS("HLCSLM")
+        Q
+        ;
+STOPLM  ;ENTRY POINT TO STOP LINK MANAGER
+        N DIC,X,Y,DTOUT,DUOUT,DLAYGO,DIE,DA,DR
+        S DIC="^HLCS(869.3,"
+        S X=1
+        D ^DIC
+        S DA=+Y,DIE=DIC
+        S DR="53////1"
+        D ^DIE
+        W !,"Link Manager has been asked to stop"
+        Q
+STAT()  ;Status of LINK MANAGER--up, down or unable to determine.
+        N %,DA,X,Y
+        S DA=1
+        S X=$$GET1^DIQ(869.3,DA_",",52)
+        Q:X']"" 0
+        S X=$$GET1^DIQ(869.3,DA_",",54)
+        Q:X']"" 0
+        I $$HDIFF^XLFDT($H,X,2)>500 Q 0
+        Q 1
+        ;
+TASKLSUB(X)     ;Task LINK SUB-MANAGER.
+        ;This may be a place to log the time which the LINK SUBMANAGER is tasked.
+        N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARM,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTCPU,ZTSAVE
+        ;ZTSK is not Newed here because it will be needed by SAVTSK.
+        S HLDP=X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400))
+        ; Q:"N"'[$P(HLPARM4,U,4)  ; patch HL*1.6*123: comment out
+        ;quit if no LLP TYPE
+        S HLDAPP=$P(HLDP0,U),HLTYPTR=$P(HLDP0,U,3) Q:'HLTYPTR
+        S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200))
+        I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
+        S ZTRTN="^HLCSLSM",HLBGR=$P(HLBGR," ",2)
+        S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="",ZTSAVE("HLBGR")=""
+        S ZTIO="",ZTDTH=$H
+        ;get startup node
+        I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U)
+        D ^%ZTLOAD
+        D MON^HLCSTCP("Tasked") ;HL*1.6*123
+        Q
+        ;
+TASKLM  ;Task Link Manager
+        ;Declare variables
+        N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,TMP
+        S ZTIO=""
+        S ZTDTH=$H
+        ;Task Link Manager
+        S ZTRTN="EN^HLCSLM"
+        S ZTDESC="HL7 Link Manager"
+        ;Call TaskMan
+        D ^%ZTLOAD
+        I $G(ZTSK) W !,"Link Manager queued as task number ",ZTSK
+        E  W $C(7),!!,"Unable to start/restart Link Manager"
+        Q
+        ;
+CKLMSTOP()      ;Check whether Link Manager should stop
+        N PTRMAIN,NODE5,STOP
+        S PTRMAIN=+$O(^HLCS(869.3,0))
+        L +^HLCS(869.3,PTRMAIN,5):1
+        I $T L -^HLCS(869.3,PTRMAIN,5)
+        S NODE5=$G(^HLCS(869.3,PTRMAIN,5))
+        S STOP=+$P(NODE5,"^",3)
+        Q:STOP STOP
+        S STOP=$$S^%ZTLOAD
+        Q STOP
+        ;
+SNDALERT        ;Send Alert
+        N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+        S Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
+        S XQA("G."_Z)="",XQAMSG="HL7 Logical Link "_$P(^HLCS(870,HLDP,0),U)_" shutdown due to TaskMan unable to process task request"
+        D SETUP^XQALERT
+        Q
+HLCSLM ;SFCIOFO/AC - HL7 LINK MANAGER ;06/14/2005  10:29
+ ;;1.6;HEALTH LEVEL SEVEN;**49,57,109,123**;Oct 13, 1995
+ ;
+EN ;Entry point for start up task
+ N %,HLEVLCHK,HLTSKCNT
+ F %=1:1:10 L +^HLCS("HLCSLM"):2 Q:$T
+ E  Q
+ I $G(ZTQUEUED) S Y=$$PSET^%ZTLOAD(ZTQUEUED)
+ D INIT,SAVDOLRH
+ D SETNM^%ZOSV($E("HLmgr:"_$G(ZTQUEUED),1,15))
+ ;
+LOOP ;
+ D CHKQUE
+ I $$CKLMSTOP G EXIT
+ D SAVDOLRH
+ D CHECKMST^HLEVMST ;HL*1.6*109 - Make sure event monitor current
+ H 10
+ G LOOP
+ ;
+EXIT N HLJ,X
+ S X=1
+ F  L +^HLCS(869.3,X,5):2 Q:$T
+ ;52=Link Manager task number
+ S HLJ(869.3,X_",",52)="@"
+ D FILE^HLDIE("","HLJ","","EXIT","HLCSLM") ;HL*1.6*109
+ L -^HLCS(869.3,X,5)
+ L -^HLCS("HLCSLM")
+ Q
+ ;
+SAVDOLRH ;Save Last Known $H
+ N HLJ,X
+ S X=1
+ F  L +^HLCS(869.3,X,5):2 Q:$T
+ ;54=LM LAST KNOWN $H
+ S HLJ(869.3,X_",",54)=$H
+ D FILE^HLDIE("","HLJ","","SAVDOLRH","HLCSLM") ;HL*1.6*109
+ L -^HLCS(869.3,X,5)
+ Q
+ ;
+CHKQUE ;Check queues for messages to send
+ ;HLTSKCNT(logical link)=task #^$H
+ N HLDA,HLDP,HLMSG,HLTSK,Y
+ S (HLDA,HLMSG)=""
+ F HLDP=0:0 S HLDP=+$O(^HLMA("AC","O",HLDP)) Q:HLDP'>0  S HLMSG=+$O(^(HLDP,0)) I HLMSG D  L -^HLCS("HLCSLSM",HLDP)
+ .;quit if persistent link
+ .Q:$P($G(^HLCS(870,HLDP,400)),U,4)="Y"
+ .L +^HLCS("HLCSLSM",HLDP):0 E  K HLTSKCNT(HLDP) Q
+ .Q:'$$LLOK(+HLDP)
+ .;get tasknumber from file 870 and HLTSKCNT array
+ .S Y=$$TASKNUM(HLDP),HLTSK=$G(HLTSKCNT(HLDP))
+ . ;
+ . ;patch HL*1.6*123 start
+ . S HLDP("TASK-ACTIVE")=0
+ . ;
+ . I Y D
+ .. N ZTSK
+ .. S ZTSK=Y
+ .. ; Check status of task
+ .. D STAT^%ZTLOAD
+ .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1
+ . Q:HLDP("TASK-ACTIVE")
+ . ;
+ . I HLTSK D
+ .. N ZTSK
+ .. S ZTSK=+HLTSK
+ .. ; Check status of task
+ .. D STAT^%ZTLOAD
+ .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1
+ . Q:HLDP("TASK-ACTIVE")
+ . ;
+ . ;no tasknumber, link not running nor queued, task it
+ . I 'HLTSK!'Y D TASKLSUB(HLDP),SAVTSK(HLDP) Q
+ ; comment out the following lines
+ ; .;link was tasked, check time
+ ; .S Y=$P(HLTSK,U,2)
+ ; .;check that time task is less than 30 minutes
+ ; .Q:$$HDIFF^XLFDT($H,Y,2)<1800
+ ; .;shutdown and send alert
+ ; .D SDFLD^HLCSTCP,EXITS^HLCSTCP("Shutdown"),SNDALERT
+ ; loop through links that have been tasked
+ ; F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0  K:'$D(^HLMA("AC","O",HLDP)) HLTSKCNT(HLDP)
+ F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0  D
+ . N ZTSK
+ . S ZTSK=+HLTSKCNT(HLDP)
+ . ; Check status of task
+ . D STAT^%ZTLOAD
+ . ; kill HLTSKCNT(HLDP) if process is not active
+ . I "12"'[ZTSK(1) K HLTSKCNT(HLDP)
+ ; patch HL*1.6*123 end
+ Q
+ ;
+INIT ;Create Task number and clear Stop flag.
+ N HLJ,X
+ S X=1
+ F  L +^HLCS(869.3,X,5):2 Q:$T
+ ;52=Link Manager task number,53=Stop Link Manager
+ S HLJ(869.3,X_",",52)=$G(ZTQUEUED)
+ S HLJ(869.3,X_",",53)="@"
+ D FILE^HLDIE("","HLJ","","INIT","HLCSLM") ;HL*1.6*109
+ L -^HLCS(869.3,X,5)
+ Q
+TASKNUM(X) ;Look-up task number
+ N %,DA,Y
+ S DA=X
+ ;
+ ;**109**
+ ;F  L +^HLCS(870,+DA,0):2 Q:$T
+ ;
+ S Y=$$GET1^DIQ(870,DA_",",11)
+ ;
+ ;**109
+ ;L -^HLCS(870,+DA,0)
+ ;
+ Q Y
+STATUS(X) ;Status of task
+ N Y,ZTSK
+ S ZTSK=X
+ D STAT^%ZTLOAD
+ S Y=ZTSK(1)
+ Q Y
+ ;
+LLOK(X) ;Function to check whether LL ok.
+ ;return value 1 = ok, 0 = not ok.
+ Q:'$G(X)
+ N HLDP,HLDP0,HLPARM4,HLTYPTR
+ S HLDP=+X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) Q:HLDP0="" 0
+ ;must be a client
+ Q:$P(HLPARM4,U,3)'="C" 0
+ ;
+ ; patch HL*1.6*123
+ ;shutdown LLP must be 0
+ ; Q:$P(HLDP0,U,15)'=0 0
+ ; change to 1, in case the data is empty
+ Q:$P(HLDP0,U,15)=1 0
+ ;
+ ;must have LLP Type of TCP
+ S HLTYPTR=+$P(HLDP0,U,3) Q:$P($G(^HLCS(869.1,HLTYPTR,0)),U)'="TCP" 0
+ Q 1
+ ;
+SAVTSK(X) ;
+ N HLDP,HLJ
+ S HLDP=X
+ ;
+ ;**109**
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ ;
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Online ?
+ S X=$NA(HLJ(870,HLDP_",")),@X@(11)=$G(ZTSK)
+ ;S HLJ(870,HLDP_",",11)=$G(ZTSK)
+ D FILE^HLDIE("","HLJ","","SAVTSK","HLCSLM") ; HL*1.6*109
+ S HLTSKCNT(HLDP)=$G(ZTSK)_"^"_$H
+ ;
+ ;**109**
+ L -^HLCS(870,HLDP,0)
+ ;
+ Q
+ ;
+STRTSTOP ;ENTRY POINT TO START/STOP TCP LINK MANAGER
+ N DIR,DIRUT,Y
+ L +^HLCS("HLCSLM"):3 E  D  Q
+ .W !,*7,"Link Manager already running!"
+ .W ! S DIR(0)="YO",DIR("A")="Would you like to stop the Link Manager now",DIR("B")="NO" D ^DIR K DIR
+ .I $D(DIRUT)!'Y Q
+ .D STOPLM
+ W !,*7,"Link Manager is NOT currently running!"
+ W ! S DIR(0)="YO",DIR("A")="Would you like to start the Link Manager now",DIR("B")="YES" D ^DIR K DIR
+ I '$D(DIRUT)&Y D TASKLM
+ L -^HLCS("HLCSLM")
+ Q
+ ;
+STOPLM ;ENTRY POINT TO STOP LINK MANAGER
+ N DIC,X,Y,DTOUT,DUOUT,DLAYGO,DIE,DA,DR
+ S DIC="^HLCS(869.3,"
+ S X=1
+ D ^DIC
+ S DA=+Y,DIE=DIC
+ S DR="53////1"
+ D ^DIE
+ W !,"Link Manager has been asked to stop"
+ Q
+STAT() ;Status of LINK MANAGER--up, down or unable to determine.
+ N %,DA,X,Y
+ S DA=1
+ S X=$$GET1^DIQ(869.3,DA_",",52)
+ Q:X']"" 0
+ S X=$$GET1^DIQ(869.3,DA_",",54)
+ Q:X']"" 0
+ I $$HDIFF^XLFDT($H,X,2)>500 Q 0
+ Q 1
+ ;
+TASKLSUB(X) ;Task LINK SUB-MANAGER.
+ ;This may be a place to log the time which the LINK SUBMANAGER is tasked.
+ N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARM,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTCPU,ZTSAVE
+ ;ZTSK is not Newed here because it will be needed by SAVTSK.
+ S HLDP=X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400))
+ ; Q:"N"'[$P(HLPARM4,U,4)  ; patch HL*1.6*123: comment out
+ ;quit if no LLP TYPE
+ S HLDAPP=$P(HLDP0,U),HLTYPTR=$P(HLDP0,U,3) Q:'HLTYPTR
+ S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200))
+ I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
+ S ZTRTN="^HLCSLSM",HLBGR=$P(HLBGR," ",2)
+ S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="",ZTSAVE("HLBGR")=""
+ S ZTIO="",ZTDTH=$H
+ ;get startup node
+ I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U)
+ D ^%ZTLOAD
+ D MON^HLCSTCP("Tasked") ;HL*1.6*123
+ Q
+ ;
+TASKLM ;Task Link Manager
+ ;Declare variables
+ N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,TMP
+ S ZTIO=""
+ S ZTDTH=$H
+ ;Task Link Manager
+ S ZTRTN="EN^HLCSLM"
+ S ZTDESC="HL7 Link Manager"
+ ;Call TaskMan
+ D ^%ZTLOAD
+ I $G(ZTSK) W !,"Link Manager queued as task number ",ZTSK
+ E  W $C(7),!!,"Unable to start/restart Link Manager"
+ Q
+ ;
+CKLMSTOP() ;Check whether Link Manager should stop
+ N PTRMAIN,NODE5,STOP
+ S PTRMAIN=+$O(^HLCS(869.3,0))
+ L +^HLCS(869.3,PTRMAIN,5):1
+ I $T L -^HLCS(869.3,PTRMAIN,5)
+ S NODE5=$G(^HLCS(869.3,PTRMAIN,5))
+ S STOP=+$P(NODE5,"^",3)
+ Q:STOP STOP
+ S STOP=$$S^%ZTLOAD
+ Q STOP
+ ;
+SNDALERT ;Send Alert
+ N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+ S Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
+ S XQA("G."_Z)="",XQAMSG="HL7 Logical Link "_$P(^HLCS(870,HLDP,0),U)_" shutdown due to TaskMan unable to process task request"
+ D SETUP^XQALERT
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m

-              r613
+              r623
+HLCSLNCH        ;ALB/MTC/JC - START AND STOP THE LLP ;07/26/2007  17:10
+        ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;This program is callable from a menu
+        ;It allows the user to Start and Stop the Lower Layer
+        ;Protocol in the Background or in the foreground
+        ;
+        ;Required or Optional INPUT PARAMETERS
+        ;             None
+        ;
+        ;
+        ;Output variables
+        ;             HLDP=IEN of Logical Link in file #870
+        ;(optional)HLTRACE=if SET it launches the LLP in the Foreground
+        ;(optional)   ZTSK=if defined LLP was launched in the
+        ;background
+        ;
+        ;
+START   ; Start up the lower level protocol
+        N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
+        N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
+        W !!,"This option is used to launch the lower level protocol for the"
+        W !,"appropriate device.  Please select the node with which you want"
+        W !,"to communicate",!
+        ; patch HL*1.6*122
+        S POP=0
+        S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
+        S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
+        ;-- check if parameter have been setup
+        ;-- check for LLP type
+        I 'HLTYPTR W !!,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+        ;-- get TCP information
+        S HLPARM4=$G(^HLCS(870,HLDP,400))
+        ;-- get routine (background job for LLP)
+        S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
+        ;-- get environment check routine (HLQUIT should be defined in fails)
+        S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
+        ;
+        I HLBGR="" W !!,$C(7),"No routine has been specified for this LLP." G STARTQ
+        ;
+        ;-- execute environment check routine if HLQUIT is defined then terminate
+        I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
+        ; patch HL*1.6*122 start
+        ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
+        ; by the external service
+        I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  G STARTQ
+        . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
+        . Q
+        ; patch HL*1.6*122 end
+        ;
+        I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
+        I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
+        ; patch HL*1.6*122 start
+        ; comment out-should be taken care of by the code 2 line above
+        ; I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
+        ; I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+        ; . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
+        N HLTEMP
+        S HLTEMP=0
+        I $P(HLPARM0,U,12) D  G:HLTEMP STARTQ
+        . N ZTSK
+        . S ZTSK=$P(HLPARM0,U,12)
+        . D STAT^%ZTLOAD
+        . I "12"[ZTSK(1) D
+        .. W !,$C(7),"NOTE: The lower level protocol for this application is already running."
+        .. I '$P(^HLCS(870,HLDP,0),"^",10) S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
+        .. S HLTEMP=1
+        ; patch HL*1.6*122 end
+        I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
+        .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+        .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+        .N HLJ,X
+        . ; patch HL*1.6*122-comment out
+        . ; I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+        .L +^HLCS(870,HLDP,0):2
+        .E  W !,$C(7),"Unable to enable this LLP !" Q
+        .S X="HLJ(870,"""_HLDP_","")"
+        .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+        .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
+        .L -^HLCS(870,HLDP,0)
+        .W !,"This LLP has been enabled!"
+        .Q
+        I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
+        ;
+        ; patch HL*1.6*122 start, for tcp link
+        I HLTYPTR=4 D  Q
+        . S Y="B"
+        . D STARTJOB
+        ; patch HL*1.6*122 end
+        ;
+        W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
+        S DIR("A")="Method for running the receiver"
+        S DIR("B")="B"
+        S DIR("?",1)="Enter F for Foreground (and trace)"
+        S DIR("?",2)="      B for Background (normal) or"
+        S DIR("?")="      Q to quit without starting the receiver"
+        D ^DIR K DIR
+        Q:(Y=U)!(Y="Q")
+        ;
+STARTJOB        ;
+        S HLX=$G(^HLCS(870,HLDP,0))
+        ;-- foreground
+        I Y="F" S HLTRACE=1 D  G STARTQ
+        . S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
+        . D MON^HLCSTCP("Start")
+        . X HLBGR
+        ;-- background
+        I Y="B" D  G STARTQ
+        . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
+        . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+        . D ^%ZTLOAD
+        . ; patch HL*1.6*122 start
+        . I $D(ZTSK) D
+        .. K HLTRACE
+        .. D MON^HLCSTCP("Tasked")
+        .. S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
+        . ; patch HL*1.6*122 end
+        . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
+        ;
+        Q
+        ;
+STARTQ  ;
+        I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running."
+        Q
+        ;
+STOP    ; Shut down a lower level protocol..
+        N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
+        W !!,"This option is used to shut down the lower level protocol for the"
+        W !,"appropriate device.  Please select the link which you would"
+        W !,"like to shutdown.",!
+        S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
+        S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
+        ; patch HL*1.6*122
+        ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
+        ; by the external service
+        I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  Q
+        . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to disable this LLP."
+        . Q
+        ;
+        I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
+        I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
+STP1    ;
+        W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
+        I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
+S       ;
+        F  L +^HLCS(870,HLDP,0):2 Q:$T
+        ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
+        S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+        I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
+        D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
+        ; patch HL*1.6*122 start
+        ; I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
+        ; I ^%ZOSF("OS")'["DSM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
+        I ($P(HLPARM4,U,3)="S")!(($P(HLPARM4,U,3)="M")&($S(^%ZOSF("OS")'["OpenM":0,1:$$OS^%ZOSV'["VMS"))) D
+        . ;pass task number to stop listener
+        . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
+        . ; D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+        . ; I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+        . ; U IO W "**STOP**"
+        . ; W !
+        . ; D CLOSE^%ZISTCP
+        . ; patch HL*1.6*122 end
+        L -^HLCS(870,HLDP,0)
+        W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
+        Q
+        ;
+STOPQ   Q
+HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2003  17:37
+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**;Oct 13, 1995
+ ;
+ ;This program is callable from a menu
+ ;It allows the user to Start and Stop the Lower Layer
+ ;Protocol in the Background or in the foreground
+ ;
+ ;Required or Optional INPUT PARAMETERS
+ ;             None
+ ;
+ ;
+ ;Output variables
+ ;             HLDP=IEN of Logical Link in file #870
+ ;(optional)HLTRACE=if SET it launches the LLP in the Foreground
+ ;(optional)   ZTSK=if defined LLP was launched in the
+ ;background
+ ;
+ ;
+START ; Start up the lower level protocol
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
+ N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
+ W !!,"This option is used to launch the lower level protocol for the"
+ W !,"appropriate device.  Please select the node with which you want"
+ W !,"to communicate",!
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
+ S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
+ ;-- check if parameter have been setup
+ ;-- check for LLP type
+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+ ;-- get TCP information
+ S HLPARM4=$G(^HLCS(870,HLDP,400))
+ ;-- get routine (background job for LLP)
+ S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
+ ;-- get environment check routine (HLQUIT should be defined in fails)
+ S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
+ ;
+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
+ ;
+ ;-- execute environment check routine if HLQUIT is defined then terminate
+ I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
+ ;Multi-Servers, only enable the link if not OpenM
+ I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  G STARTQ
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
+ . Q
+ ;
+ I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
+ I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
+ I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+ .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+ .N HLJ,X
+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+ .L +^HLCS(870,HLDP,0):2
+ .E  W !,$C(7),"Unable to enable this LLP !" Q
+ .S X="HLJ(870,"""_HLDP_","")"
+ .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+ .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
+ .L -^HLCS(870,HLDP,0)
+ .W !,"This LLP has been enabled!"
+ .Q
+ I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
+ ;
+ W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
+ S DIR("A")="Method for running the receiver"
+ S DIR("B")="B"
+ S DIR("?",1)="Enter F for Foreground (and trace)"
+ S DIR("?",2)="      B for Background (normal) or"
+ S DIR("?")="      Q to quit without starting the receiver"
+ D ^DIR K DIR
+ Q:(Y=U)!(Y="Q")
+ ;
+ S HLX=$G(^HLCS(870,HLDP,0))
+ ;-- foreground
+ I Y="F" S HLTRACE=1 D  G STARTQ
+ . X HLBGR
+ ;-- background
+ I Y="B" D  G STARTQ
+ . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
+ . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+ . D ^%ZTLOAD
+ . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
+ ;
+ Q
+ ;
+ ;
+STARTQ ;
+ I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running."
+ Q
+ ;
+STOP ; Shut down a lower level protocol..
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
+ W !!,"This option is used to shut down the lower level protocol for the"
+ W !,"appropriate device.  Please select the link which you would"
+ W !,"like to shutdown.",!
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
+ S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
+ I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  Q
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
+ . Q
+ ;
+ I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
+ I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
+STP1 ;
+ W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
+ I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
+S ;
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
+ S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
+ D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
+ . ;pass task number to stop listener
+ . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+ . U IO W "**STOP**"
+ . W !
+ . D CLOSE^%ZISTCP
+ L -^HLCS(870,HLDP,0)
+ W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
+ Q
+ ;
+STOPQ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m

-              r613
+              r623
+HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;12/11/2007  17:07
+        ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;This Program drives a real-time display monitor for the HL7
+        ;Package. All the data used by this display is stored in file
+        ;# 870. Several callable entry points were broken
+        ;out of this routine and placed into HLCSMON1
+        ;
+        ;This routine has no required input parameters other than require that
+        ;U be defined, it does not instantiate any parameters either.
+        ;
+        ;
+        ;HLARY=array of all,HLARYD=array of display,HLARYO=array of old values
+        ;HLPTR1=top of display,HLPTR2=bottom of display,HLPTR3=last in HLVARY
+INIT    N HLARY,HLARYD,HLARYO,HLCOFF,HLCON,HLDISP,HLPTR1,HLPTR2,HLPTR3,HLRESP
+        N HLDEV,HLERR,HLEVL,HLHDR,HLNODE,HLOCK
+        N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE
+        N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY
+        ;
+        ; patch HL*1.6*122 start
+        D HOME^%ZIS
+        W @IOF
+        ; patch HL*1.6*122 end
+        ;
+        D ^HLCSTERM ;Sets up variables to control display attributes
+INIT1   ;
+        ; Next 4 lines copied here from top of START by patch 73...
+        ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode
+        S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S"
+        D BUILDARY ;Build an array for display
+        QUIT:$$LOCKED(.HLOCK)  ;-> Anything locked?
+        ;
+        W HLCOFF ;Shut Cursor off
+        D HEADER^HLCSTERM ;Write header
+        D WDATA^HLCSMON1(5,17,"","","Incoming filers running => ")
+        D WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ")
+        D WDATA^HLCSMON1(5,20,"","","Select a Command:")
+        D WDATA^HLCSMON1(1,21,"","","(N)EXT  (B)ACKUP  (A)LL LINKS  (S)CREENED  (V)IEWS  (Q)UIT  (?) HELP: ")
+        ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode
+        S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S"
+START   ;
+        D BUILDARY ;Build an array for display
+        D DISPLAY^HLCSMON1 ;Display the array just built
+        D READ
+        ;HLRESP=user response
+        I '$L(HLRESP) G START
+        G:HLRESP="Q" EXIT
+        ;any of following commands, kill old values
+        K HLARYO,HLTMSTAT,HLLMSTAT
+        I HLRESP="?" D HELP G INIT1
+        I HLRESP="V" D VIEW G INIT1
+        I "AS"[HLRESP K HLARY,HLEVL S HLDISP=HLRESP G INIT1
+        I "NB"[HLRESP D NEXT
+        G START
+        ;
+READ    ;Prompt the user for the next action
+        D WDATA^HLCSMON1(71,21,"","","",1)
+        W HLCON
+        R X#1:3
+        W HLCOFF
+        S HLRESP=$S(X="":X,"Qq^"[X:"Q","Bb"[X:"B","Nn"[X:"N","Aa"[X:"A","Vv"[X:"V",X="?":"?","Ss"[X:"S",1:"")
+        Q
+        ;
+VIEW    ;select new view
+        W HLCON,!!
+        N DIC
+        S DIC="^HLCS(869.3,1,6,",DIC(0)="QEA"
+        D ^DIC Q:Y<0
+        S HLVIEW=+Y,HLDISP="V"
+        W HLCOFF
+        Q
+        ;
+NEXT    ;
+        ;Next page
+        I HLRESP="N" D
+        . ;no more
+        . I HLPTR2=HLPTR3 D EOB Q
+        . S Y=HLPTR2+10,HLEVL(HLPTR1)=""
+        . ;exceed list, get last 10
+        . I Y>HLPTR3 S HLPTR2=HLPTR3,HLPTR1=HLPTR2-9 Q
+        . S HLPTR1=HLPTR2,HLPTR2=Y
+        ;
+        ;Backup a page
+        I HLRESP="B" D
+        . ;top of list
+        . I HLPTR1=1 D EOB Q
+        . I HLDISP="S" S HLPTR1=$O(HLEVL(HLPTR1),-1) Q
+        . S Y=HLPTR1-9
+        . ;can't go back 10, reset to top
+        . I Y'>0 S HLPTR1=1,HLPTR2=10 Q
+        . S HLPTR2=HLPTR1,HLPTR1=Y
+        ;
+        ;Erase what might be displayed on line 22
+        D WDATA^HLCSMON1(1,22,IOELALL,"","")
+        Q
+EOB     D WDATA^HLCSMON1(5,22,IORVON,IORVOFF,"CANNOT "_$S(HLRESP="N":"ADVANCE",1:"BACKUP")_" BEYOND END OF BUFFER")
+        W $C(7) H 2
+        Q
+        ;
+BUILDARY        ;
+        K HLARYD
+        ;
+        ;if view is defined, get links
+        I $G(HLVIEW) D  S HLVIEW=0,HLDISP="V"
+        . N HLTMP
+        . K HLARY,HLEVL S HLI=0
+        . F  S HLI=$O(^HLCS(869.3,1,6,HLVIEW,1,HLI)) Q:'HLI  S HLYY=+$P($G(^(HLI,0)),U,2) D
+        .. S Y=$P($G(^HLCS(870,HLI,0)),U) Q:Y=""
+        .. ;build array by DISPLAY ORDER and then by NAME
+        .. I HLYY S HLTMP(HLYY,HLI)="" Q
+        .. S HLTMP(Y,HLI)=""
+        . S (HLI,HLYY)=0
+        . ;rebuild array to put in proper order
+        . F  S HLI=$O(HLTMP(HLI)),HLXX=0 Q:HLI=""  D
+        .. F  S HLXX=$O(HLTMP(HLI,HLXX)) Q:'HLXX  S HLYY=HLYY+1,HLARY(HLYY,HLXX)=""
+        . S HLPTR3=HLYY
+        ;
+        I '$D(HLARY)  S HLYY=0,HLXX="" D
+        . ;build array in alphabetical order
+        . F  S HLXX=$O(^HLCS(870,"B",HLXX)) Q:HLXX=""  S Y=$O(^(HLXX,0)),HLYY=HLYY+1,HLARY(HLYY,Y)=""
+        . S HLPTR3=HLYY
+        ;
+        S HLI=HLPTR1,HLYY=6 ;HLYY=6TH Line of display
+        ;HLARYD(6) through HLARYD(15) with 6 through 15 also representing line
+        ;numbers on the display
+        F HLI=HLI:1 S HLXX=$O(HLARY(HLI,0)) Q:HLYY=16!'HLXX  D COPY
+        S HLPTR2=HLI-1
+        ;Set all HLARY elements not defined on this pass to null
+        F HLYY=HLYY:1:15 S HLARYD(HLYY)=""
+        Q
+COPY    ;
+        Q:'$D(^HLCS(870,HLXX))
+        ;
+        ;These lock tags lock nodes in the global so that the screen is
+        ;refreshed in real-time. The lock forces the buffer to be refreshed,
+        ;so that the display is up to date.
+        ;
+        ;**109**
+        ;L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOCK
+        ;
+        ; Set, even if not able to lock...
+        S Y=$G(^HLCS(870,HLXX,0))
+        ;
+        ;name^rec^proc^send^sent^device^state^error
+        S HLARYD(HLYY)=$P(Y,U)_"^^^^^"_$P(Y,U,4)_"^"_$P(Y,U,5)_"^"_$P(Y,U,19)
+        ;
+        ;**109**
+        ;L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLOCK
+        ;L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER")
+        ;
+        S $P(HLARYD(HLYY),U,2)=$G(^HLCS(870,HLXX,"IN QUEUE BACK POINTER"))
+        ;
+        ;**109**
+        ;L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKLOCK
+        ;L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+        ;
+        S $P(HLARYD(HLYY),U,3)=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
+        ;
+        ;**109**
+        ;L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKLOCK
+        ;L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER")
+        ;
+        S $P(HLARYD(HLYY),U,4)=$G(^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"))
+        ;
+        ;**109**
+        ;L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHKLOCK
+        ;L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER")
+        ;
+        S $P(HLARYD(HLYY),U,5)=$G(^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"))
+        ;
+        S X=HLARYD(HLYY),Y=$P(X,U,2)+$P(X,U,3)+$P(X,U,4)+$P(X,U,5)
+        ;if Select and the Y=0, nothing to report
+        I 'Y,HLDISP="S" S HLARYD(HLYY)="" Q
+        S HLYY=HLYY+1
+        Q
+        ;
+CHKLOCK ; Call here immediately after trying to lock.  And, BE SURE that
+        ; nothing might occur that would change $T after the lock attempt!!
+        ; $T,HLXX -- req
+        N NM870
+        QUIT:$T  ;-> Lock obtained...
+        S NM870=$P($G(^HLCS(870,+HLXX,0)),U)
+        S NM870=$S(NM870]"":NM870_" (IEN #"_HLXX_")",1:"IEN #"_HLXX)
+        S HLOCK(NM870)=""
+        QUIT
+        ;
+HELP    ;
+        W HLCON,@IOF
+        W !,"You have the following options when monitoring the Messaging System:"
+        W !,"Enter the command letter parentheses: N,B,Q,A,S,V or ?"
+        W !!,"(N) takes you to the next page of the display of Logical Links."
+        W !!,"(B) takes you back one page."
+        W !!,"(Q) terminates the monitor."
+        W !!,"(A) provides a display of all links defined on your system."
+        W !!,"(S) displays only those links that have had message traffic."
+        W !!,"(V) prompts for a view name and displays links defined in view."
+        W !!,"    Note that (S) is the default display at startup."
+        W !!,"**PRESS <RET> TO CONTINUE**"
+        R X:DTIME
+        W @IOF
+        W !,?25,"Device Types and corresponding prefixes:"
+        W !!,?30,"PC -- Persistent TCP/IP Client"
+        W !!,?30,"NC -- Non-Persistent TCP/IP Client"
+        W !!,?30,"SS -- Single-threaded TCP/IP Server"
+        W !!,?30,"MS -- Multi-threaded TCP/IP Server"
+        W !!,?30,"SH -- Serial HLLP"
+        W !!,?30,"SX -- Serial X3.28"
+        W !!,?30,"MM -- MailMan"
+        W !!,"**PRESS <RET> TO CONTINUE**"
+        R X:DTIME
+        W HLCOFF
+        Q
+EXIT    ;
+        ;Turn Cursor back on
+        W HLCON
+        D KVAR^HLCSTERM
+        Q
+        ;
+LOCKED(HLOCK)   ; Anything locked?
+        ;
+        ;
+        ; Nothing locked...
+        I '$D(HLOCK) QUIT "" ;->
+        ;
+        W !!,"Editing of logical link data is occurring right now.  For this reason, some of"
+        W !,"the information on the 'System Link Monitor' report might not be accurate for"
+        W !,"the following node(s)..."
+        W !
+        ;
+        S HLOCK=""
+        F  S HLOCK=$O(HLOCK(HLOCK)) Q:HLOCK']""  D
+        .  W !,?5,HLOCK
+        ;
+        S ACTION=$$BTE("Press RETURN to print report or '^' to exit... ",1)
+        ;
+        QUIT $S(ACTION=1:1,1:"")
+        ;
+BTE(PMT,FF)     ;
+        N DIR,DIRUT,DTOUT,DUOUT,X,Y
+        F X=1:1:$G(FF) W !
+        S DIR(0)="EA",DIR("A")=PMT
+        D ^DIR
+        QUIT $S(Y=1:"",1:1)
+        ;
+HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;07/10/2000  12:18
+ ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109**;Oct 13, 1995
+ ;
+ ;This Program drives a real-time display monitor for the HL7
+ ;Package. All the data used by this display is stored in file
+ ;# 870. Several callable entry points were broken
+ ;out of this routine and placed into HLCSMON1
+ ;
+ ;This routine has no required input parameters other than require that
+ ;U be defined, it does not instantiate any parameters either.
+ ;
+ ;
+ ;HLARY=array of all,HLARYD=array of display,HLARYO=array of old values
+ ;HLPTR1=top of display,HLPTR2=bottom of display,HLPTR3=last in HLVARY
+INIT N HLARY,HLARYD,HLARYO,HLCOFF,HLCON,HLDISP,HLPTR1,HLPTR2,HLPTR3,HLRESP
+ N HLDEV,HLERR,HLEVL,HLHDR,HLNODE,HLOCK
+ N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE
+ N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY
+ ;
+ D ^HLCSTERM ;Sets up variables to control display attributes
+INIT1 ;
+ ; Next 4 lines copied here from top of START by patch 73...
+ ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode
+ S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S"
+ D BUILDARY ;Build an array for display
+ QUIT:$$LOCKED(.HLOCK)  ;-> Anything locked?
+ ;
+ W HLCOFF ;Shut Cursor off
+ D HEADER^HLCSTERM ;Write header
+ D WDATA^HLCSMON1(5,17,"","","Incoming filers running => ")
+ D WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ")
+ D WDATA^HLCSMON1(5,20,"","","Select a Command:")
+ D WDATA^HLCSMON1(1,21,"","","(N)EXT  (B)ACKUP  (A)LL LINKS  (S)CREENED  (V)IEWS  (Q)UIT  (?) HELP: ")
+ ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode
+ S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S"
+START ;
+ D BUILDARY ;Build an array for display
+ D DISPLAY^HLCSMON1 ;Display the array just built
+ D READ
+ ;HLRESP=user response
+ I '$L(HLRESP) G START
+ G:HLRESP="Q" EXIT
+ ;any of following commands, kill old values
+ K HLARYO,HLTMSTAT,HLLMSTAT
+ I HLRESP="?" D HELP G INIT1
+ I HLRESP="V" D VIEW G INIT1
+ I "AS"[HLRESP K HLARY,HLEVL S HLDISP=HLRESP G INIT1
+ I "NB"[HLRESP D NEXT
+ G START
+ ;
+READ ;Prompt the user for the next action
+ D WDATA^HLCSMON1(71,21,"","","",1)
+ W HLCON
+ R X#1:3
+ W HLCOFF
+ S HLRESP=$S(X="":X,"Qq^"[X:"Q","Bb"[X:"B","Nn"[X:"N","Aa"[X:"A","Vv"[X:"V",X="?":"?","Ss"[X:"S",1:"")
+ Q
+ ;
+VIEW ;select new view
+ W HLCON,!!
+ N DIC
+ S DIC="^HLCS(869.3,1,6,",DIC(0)="QEA"
+ D ^DIC Q:Y<0
+ S HLVIEW=+Y,HLDISP="V"
+ W HLCOFF
+ Q
+ ;
+NEXT ;
+ ;Next page
+ I HLRESP="N" D
+ . ;no more
+ . I HLPTR2=HLPTR3 D EOB Q
+ . S Y=HLPTR2+10,HLEVL(HLPTR1)=""
+ . ;exceed list, get last 10
+ . I Y>HLPTR3 S HLPTR2=HLPTR3,HLPTR1=HLPTR2-9 Q
+ . S HLPTR1=HLPTR2,HLPTR2=Y
+ ;
+ ;Backup a page
+ I HLRESP="B" D
+ . ;top of list
+ . I HLPTR1=1 D EOB Q
+ . I HLDISP="S" S HLPTR1=$O(HLEVL(HLPTR1),-1) Q
+ . S Y=HLPTR1-9
+ . ;can't go back 10, reset to top
+ . I Y'>0 S HLPTR1=1,HLPTR2=10 Q
+ . S HLPTR2=HLPTR1,HLPTR1=Y
+ ;
+ ;Erase what might be displayed on line 22
+ D WDATA^HLCSMON1(1,22,IOELALL,"","")
+ Q
+EOB D WDATA^HLCSMON1(5,22,IORVON,IORVOFF,"CANNOT "_$S(HLRESP="N":"ADVANCE",1:"BACKUP")_" BEYOND END OF BUFFER")
+ W $C(7) H 2
+ Q
+ ;
+BUILDARY ;
+ K HLARYD
+ ;
+ ;if view is defined, get links
+ I $G(HLVIEW) D  S HLVIEW=0,HLDISP="V"
+ . N HLTMP
+ . K HLARY,HLEVL S HLI=0
+ . F  S HLI=$O(^HLCS(869.3,1,6,HLVIEW,1,HLI)) Q:'HLI  S HLYY=+$P($G(^(HLI,0)),U,2) D
+ .. S Y=$P($G(^HLCS(870,HLI,0)),U) Q:Y=""
+ .. ;build array by DISPLAY ORDER and then by NAME
+ .. I HLYY S HLTMP(HLYY,HLI)="" Q
+ .. S HLTMP(Y,HLI)=""
+ . S (HLI,HLYY)=0
+ . ;rebuild array to put in proper order
+ . F  S HLI=$O(HLTMP(HLI)),HLXX=0 Q:HLI=""  D
+ .. F  S HLXX=$O(HLTMP(HLI,HLXX)) Q:'HLXX  S HLYY=HLYY+1,HLARY(HLYY,HLXX)=""
+ . S HLPTR3=HLYY
+ ;
+ I '$D(HLARY)  S HLYY=0,HLXX="" D
+ . ;build array in alphabetical order
+ . F  S HLXX=$O(^HLCS(870,"B",HLXX)) Q:HLXX=""  S Y=$O(^(HLXX,0)),HLYY=HLYY+1,HLARY(HLYY,Y)=""
+ . S HLPTR3=HLYY
+ ;
+ S HLI=HLPTR1,HLYY=6 ;HLYY=6TH Line of display
+ ;HLARYD(6) through HLARYD(15) with 6 through 15 also representing line
+ ;numbers on the display
+ F HLI=HLI:1 S HLXX=$O(HLARY(HLI,0)) Q:HLYY=16!'HLXX  D COPY
+ S HLPTR2=HLI-1
+ ;Set all HLARY elements not defined on this pass to null
+ F HLYY=HLYY:1:15 S HLARYD(HLYY)=""
+ Q
+COPY ;
+ Q:'$D(^HLCS(870,HLXX))
+ ;
+ ;These lock tags lock nodes in the global so that the screen is
+ ;refreshed in real-time. The lock forces the buffer to be refreshed,
+ ;so that the display is up to date.
+ ;
+ ;**109**
+ ;L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOCK
+ ;
+ ; Set, even if not able to lock...
+ S Y=$G(^HLCS(870,HLXX,0))
+ ;
+ ;name^rec^proc^send^sent^device^state^error
+ S HLARYD(HLYY)=$P(Y,U)_"^^^^^"_$P(Y,U,4)_"^"_$P(Y,U,5)_"^"_$P(Y,U,19)
+ ;
+ ;**109**
+ ;L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLOCK
+ ;L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER")
+ ;
+ S $P(HLARYD(HLYY),U,2)=$G(^HLCS(870,HLXX,"IN QUEUE BACK POINTER"))
+ ;
+ ;**109**
+ ;L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKLOCK
+ ;L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+ ;
+ S $P(HLARYD(HLYY),U,3)=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
+ ;
+ ;**109**
+ ;L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKLOCK
+ ;L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER")
+ ;
+ S $P(HLARYD(HLYY),U,4)=$G(^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"))
+ ;
+ ;**109**
+ ;L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHKLOCK
+ ;L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER")
+ ;
+ S $P(HLARYD(HLYY),U,5)=$G(^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"))
+ ;
+ S X=HLARYD(HLYY),Y=$P(X,U,2)+$P(X,U,3)+$P(X,U,4)+$P(X,U,5)
+ ;if Select and the Y=0, nothing to report
+ I 'Y,HLDISP="S" S HLARYD(HLYY)="" Q
+ S HLYY=HLYY+1
+ Q
+ ;
+CHKLOCK ; Call here immediately after trying to lock.  And, BE SURE that
+ ; nothing might occur that would change $T after the lock attempt!!
+ ; $T,HLXX -- req
+ N NM870
+ QUIT:$T  ;-> Lock obtained...
+ S NM870=$P($G(^HLCS(870,+HLXX,0)),U)
+ S NM870=$S(NM870]"":NM870_" (IEN #"_HLXX_")",1:"IEN #"_HLXX)
+ S HLOCK(NM870)=""
+ QUIT
+ ;
+HELP ;
+ W HLCON,@IOF
+ W !,"You have the following options when monitoring the Messaging System:"
+ W !,"Enter the command letter parentheses: N,B,Q,A,S,V or ?"
+ W !!,"(N) takes you to the next page of the display of Logical Links."
+ W !!,"(B) takes you back one page."
+ W !!,"(Q) terminates the monitor."
+ W !!,"(A) provides a display of all links defined on your system."
+ W !!,"(S) displays only those links that have had message traffic."
+ W !!,"(V) prompts for a view name and displays links defined in view."
+ W !!,"    Note that (S) is the default display at startup."
+ W !!,"**PRESS <RET> TO CONTINUE**"
+ R X:DTIME
+ W @IOF
+ W !,?25,"Device Types and corresponding prefixes:"
+ W !!,?30,"PC -- Persistent TCP/IP Client"
+ W !!,?30,"NC -- Non-Persistent TCP/IP Client"
+ W !!,?30,"SS -- Single-threaded TCP/IP Server"
+ W !!,?30,"MS -- Multi-threaded TCP/IP Server"
+ W !!,?30,"SH -- Serial HLLP"
+ W !!,?30,"SX -- Serial X3.28"
+ W !!,?30,"MM -- MailMan"
+ W !!,"**PRESS <RET> TO CONTINUE**"
+ R X:DTIME
+ W HLCOFF
+ Q
+EXIT ;
+ ;Turn Cursor back on
+ W HLCON
+ D KVAR^HLCSTERM
+ Q
+ ;
+LOCKED(HLOCK) ; Anything locked?
+ ;
+ ;
+ ; Nothing locked...
+ I '$D(HLOCK) QUIT "" ;->
+ ;
+ W !!,"Editing of logical link data is occurring right now.  For this reason, some of"
+ W !,"the information on the 'System Link Monitor' report might not be accurate for"
+ W !,"the following node(s)..."
+ W !
+ ;
+ S HLOCK=""
+ F  S HLOCK=$O(HLOCK(HLOCK)) Q:HLOCK']""  D
+ .  W !,?5,HLOCK
+ ;
+ S ACTION=$$BTE("Press RETURN to print report or '^' to exit... ",1)
+ ;
+ QUIT $S(ACTION=1:1,1:"")
+ ;
+BTE(PMT,FF) ;
+ N DIR,DIRUT,DTOUT,DUOUT,X,Y
+ F X=1:1:$G(FF) W !
+ S DIR(0)="EA",DIR("A")=PMT
+ D ^DIR
+ QUIT $S(Y=1:"",1:1)
+ ;

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m

-              r613
+              r623
+HLCSMON1        ;SF-Utilities for Driver Program  ;07/17/2007  17:05
+        ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;This routine contains several entry points called from HLCSMON
+        ;no input parameters are required. All variables used which are
+        ;not newed here are newed in HLCSMON
+        ;
+DISPLAY ;display link info
+        ;turn of line wrap
+        S HLXX=0,X=0 X ^%ZOSF("RM")
+        F  S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0)  D WLINE(HLXX)
+        ;DISPLAY INCOMING FILER STATUS
+        ; patch HL*1.6*122
+        S HLXX=$P(HLRUNCNT,"^",1)
+        ; S HLXX=$$CNTFLR^HLCSUTL2("IN")
+        I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("IN")
+        ;
+        ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
+        I (HLXX'=+HLRUNCNT) D
+        .D WDATA(5,17,"","",$J(" ",31)),WDATA^HLCSMON1(5,17,"","","Incoming filers running => ",35)
+        .I (HLXX) D WDATA(32,17,"","",HLXX)
+        .I ('HLXX) D WDATA(32,17,IOINHI,IOINORM,"Zero")
+        .S $P(HLRUNCNT,"^",1)=HLXX
+        ;DISPLAY OUTGOING FILER STATUS
+        ; patch HL*1.6*122
+        S HLXX=$P(HLRUNCNT,"^",2)
+        ; S HLXX=$$CNTFLR^HLCSUTL2("OUT")
+        I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("OUT")
+        ;
+        ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
+        I (HLXX'=+$P(HLRUNCNT,"^",2)) D
+        .D WDATA(5,18,"","",$J(" ",31)),WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ",35)
+        .I (HLXX) D WDATA(32,18,"","",HLXX)
+        .I ('HLXX) D WDATA(32,18,IOINHI,IOINORM,"Zero")
+        .S $P(HLRUNCNT,"^",2)=HLXX
+        S X=$$TM^%ZTLOAD
+        I X'=$G(HLTMSTAT) D
+        .S HLTMSTAT=X
+        .S HLXX=$S('HLTMSTAT:"***TASKMAN NOT RUNNING!!!***",1:"")
+        .I 'HLTMSTAT D WDATA^HLCSMON1(45,17,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1
+        .E  D WDATA(45,17,IOELEOL,"",$J("TaskMan running ",16)) ;D WDATA(5,19,IOELALL,"","")
+        S X=$$STAT^HLCSLM
+        I X'=$G(HLLMSTAT) D
+        .S HLLMSTAT=X Q:HLLMSTAT=3
+        .S HLXX=$S('HLLMSTAT:"***LINK MANAGER NOT RUNNING!!!***",1:"")
+        .I 'HLLMSTAT D WDATA^HLCSMON1(45,18,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1
+        .E  D WDATA^HLCSMON1(45,18,IOELEOL,"",$J("Link Manager running",18))
+        ;Turn terminal line wrap back on
+        D WDATA(45,19,IOELEOL,"",$$SLM^HLEVUTIL) ; HL*1.6*109
+        S X=IOM X ^%ZOSF("RM")
+        Q
+        ;
+WLINE(HLXX)     ;write line from HLARYD=current values, HLARYO=old values
+        ;if values haven't changed, don't do anything
+        I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q
+        S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1
+        ; patch HL*1.6*122
+        ; F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
+        F X=1,7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,10)
+        F X=2:1:5 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
+        S X=6,@$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,7)
+        ;
+        ;if link is in error, write node in rev. video
+        I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14
+        ;Turn off terminal line wrap & inform O/S where cursor is located
+        S DY=HLXX X IOXY,^%ZOSF("XY")
+        ; patch HL*1.6*122
+        W:HLERR="" ?4,HLNODE
+        W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?63,HLSTAT
+        ;
+        Q
+        ;
+WDATA(DX,DY,IO1,IO2,HLDATA,HLENGTH)     ;
+        ;
+        ;First erase the data block then write to it. Attributes are
+        ;contained in IO1 & IO2
+        ;
+        N X S X=0 X ^%ZOSF("RM") X ^%ZOSF("XY")
+        ;Turn off terminal line wrap & inform O/S where cursor is located
+        I '$D(HLENGTH) S HLENGTH=$L(HLDATA)
+        X IOXY W IOSC,$E($J(" ",79),1,HLENGTH),IORC W IO1,$E(HLDATA,1,HLENGTH),IO2
+        S X=IOM X ^%ZOSF("RM")
+        ;Turn terminal line wrap back on
+        Q
+HLCSMON1 ;SF-Utilities for Driver Program  ;02/04/2004  10:25
+ ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, 1995
+ ;
+ ;This routine contains several entry points called from HLCSMON
+ ;no input parameters are required. All variables used which are
+ ;not newed here are newed in HLCSMON
+ ;
+DISPLAY ;display link info
+ ;turn of line wrap
+ S HLXX=0,X=0 X ^%ZOSF("RM")
+ F  S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0)  D WLINE(HLXX)
+ ;DISPLAY INCOMING FILER STATUS
+ S HLXX=$$CNTFLR^HLCSUTL2("IN")
+ ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
+ I (HLXX'=+HLRUNCNT) D
+ .D WDATA(5,17,"","",$J(" ",31)),WDATA^HLCSMON1(5,17,"","","Incoming filers running => ",35)
+ .I (HLXX) D WDATA(32,17,"","",HLXX)
+ .I ('HLXX) D WDATA(32,17,IOINHI,IOINORM,"Zero")
+ .S $P(HLRUNCNT,"^",1)=HLXX
+ ;DISPLAY OUTGOING FILER STATUS
+ S HLXX=$$CNTFLR^HLCSUTL2("OUT")
+ ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
+ I (HLXX'=+$P(HLRUNCNT,"^",2)) D
+ .D WDATA(5,18,"","",$J(" ",31)),WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ",35)
+ .I (HLXX) D WDATA(32,18,"","",HLXX)
+ .I ('HLXX) D WDATA(32,18,IOINHI,IOINORM,"Zero")
+ .S $P(HLRUNCNT,"^",2)=HLXX
+ S X=$$TM^%ZTLOAD
+ I X'=$G(HLTMSTAT) D
+ .S HLTMSTAT=X
+ .S HLXX=$S('HLTMSTAT:"***TASKMAN NOT RUNNING!!!***",1:"")
+ .I 'HLTMSTAT D WDATA^HLCSMON1(45,17,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1
+ .E  D WDATA(45,17,IOELEOL,"",$J("TaskMan running ",16)) ;D WDATA(5,19,IOELALL,"","")
+ S X=$$STAT^HLCSLM
+ I X'=$G(HLLMSTAT) D
+ .S HLLMSTAT=X Q:HLLMSTAT=3
+ .S HLXX=$S('HLLMSTAT:"***LINK MANAGER NOT RUNNING!!!***",1:"")
+ .I 'HLLMSTAT D WDATA^HLCSMON1(45,18,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1
+ .E  D WDATA^HLCSMON1(45,18,IOELEOL,"",$J("Link Manager running",18))
+ ;Turn terminal line wrap back on
+ D WDATA(45,19,IOELEOL,"",$$SLM^HLEVUTIL) ; HL*1.6*109
+ S X=IOM X ^%ZOSF("RM")
+ Q
+ ;
+WLINE(HLXX) ;write line from HLARYD=current values, HLARYO=old values
+ ;if values haven't changed, don't do anything
+ I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q
+ S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1
+ F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
+ ;if link is in error, write node in rev. video
+ I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14
+ ;Turn off terminal line wrap & inform O/S where cursor is located
+ S DY=HLXX X IOXY,^%ZOSF("XY")
+ W:HLERR="" ?5,HLNODE
+ W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?64,HLSTAT
+ Q
+ ;
+WDATA(DX,DY,IO1,IO2,HLDATA,HLENGTH) ;
+ ;
+ ;First erase the data block then write to it. Attributes are
+ ;contained in IO1 & IO2
+ ;
+ N X S X=0 X ^%ZOSF("RM") X ^%ZOSF("XY")
+ ;Turn off terminal line wrap & inform O/S where cursor is located
+ I '$D(HLENGTH) S HLENGTH=$L(HLDATA)
+ X IOXY W IOSC,$E($J(" ",79),1,HLENGTH),IORC W IO1,$E(HLDATA,1,HLENGTH),IO2
+ S X=IOM X ^%ZOSF("RM")
+ ;Turn terminal line wrap back on
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m

-              r613
+              r623
+HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT ;10/17/2007  08:56
+        ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+REPMSG  ;Duplicate messages on a queue
+        ; INPUT:  MSG   - Array which contains the queue and the
+        ;                 message numbers for msgs to be re-queued
+        ;                 MSG(QUEUE,NUMBER)
+        ; OUTPUT: NONE
+        N DIC,LLE,X,Y,DA,ERROR,FROMID,MSGID
+        N TOID,ENTRY,LLE
+        Q:('$D(MSG))
+        ;  create new entries
+        S (LLE,ERROR)=""
+        F  S LLE=$O(MSG(LLE)) Q:(LLE="")!(ERROR)  D
+        .S ENTRY=""
+        .F  S ENTRY=$O(MSG(LLE,ENTRY)) Q:(ENTRY="")!(ERROR)  D
+        ..S MSGID=$$ENQUEUE^HLCSQUE(LLE,"OUT")
+        ..I +MSGID'>0 S ERROR=1 Q
+        ..S TOID=$P(MSGID,"^",2)
+        ..M ^HLCS(870,LLE,2,TOID)=^HLCS(870,LLE,2,ENTRY)
+        ..;  Change .01 of new record to be IEN
+        ..S $P(^HLCS(870,LLE,2,TOID,0),"^",1)=TOID
+        ..S $P(^HLCS(870,LLE,2,TOID,0),"^",2)="P"
+EXIT    ;
+        Q
+        ;
+ENQUE(LINK,DIR,IEN773)  ;
+        ;This routine will place the message=IEN773 on the "AC" xref of file 773.
+        ;Input:
+        ;  DIR = "I" or "O", denoting the direction that the message is going in
+        ;  LINK = the ien of the logical link
+        ;  IEN773 = ien of the message in file 773
+        ;
+        Q:'$G(LINK)
+        I DIR'="I",DIR'="O" Q
+        Q:'$G(IEN773)
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
+        S ^HLMA("AC",DIR,LINK,IEN773)=""
+        L -^HLMA("AC",DIR,LINK,IEN773)
+        ;
+        S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja
+        I DIR="O" D LLCNT^HLCSTCP(LINK,3)
+        Q
+        ;
+DEQUE(LINK,DIR,IEN773)  ;
+        ;This routine will remove the message=IEN773 on the "AC" xref of file 773.
+        ;Input:
+        ;  DIR = "I" or "O", denoting the direction that the message is going in
+        ;  LINK = the ien of the logical link
+        ;  IEN773 = ien of the message in file 773
+        ;
+        Q:'$G(LINK)
+        I DIR'="I",DIR'="O" Q
+        Q:'$G(IEN773)
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
+        K ^HLMA("AC",DIR,LINK,IEN773)
+        L -^HLMA("AC",DIR,LINK,IEN773)
+        ;
+        Q
+HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT - 10/4/94 1pm
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+REPMSG ;Duplicate messages on a queue
+ ; INPUT:  MSG   - Array which contains the queue and the
+ ;                 message numbers for msgs to be re-queued
+ ;                 MSG(QUEUE,NUMBER)
+ ; OUTPUT: NONE
+ N DIC,LLE,X,Y,DA,ERROR,FROMID,MSGID
+ N TOID,ENTRY,LLE
+ Q:('$D(MSG))
+ ;  create new entries
+ S (LLE,ERROR)=""
+ F  S LLE=$O(MSG(LLE)) Q:(LLE="")!(ERROR)  D
+ .S ENTRY=""
+ .F  S ENTRY=$O(MSG(LLE,ENTRY)) Q:(ENTRY="")!(ERROR)  D
+ ..S MSGID=$$ENQUEUE^HLCSQUE(LLE,"OUT")
+ ..I +MSGID'>0 S ERROR=1 Q
+ ..S TOID=$P(MSGID,"^",2)
+ ..M ^HLCS(870,LLE,2,TOID)=^HLCS(870,LLE,2,ENTRY)
+ ..;  Change .01 of new record to be IEN
+ ..S $P(^HLCS(870,LLE,2,TOID,0),"^",1)=TOID
+ ..S $P(^HLCS(870,LLE,2,TOID,0),"^",2)="P"
+EXIT ;
+ Q
+ ;
+ENQUE(LINK,DIR,IEN773) ;
+ ;This routine will place the message=IEN773 on the "AC" xref of file 773.
+ ;Input:
+ ;  DIR = "I" or "O", denoting the direction that the message is going in
+ ;  LINK = the ien of the logical link
+ ;  IEN773 = ien of the message in file 773
+ ;
+ Q:'$G(LINK)
+ I DIR'="I",DIR'="O" Q
+ Q:'$G(IEN773)
+ S ^HLMA("AC",DIR,LINK,IEN773)=""
+ S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja
+ I DIR="O" D LLCNT^HLCSTCP(LINK,3)
+ Q
+ ;
+DEQUE(LINK,DIR,IEN773) ;
+ ;This routine will remove the message=IEN773 on the "AC" xref of file 773.
+ ;Input:
+ ;  DIR = "I" or "O", denoting the direction that the message is going in
+ ;  LINK = the ien of the logical link
+ ;  IEN773 = ien of the message in file 773
+ ;
+ Q:'$G(LINK)
+ I DIR'="I",DIR'="O" Q
+ Q:'$G(IEN773)
+ K ^HLMA("AC",DIR,LINK,IEN773)
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m

-              r613
+              r623
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;04/15/2008  10:58
+        ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140**;Oct 13, 1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; This is an implementation of the HL7 Minimal Lower Layer Protocol
+        ; taskman entry/startup option, HLDP defined in menu entry.
+        ;
+        Q:'$D(HLDP)
+        ; patch HL*1.6*122 start
+        L +^HLCS("HLTCPLINK",HLDP):5 I '$T D  Q
+        . D MON^HLCSTCP("TskLcked")
+        N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+        N HLZRULE
+        ;HLCSOUT= 1-error
+        I '$$INIT D EXITS("Init Error") Q
+        S HLDP("$J")=$J
+        S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
+        ; Start the client
+        I $G(HLTCPCS)="C" D  Q
+        . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
+        . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
+        . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+        . ; identify process for ^%SY
+        . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
+        . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
+        . K HLDP("$J",0)
+        . D ST1
+        . F  D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
+        . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
+        . I $G(HLCSOUT)=1 D  Q
+        .. D MON("Error") H 1
+        .. L -^HLCS("HLTCPLINK",HLDP)
+        . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
+        . D EXITS("Shutdown")
+        ;
+        S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
+        I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
+        S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+        ; identify process for ^%SY
+        ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+        D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
+        K HLDP("$J",0)
+        ; to stop the listener via updated Kernel API, need to pass the
+        ; listener logical link (HLDP)
+        S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
+        ;single threaded listener
+        I $G(HLTCPCS)="S" D  Q
+        . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
+        . I $$STOP D EXITS("Shutdown") Q
+        . D EXITS("Openfail")
+        ;
+        ;multi-threaded listener (for OpenM/NT)
+        I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D  Q
+        . L -^HLCS("HLTCPLINK",HLDP)
+        I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
+        D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
+        ; update status of listener
+        I $$STOP D EXITS("Shutdown") Q
+        D EXITS("Openfail")
+        ; HL*1.6*122 end
+        Q
+        ;
+SERVER(HLDP)    ; single server using Taskman
+        I '$$INIT D EXITS("Init error") Q
+        D ^HLCSTCP1
+        I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+        Q:$G(HLCSOUT)=1
+        D MON("Idle")
+        Q
+        ;
+SERVERS(HLDP)   ; Multi-threaded server using Taskman
+        I '$$INIT D EXITS("Init error") Q
+        G LISTEN
+        ;
+        ;multiple process servers, called from an external utility
+MSM     ;MSM entry point, called from User-Defined Services
+        ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+        ;HL7 Multi-Threaded SERVER
+        S (IO,IO(0))=$P
+        G LISTEN
+        ;
+LISTEN  ;
+        N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+        I '$$INIT D ^%ZTER Q
+        ; patch HL*1.6*122 start
+        S HLDP("$J")=$J
+        S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
+        S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
+        I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
+        S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+        ; identify process for ^%SY
+        ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+        D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
+        K HLDP("$J",0)
+        ; patch HL*1.6*122 end
+        ;HLLSTN used to identify a listener to tag MON
+        S HLLSTN=1
+        ;increment job count, run server
+        D UPDT(1),^HLCSTCP1,EXITM
+        Q
+        ;
+DCOPEN(HLDP)    ;open direct connect - called from HLMA2
+        Q:'$$INIT 0
+        Q:HLTCPADD=""!(HLTCPORT="") 0
+        Q:'$$OPEN^HLCSTCP2 0
+        Q 1
+        ;
+INIT()  ; Initialize Variables
+        ; HLDP should be set to the IEN or name of Logical Link, file 870
+        S HLOS=$P($G(^%ZOSF("OS")),"^")
+        N DA,DIQUIET,DR,TMP,X,Y
+        ; patch HL*1.6*140
+        ; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
+        S HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP
+        S DIQUIET=1
+        D DT^DICRW
+        I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
+        S DA=HLDP
+        ; patch HL*1.6*122 for field 400.09
+        S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
+        D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+        ;
+        I $D(TMP("DIERR")) QUIT 0
+        ; -- re-transmit attempts
+        S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
+        S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I"))
+        ; -- exceed re-transmit action
+        S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
+        ; -- block size
+        S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
+        ; -- read timeout
+        S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
+        ; -- ack timeout
+        S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
+        ; -- uni-directional wait
+        S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
+        ; -- tcp address
+        S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
+        ; -- tcp port
+        S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
+        ; -- tcp/ip service type
+        S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
+        ; -- link persistence
+        S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
+        ; -- retention
+        S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
+        ;
+        ; patch HL*1.6*140
+        ; patch HL*1.6*122 for field 400.09
+        ; -- tcp/ip openfail timeout
+        ; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
+        S HLTCPLNK("TIMEOUT")=+$G(TMP(870,DA_",",400.09,"I"))
+        ;
+        ; -- set defaults in case something's not set
+        S:HLDREAD=0 HLDREAD=10
+        S:HLDBACK=0 HLDBACK=60
+        ; patch HL*1.6*122
+        ; S:HLDBSIZE=0 HLDBSIZE=245
+        S:HLDBSIZE<245 HLDBSIZE=245
+        S:HLDRETR=0 HLDRETR=5
+        S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
+        ;
+        ; patch HL*1.6*140, the defaut is 30
+        ; patch HL*1.6*122 for field 400.09
+        ; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
+        S:(HLTCPLNK("TIMEOUT")<1) HLTCPLNK("TIMEOUT")=30
+        ;
+        Q 1
+        ;
+ST1     ;record startup in 870 for single server
+        ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+        ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+        N HLJ,X
+        ; HL*1.6*122 remove unnecessary locks
+        ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+        S X="HLJ(870,"""_HLDP_","")"
+        S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
+        I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
+        E  S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+        I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
+        S:$G(ZTSK) @X@(11)=ZTSK
+        D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
+        ;L -^HLCS(870,HLDP,0)
+        Q
+        ;
+MON(Y)  ;Display current state & check for shutdown
+        ;don't display for multiple server
+        Q:$G(HLLSTN)
+        ; HL*1.6*122 remove unnecessary locks
+        ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+        S $P(^HLCS(870,HLDP,0),U,5)=Y
+        ;L -^HLCS(870,HLDP,0)
+        Q:'$D(HLTRACE)
+        N X U IO(0)
+        W !,"IN State: ",Y
+        I '$$STOP D
+        . ; patch HL*1.6*122
+        . ; R !,"Type Q to Quit: ",X#1:1
+        . R !,"Type Q to Quit: ",X:1
+        . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+        . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
+        . ; patch HL*1.6*122 end
+        U IO
+        Q
+UPDT(Y) ;update job count for multiple servers,X=1 increment
+        N HLJ,X
+        ;
+        ; HL*1.6*122 start
+        ; F  L +^HLCS(870,HLDP,0):2 Q:$T
+        Q:'$G(HLDP)
+        Q:'$D(^HLCS(870,"E","M",HLDP))
+        F  L +^HLCS(870,HLDP,0):10 Q:$T  H 1
+        ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+        S X=+$P(^HLCS(870,HLDP,0),U,5)
+        I X<0 S X=0
+        S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
+        ;if incrementing, set the Device Type field to Multi-Server
+        ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
+        I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
+        ; HL*1.6*122 end
+        ;
+        L -^HLCS(870,HLDP,0)
+        Q
+STOP()  ;stop flag set
+        N X
+        F  L +^HLCS(870,HLDP,0):2 Q:$T
+        S X=+$P(^HLCS(870,HLDP,0),U,15)
+        L -^HLCS(870,HLDP,0)
+        Q X
+        ;
+LLCNT(DP,Y,Z)   ;update Logical Link counters
+        ;DP=ien of Logical Link in file 870
+        ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+        ;Z: ""=add to counter, 1=subtract from counter
+        Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
+        N P,X
+        S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
+        ; patch HL*1.6*122 start
+        ; F  L +^HLCS(870,DP,P):2 Q:$T
+        ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+        I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
+        I OS'["DSM",OS'["OpenM" D
+        . F  L +^HLCS(870,DP,P):10 Q:$T  H 1
+        . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+        . L -^HLCS(870,DP,P)
+        E  D
+        . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
+        ; L -^HLCS(870,DP,P)
+        ; patch HL*1.6*122 end
+        Q
+SDFLD   ; set Shutdown? field to yes
+        Q:'$G(HLDP)
+        ; HL*1.6*122 remove unnecessary lock and call to FM
+        S $P(^HLCS(870,HLDP,0),U,15)=1
+        ;N HLJ,X
+        ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+        ;14=Shutdown LLP?
+        ;S HLJ(870,HLDP_",",14)=1
+        ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+        ;L -^HLCS(870,HLDP,0)
+        Q
+        ;
+EXITS(Y)        ; shutdown and clean up the listener process for either
+        ; single-threaded or multi-threaded
+        N HLJ,X
+        F  L +^HLCS(870,HLDP,0):2 Q:$T
+        ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+        S X="HLJ(870,"""_HLDP_","")"
+        S @X@(4)=Y,@X@(11)="@"
+        S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
+        D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
+        L -^HLCS(870,HLDP,0)
+        I $D(ZTQUEUED) S ZTREQ="@"
+        ; HL*1.6*122
+        L -^HLCS("HLTCPLINK",HLDP)
+        Q
+        ;
+EXITM   ;Multiple service shutdown and clean up
+        ; shutdown and clean up a connection spawned by the listener
+        ; process for a multi-threaded listener
+        D UPDT(0)
+        I $D(ZTQUEUED) S ZTREQ="@"
+        Q
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133**;Oct 13, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ; This is an implementation of the HL7 Minimal Lower Layer Protocol
+ ;
+ ;taskman entry/startup option, HLDP defined in menu entry,
+ Q:'$D(HLDP)
+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+ ;HLCSOUT= 1-error
+ I '$$INIT D EXITS("Init Error") Q
+ ; Start the client
+ I $G(HLTCPCS)="C" D  Q
+ . ; identify process for ^%SY
+ . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
+ . D ST1
+ . F  D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
+ . I $G(HLCSOUT)=1 D MON("Error") H 1 Q
+ . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
+ . D EXITS("Shutdown")
+ ;
+ ; identify process for ^%SY
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+ ;HLCSFAIL=1 port failed to open
+ S HLCSFAIL=1
+ ;single threaded listener
+ I $G(HLTCPCS)="S" D  Q
+ . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")")
+ . ;couldn't open listener port
+ . I HLCSFAIL D EXITS("Openfail") Q
+ ;
+ ;multi-threaded listener (OpenM)
+ I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D  Q
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
+ Q
+ ;
+SERVER(HLDP) ; single server using Taskman
+ S HLCSFAIL=0
+ I '$$INIT D EXITS("Init error") Q
+ D ^HLCSTCP1
+ I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+ Q:$G(HLCSOUT)=1
+ D MON("Idle")
+ Q
+ ;
+SERVERS(HLDP) ; Multi-threaded server using Taskman
+ I '$$INIT D EXITS("Init error") Q
+ G LISTEN
+ ;
+ ;multiple process servers, called from an external utility
+MSM ;MSM entry point, called from User-Defined Services
+ ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+ ;HL7 Multi-Threaded SERVER
+ S (IO,IO(0))=$P
+ G LISTEN
+ ;
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",HLDP=%
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **Cache'/VMS specific code**
+ O IO::5 E  D MON("Openfail") Q
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+ D LISTEN C IO Q
+ ;
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = device^HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **VMS specific code, need to share device**
+ O IO:(TCPDEV):60 E  D MON("Openfail") Q
+LISTEN ;
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+ I '$$INIT D ^%ZTER Q
+ ; identify process for ^%SY
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+ ;HLLSTN used to identify a listener to tag MON
+ S HLLSTN=1
+ ;increment job count, run server
+ D UPDT(1),^HLCSTCP1,EXITM
+ Q
+ ;
+DCOPEN(HLDP) ;open direct connect - called from HLMA2
+ Q:'$$INIT 0
+ Q:HLTCPADD=""!(HLTCPORT="") 0
+ Q:'$$OPEN^HLCSTCP2 0
+ Q 1
+ ;
+INIT() ; Initialize Variables
+ ; HLDP should be set to the IEN or name of Logical Link, file 870
+ S HLOS=$P($G(^%ZOSF("OS")),"^")
+ N DA,DIQUIET,DR,TMP,X,Y
+ S DIQUIET=1
+ D DT^DICRW
+ I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
+ S DA=HLDP
+ S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
+ D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+ ;
+ I $D(TMP("DIERR")) QUIT 0
+ ; -- re-transmit attempts
+ S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
+ S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I"))
+ ; -- exceed re-transmit action
+ S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
+ ; -- block size
+ S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
+ ; -- read timeout
+ S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
+ ; -- ack timeout
+ S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
+ ; -- uni-directional wait
+ S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
+ ; -- tcp address
+ S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
+ ; -- tcp port
+ S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
+ ; -- tcp/ip service type
+ S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
+ ; -- link persistence
+ S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
+ ; -- retention
+ S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
+ ;
+ ; -- set defaults in case something's not set
+ S:HLDREAD=0 HLDREAD=10
+ S:HLDBACK=0 HLDBACK=60
+ S:HLDBSIZE=0 HLDBSIZE=245
+ S:HLDRETR=0 HLDRETR=5
+ S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
+ ;
+ Q 1
+ ;
+ST1 ;record startup in 870 for single server
+ ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+ ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S X="HLJ(870,"""_HLDP_","")"
+ S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
+ I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
+ E  S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+ I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
+ S:$G(ZTSK) @X@(11)=ZTSK
+ D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ Q
+ ;
+MON(Y) ;Display current state & check for shutdown
+ ;don't display for multiple server
+ Q:$G(HLLSTN)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S $P(^HLCS(870,HLDP,0),U,5)=Y
+ L -^HLCS(870,HLDP,0)
+ Q:'$D(HLTRACE)
+ N X U IO(0)
+ W !,"IN State: ",Y
+ I '$$STOP D
+ . R !,"Type Q to Quit: ",X#1:1
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+ U IO
+ Q
+UPDT(Y) ;update job count for multiple servers,X=1 increment
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+ ;if incrementing, set the Device Type field to Multi-Server
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ Q
+STOP() ;stop flag set
+ N X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S X=+$P(^HLCS(870,HLDP,0),U,15)
+ L -^HLCS(870,HLDP,0)
+ Q X
+ ;
+LLCNT(DP,Y,Z) ;update Logical Link counters
+ ;DP=ien of Logical Link in file 870
+ ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+ ;Z: ""=add to counter, 1=subtract from counter
+ Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
+ N P,X
+ S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
+ F  L +^HLCS(870,DP,P):2 Q:$T
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+ L -^HLCS(870,DP,P)
+ Q
+SDFLD ; set Shutdown? field to yes
+ Q:'$G(HLDP)
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ ;14=Shutdown LLP?
+ S HLJ(870,HLDP_",",14)=1
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ Q
+ ;
+EXITS(Y) ; Single service shutdown and cleans up
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+ S X="HLJ(870,"""_HLDP_","")"
+ S @X@(4)=Y,@X@(11)="@"
+ S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
+ D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+ Q
+ ;
+EXITM ;Multiple service shutdown and clean up
+ D UPDT(0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m

-              r613
+              r623
+HLCSTCP1        ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/15/08  11:11
+        ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140**;OCT 13,1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;Receiver
+        ;connection is initiated by sender and listener accepts connection
+        ;and calls this routine
+        ;
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
+        N HLMIEN,HLASTMSG
+        ;
+        ; patch HL*1.6*140, save IO
+        S HLTCPORT("IO")=IO ;RWF
+        ; patch HL*1.6*122 start
+        ; variable to replace ^TMP
+        N HLTMBUF
+        ;
+        ; for HL7 application proxy user
+        ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
+        N HLDUZ
+        S HLDUZ=+$G(DUZ)
+        ;
+        D MON^HLCSTCP("Open")
+        ; K ^TMP("HLCSTCP",$J,0)
+        S HLMIEN=0,HLASTMSG=""
+        ;
+        ; patch HL*1.6*122 TEST v2: DUZ code removed
+        ; set DUZ for application proxy user
+        ;; D PROXY^HLCSTCP4
+        ;
+        F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
+        . ; clean variables
+        . D CLEANVAR^HLCSTCP4
+        . ; patch HL*1.6*140, restore the saved IO
+        . S IO=HLTCPORT("IO") ;RWF
+        . S HLMIEN=$$READ
+        . Q:'HLMIEN
+        . ;
+        . ; patch HL*1.6*122 TEST v2: DUZ code removed
+        . ; DUZ comparison/reset for application proxy user
+        . ;; D HLDUZ^HLCSTCP4
+        . D HLDUZ2^HLCSTCP4
+        . ; protect HLDUZ
+        . N HLDUZ
+        . D PROCESS
+        ; patch HL*1.6*122 end
+        Q
+        ;
+PROCESS ;check message and reply
+        ;HLDP=LL in 870
+        N HLTCP,HLTCPI,HLTCPO
+        S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
+        ;update monitor, msg. received
+        D LLCNT^HLCSTCP(HLDP,1)
+        D NEW^HLTP3(HLMIEN)
+        ;I IO'=HLTCPORT("IO") D ^%ZTER ;RWF
+        ;update monitor, msg. processed
+        D LLCNT^HLCSTCP(HLDP,2)
+        Q
+        ;
+READ()  ;read 1 message, returns ien in 773^ien in 772 for message
+        D MON^HLCSTCP("Reading")
+        N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+        ;HLDSTRT=start char., HLDEND=end char., HLRS=record separator
+        S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
+        ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+        ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack
+        ; HL*1.6*122 start
+        ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+        S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK
+        N HLBUFF,HLXX,MAXWAIT
+        ; based on patch 132 for readtime
+        S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
+        S HLRS("START-FLAG")=0
+        S HLTMBUF(0)=""
+        ; variable used to store data in HLBUFF
+        S HLX(1)=$G(HLTMBUF(1))
+        S HLTMBUF(1)=""
+        S HLBUFF("START")=0
+        S HLBUFF("END")=0
+        I (HLX]"")!(HLX(1)]"") D
+        . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D
+        .. S HLBUFF("START")=1
+        . I (HLX[HLDEND)!(HLX(1)[HLDEND) D
+        .. S HLBUFF("END")=1
+        F  D RDBLK Q:HLRDOUT
+        ;**132**
+        ;switch to null device if opened to prevent 'leakage'
+        I $G(IO(0))]"",IO(0)'=IO U IO(0)
+        ;
+        ;save any excess for next time
+        S:HLX]"" HLTMBUF(0)=HLX
+        S:HLX(1)]"" HLTMBUF(1)=HLX(1)
+        I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
+        Q HLIND1
+        ;
+RDBLK   ;
+        ; initialize
+        S HLBUFF=""
+        ;
+        ;S HLDB=HLDBSIZE-$L(HLX)
+        ; store the total length of HLX and HLX(1) in HLDB(1)
+        S HLDB(1)=$L(HLX)+$L(HLX(1))
+        ;
+        ;**132 **
+        ;U IO R X#HLDB:HLDREAD
+        ; U IO R X#HLDB:MAXWAIT
+        ;
+        ; remove the readcount to speedup GT.M
+        U IO
+        R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT
+        ;
+        I HLBUFF]"" D
+        . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D
+        .. ; remove the extraneous text prefixing the "START" char
+        .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99)
+        .. S HLBUFF("START")=1
+        . ;
+        . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
+        ; detect disconnect for GT.M
+        I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
+        ; timedout, <clean up>, quit
+        ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+        ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
+        ; patch HL*1.6*140
+        ; I '$T,HLBUFF="",HLX="",HLX(1)="" D  Q
+        I HLBUFF="",HLX="",HLX(1)="" D  Q
+        . D:('HLHDR)&('HLIND1) CLEAN
+        ;add incoming line to what wasn't processed in last read
+        ;S HLX=$G(HLX)_X
+        ; get block of characters from read buffer HLBUFF
+        ; every 'for-loop' deal with one read at most, and one message at most
+        ; if HLX is not empty, loop continues even no data is read
+        ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
+        ; quit, when HLRDOUT is set to 1, means one message is encountered
+        ; an "end"
+        ; F  D  Q:HLXX=""!(HLRDOUT)
+        F  D  Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
+        . ;
+        . ; if HLX(1) is not empty
+        . I HLX(1)]"" D
+        .. ; hldb(2) is the number of characters extracted from hlx(1)
+        .. ; to be concatenated with hlx
+        .. S HLDB(2)=HLDBSIZE-$L(HLX)
+        .. ; hlx(2) stores the first hldb(2) characters extracted
+        .. ; from hlx(1)
+        .. S HLX(2)=$E(HLX(1),1,HLDB(2))
+        .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1)))
+        .. S HLX=$G(HLX)_HLX(2)
+        . ;
+        . ; if HLX(1) is empty, and HLBUFF contains data
+        . ; all the data in hlx(1) need to be extracted first
+        . I HLX(1)="",HLBUFF]"" D
+        .. S HLDB=HLDBSIZE-$L(HLX)
+        .. S HLXX=$E(HLBUFF,1,HLDB)
+        .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF))
+        .. S HLX=$G(HLX)_HLXX
+        . ; quit when HLX is empty
+        . Q:(HLX="")
+        . ; ** 132 **
+        . ; if no segment end, HLX not full, go back for more
+        . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q
+        . ;add incoming line to what wasn't processed
+        . D RDBLK2
+        ;
+        ; it is possible one message is encountered an "end" and other
+        ; messages left in buffer,HLBUFF, save it in HLX for next run
+        I HLBUFF]"" D
+        . ; variable HLBUFF may remain data with size more than HLDBSIZE
+        . ; variable HLBUFF is not empty, only if the total length of
+        . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
+        . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
+        . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
+        . S HLX(1)=$G(HLX(1))_HLBUFF
+        . S HLBUFF=""
+        Q
+        ;
+RDBLK2  ;data stream: <sb>dddd<cr><eb><cr>
+        ; HL*1.6*122 end
+        ; look for segment= <CR>
+        F  Q:HLX'[HLRS  D  Q:HLRDOUT
+        . ; Get the first piece, save the rest of the line
+        . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
+        . ; check for start block, Quit if no ien
+        . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
+        .. S HLRS("START-FLAG")=1 ; HL*1.6*122
+        .. D:HLMSG(HLINE,0)[HLDSTRT
+        ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
+        ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
+        ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
+        ... D RESET:(HLINE>1)
+        .. ;
+        .. ; patch HL*1.6*122
+        .. ; if the first line less than 10 characters
+        .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D
+        ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10)
+        ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999)
+        .. ;
+        .. ;ping message
+        .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
+        .. ; get next ien to store
+        .. D MIEN^HLCSTCP4
+        .. K HLMSG
+        .. S (HLINE,HLHDR)=0
+        . ; check for end block; <eb><cr>
+        . I HLMSG(HLINE,0)[HLDEND D
+        .. ; patch HL*1.6*122 start
+        .. ;no msg. ien
+        .. ; Q:'HLIND1
+        .. I 'HLIND1 D CLEAN Q
+        .. ; Kill just the last line if no data before HLDEND
+        .. I $P(HLMSG(HLINE,0),HLDEND)']"" D
+        ... K HLMSG(HLINE,0) S HLINE=HLINE-1
+        .. E  S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND)
+        .. ; patch HL*1.6*122 end
+        .. ;
+        .. ; move into 772
+        .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
+        .. ;mark that end block has been received
+        .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
+        .. S $P(HLIND1,U,3)=1
+        .. S HLBUFF("HLIND1")=HLIND1
+        .. ;reset variables for next message
+        .. D CLEAN
+        . ;add blank line for carriage return
+        . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
+        Q:HLRDOUT
+        ;If the line is long and no <CR> move it into the array.
+        I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
+        . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
+        ;have start block but no record separator
+        I HLX[HLDSTRT D  Q
+        . ;check for more than 1 start block
+        . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
+        . ;
+        . ; patch HL*1.6*122
+        . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+        . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+        . ;
+        . D RESET:(HLHDR&(HLINE>1))
+        ;if no ien, reset
+        ; patch HL*1.6*122
+        ; I 'HLIND1 D CLEAN Q
+        I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q
+        ; big message-merge from local to global every 100 lines
+        I (HLINE-$O(HLMSG(0)))>100 D
+        . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
+        . ; reset working array
+        . K HLMSG
+        Q
+        ;
+SAVE(SRC,DEST)  ;save into global & set top node
+        ;SRC=source array (passed by ref.), DEST=destination global
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        I DEST["HLMA" D
+        . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
+        E  D
+        . F  L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T  H 1
+        ;
+        M @DEST=SRC
+        S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+        ;
+        I DEST["HLMA" L -^HLMA(+HLIND1)
+        E  L -^HL(772,+$P(HLIND1,U,2))
+        ;
+        Q
+        ;
+DELMSG(HLMAMT)  ;delete message from Message Administration/Message Text files.
+        N DIK,DA
+        S DA=+HLMAMT,DIK="^HLMA("
+        D ^DIK
+        S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
+        D ^DIK
+        Q
+PING    ;process PING message
+        S X=HLMSG(1,0)
+        ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
+        ; I X[HLDEND U IO W X,! D
+        I X[HLDEND U IO W X,HLTCPLNK("IOF") D
+        . ; switch to null device if opened to prevent 'leakage'
+        . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0)
+CLEAN   ;reset var. for next message
+        K HLMSG
+        S HLINE=0,HLRDOUT=1
+        Q
+        ;
+ERROR   ; Error trap for disconnect error and return back to the read loop.
+        ; patch HL*1.6*122
+        ; move to routine HLCSTCP4 (splitted-size over 10000)
+        D ERROR1^HLCSTCP4
+        Q
+        ;
+CC(X)   ;cleanup and close
+        D MON^HLCSTCP(X)
+        H 2
+        Q
+RESET   ;reset info as a result of no end block
+        N %
+        S HLMSG(1,0)=HLMSG(HLINE,0)
+        F %=2:1:HLINE K HLMSG(%,0)
+        S HLINE=1
+        Q
+HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07  08:58
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;Receiver
+ ;connection is initiated by sender and listener accepts connection
+ ;and calls this routine
+ ;
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
+ N HLMIEN,HLASTMSG
+ ;
+ ; patch HL*1.6*122 start
+ ; variable to replace ^TMP
+ N HLTMBUF
+ ; for HL7 application proxy user
+ N HLDUZ,DUZ
+ D MON^HLCSTCP("Open")
+ ; K ^TMP("HLCSTCP",$J,0)
+ S HLMIEN=0,HLASTMSG=""
+ ; set DUZ for application proxy user
+ D PROXY^HLCSTCP4
+ F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
+ . ; clean variables
+ . D CLEANVAR^HLCSTCP4
+ . S HLMIEN=$$READ
+ . Q:'HLMIEN
+ . ; DUZ comparison/reset for application proxy user
+ . D HLDUZ^HLCSTCP4
+ . ; protect HLDUZ
+ . N HLDUZ
+ . D PROCESS
+ ; patch HL*1.6*122 end
+ Q
+ ;
+PROCESS ;check message and reply
+ ;HLDP=LL in 870
+ N HLTCP,HLTCPI,HLTCPO
+ S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
+ ;update monitor, msg. received
+ D LLCNT^HLCSTCP(HLDP,1)
+ D NEW^HLTP3(HLMIEN)
+ ;update monitor, msg. processed
+ D LLCNT^HLCSTCP(HLDP,2)
+ Q
+ ;
+READ() ;read 1 message, returns ien in 773^ien in 772 for message
+ D MON^HLCSTCP("Reading")
+ N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+ ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
+ S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
+ ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+ ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack
+ ; HL*1.6*122 start
+ ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+ S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK
+ N HLBUFF,HLXX,MAXWAIT
+ ; based on patch 132 for readtime
+ S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
+ S HLRS("START-FLAG")=0
+ S HLTMBUF(0)=""
+ ; variable used to store data in HLBUFF
+ S HLX(1)=$G(HLTMBUF(1))
+ S HLTMBUF(1)=""
+ S HLBUFF("START")=0
+ S HLBUFF("END")=0
+ I (HLX]"")!(HLX(1)]"") D
+ . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D
+ .. S HLBUFF("START")=1
+ . I (HLX[HLDEND)!(HLX(1)[HLDEND) D
+ .. S HLBUFF("END")=1
+ F  D RDBLK Q:HLRDOUT
+ ;**132**
+ ;switch to null device if opened to prevent 'leakage'
+ I $G(IO(0))]"",IO(0)'=IO U IO(0)
+ ;
+ ;save any excess for next time
+ S:HLX]"" HLTMBUF(0)=HLX
+ S:HLX(1)]"" HLTMBUF(1)=HLX(1)
+ I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
+ Q HLIND1
+ ;
+RDBLK ;
+ ; initialize
+ S HLBUFF=""
+ ;
+ ;S HLDB=HLDBSIZE-$L(HLX)
+ ; store the total length of HLX and HLX(1) in HLDB(1)
+ S HLDB(1)=$L(HLX)+$L(HLX(1))
+ ;
+ ;**132 **
+ ;U IO R X#HLDB:HLDREAD
+ ; U IO R X#HLDB:MAXWAIT
+ ;
+ ; remove the readcount to speedup GT.M
+ U IO
+ R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT
+ I HLBUFF]"" D
+ . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D
+ .. ; remove the extraneous text prefixing the "START" char
+ .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99)
+ .. S HLBUFF("START")=1
+ . ;
+ . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
+ ; detect disconnect for GT.M
+ I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=""
+ ; timedout, <clean up>, quit
+ ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+ ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
+ I '$T,HLBUFF="",HLX="",HLX(1)="" D  Q
+ . D:('HLHDR)&('HLIND1) CLEAN
+ ;add incoming line to what wasn't processed in last read
+ ;S HLX=$G(HLX)_X
+ ;
+ ; get block of characters from read buffer HLBUFF
+ ; every 'for-loop' deal with one read at most, and one message at most
+ ; if HLX is not empty, loop continues even no data is read
+ ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
+ ; quit, when HLRDOUT is set to 1, means one message is encountered
+ ; an "end"
+ ; F  D  Q:HLXX=""!(HLRDOUT)
+ F  D  Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
+ . ;
+ . ; if HLX(1) is not empty
+ . I HLX(1)]"" D
+ .. ; hldb(2) is the number of characters extracted from hlx(1)
+ .. ; to be concatenated with hlx
+ .. S HLDB(2)=HLDBSIZE-$L(HLX)
+ .. ; hlx(2) stores the first hldb(2) characters extracted
+ .. ; from hlx(1)
+ .. S HLX(2)=$E(HLX(1),1,HLDB(2))
+ .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1)))
+ .. S HLX=$G(HLX)_HLX(2)
+ . ;
+ . ; if HLX(1) is empty, and HLBUFF contains data
+ . ; all the data in hlx(1) need to be extracted first
+ . I HLX(1)="",HLBUFF]"" D
+ .. S HLDB=HLDBSIZE-$L(HLX)
+ .. S HLXX=$E(HLBUFF,1,HLDB)
+ .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF))
+ .. S HLX=$G(HLX)_HLXX
+ . ; quit when HLX is empty
+ . Q:(HLX="")
+ . ; ** 132 **
+ . ; if no segment end, HLX not full, go back for more
+ . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q
+ . ;add incoming line to what wasn't processed
+ . D RDBLK2
+ ;
+ ; it is possible one message is encountered an "end" and other
+ ; messages left in buffer,HLBUFF, save it in HLX for next run
+ I HLBUFF]"" D
+ . ; variable HLBUFF may remain data with size more than HLDBSIZE
+ . ; variable HLBUFF is not empty, only if the total length of
+ . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
+ . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
+ . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
+ . S HLX(1)=$G(HLX(1))_HLBUFF
+ . S HLBUFF=""
+ Q
+ ;
+RDBLK2 ;data stream: <sb>dddd<cr><eb><cr>
+ ; HL*1.6*122 end
+ ; look for segment= <CR>
+ F  Q:HLX'[HLRS  D  Q:HLRDOUT
+ . ; Get the first piece, save the rest of the line
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
+ . ; check for start block, Quit if no ien
+ . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
+ .. S HLRS("START-FLAG")=1 ; HL*1.6*122
+ .. D:HLMSG(HLINE,0)[HLDSTRT
+ ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
+ ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
+ ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
+ ... D RESET:(HLINE>1)
+ .. ;
+ .. ; patch HL*1.6*122
+ .. ; if the first line less than 10 characters
+ .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D
+ ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10)
+ ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999)
+ .. ;
+ .. ;ping message
+ .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
+ .. ; get next ien to store
+ .. D MIEN^HLCSTCP4
+ .. K HLMSG
+ .. S (HLINE,HLHDR)=0
+ . ; check for end block; <eb><cr>
+ . I HLMSG(HLINE,0)[HLDEND D
+ .. ; patch HL*1.6*122 start
+ .. ;no msg. ien
+ .. ; Q:'HLIND1
+ .. I 'HLIND1 D CLEAN Q
+ .. ; Kill just the last line if no data before HLDEND
+ .. I $P(HLMSG(HLINE,0),HLDEND)']"" D
+ ... K HLMSG(HLINE,0) S HLINE=HLINE-1
+ .. E  S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND)
+ .. ; patch HL*1.6*122 end
+ .. ;
+ .. ; move into 772
+ .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
+ .. ;mark that end block has been received
+ .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
+ .. S $P(HLIND1,U,3)=1
+ .. S HLBUFF("HLIND1")=HLIND1
+ .. ;reset variables for next message
+ .. D CLEAN
+ . ;add blank line for carriage return
+ . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
+ Q:HLRDOUT
+ ;If the line is long and no <CR> move it into the array.
+ I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
+ ;have start block but no record seperator
+ I HLX[HLDSTRT D  Q
+ . ;check for more than 1 start block
+ . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
+ . ;
+ . ; patch HL*1.6*122
+ . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+ . ;
+ . D RESET:(HLHDR&(HLINE>1))
+ ;if no ien, reset
+ ; patch HL*1.6*122
+ ; I 'HLIND1 D CLEAN Q
+ I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q
+ ; big message-merge from local to global every 100 lines
+ I (HLINE-$O(HLMSG(0)))>100 D
+ . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
+ . ; reset working array
+ . K HLMSG
+ Q
+ ;
+SAVE(SRC,DEST) ;save into global & set top node
+ ;SRC=source array (passed by ref.), DEST=destination global
+ M @DEST=SRC
+ S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+ Q
+ ;
+DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
+ N DIK,DA
+ S DA=+HLMAMT,DIK="^HLMA("
+ D ^DIK
+ S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
+ D ^DIK
+ Q
+PING ;process PING message
+ S X=HLMSG(1,0)
+ I X[HLDEND U IO W X,! D
+ . ; switch to null device if opened to prevent 'leakage'
+ . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0)
+CLEAN ;reset var. for next message
+ K HLMSG
+ S HLINE=0,HLRDOUT=1
+ Q
+ ;
+ERROR ; Error trap for disconnect error and return back to the read loop.
+ S $ETRAP="D UNWIND^%ZTER"
+ I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q  ;VOE change for GT.M
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+ I $ECODE["UREAD" D UNWIND^%ZTER Q  ; HL*1.6*122 GT.M
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+ D UNWIND^%ZTER
+ Q
+ ;
+CC(X) ;cleanup and close
+ D MON^HLCSTCP(X)
+ H 2
+ Q
+RESET ;reset info as a result of no end block
+ N %
+ S HLMSG(1,0)=HLMSG(HLINE,0)
+ F %=2:1:HLINE K HLMSG(%,0)
+ S HLINE=1
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m

-              r613
+              r623
+HLCSTCP2        ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/2008  16:20
+        ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122,140**;Oct 13,1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;Sender
+        ;Request connection, send outbound message(s) delimited by MLLP
+        ;Input : HLDP=Logical Link to use
+        ; Set up error trap
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+        N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
+        ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
+        S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
+        ;
+        ; patch 122
+        ; patch 133
+        ; set IO(0) to the null device
+        I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D
+        . S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
+        . O IO(0) U IO(0)
+        ;
+        ;persistent conection, open connection first, HLPORT=open port
+        I $G(HLTCPLNK)["Y" F  Q:$$OPEN  G EXIT:$$STOP^HLCSTCP H 1
+        F  D QUE Q:$$STOP^HLCSTCP  D:'HLMSG  Q:$G(HLCSOUT)
+        . ;no messages to send
+        . D MON^HLCSTCP("Idle") H 3
+        . ;persistent connection, no retention
+        . Q:$G(HLTCPLNK)["Y"
+        . D MON^HLCSTCP("Retention")
+        . N % I 0
+        . ;if message comes in or ask to stop
+        . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
+        . E  S HLCSOUT=2 Q
+        . Q:$$STOP^HLCSTCP
+        . D MON^HLCSTCP("Idle")
+        ;Close port
+        I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+EXIT    Q
+        ;
+QUE     ; -- Check "OUT" queue for processing IF there is a message do it
+        ; and then check the link if it open or not
+        N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
+        N HLTMBUF
+        D MON^HLCSTCP("CheckOut")
+        ;HLMSG=next msg, set at tag DONE
+        I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
+        ;
+        S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
+        ;don't have message text or MSH, kill x-ref and decrement 'to send'
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+        I 'HLI!'HLJ D  Q
+        . F  L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T  H 1
+        . K ^HLMA("AC","O",HLDP,HLMSG)
+        . L -^HLMA("AC","O",HLDP,HLMSG)
+        . D LLCNT^HLCSTCP(HLDP,3,1)
+        . S HLMSG=0
+        ;
+        ;update msg status to 'being transmitted'; if cancelled decrement link and quit
+        I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+        ;number of retransmissions for message
+        S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
+        ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
+        ;quit if restart or shutdown, link is going down
+        I HLRETRY>HLDRETR D  Q:"I"'[HLRETRA
+        . D MON^HLCSTCP("Error")
+        . ;only 1 alert per link up time, don't send if restart
+        . D:'HLRETMG&(HLRETRA'="R")
+        .. ;send alert
+        .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+        .. ;get mailgroup from file 869.3
+        .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
+        .. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
+        .. D SETUP^XQALERT
+        . ;quit if action is ignore
+        . Q:"I"[HLRETRA
+        . ;this will shutdown this link
+        . S HLCSOUT=1
+        . ;action is shutdown, set shutdown flag so LM won't restart
+        . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
+        . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
+        I '$$OPEN Q
+        D MON^HLCSTCP("Send")
+        ; -- data passed in global array, success=1
+        I $$WRITE(HLMSG)<0 Q
+        S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
+        ;update status to awaiting response, decrement link if cancelled
+        I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+        ;set transmission count, get ACKTIMEOUT override
+        S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
+        ;get header of message just sent
+        K HLJ M HLJ=^HLMA(HLMSG,"MSH")
+        ;first component of sending app.
+        S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
+        ;msg type, msg. id, commit ack, and app. ack parameter
+        S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
+        ;MSA segment, message is a response, can't have an a. ack.
+        S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
+        ;for batch/file with commit ack, reset c. ack and a. ack variables
+        I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11)
+        ;get event protocol
+        S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
+        ;set link counter to msg sent
+        D LLCNT^HLCSTCP(HLDP,4)
+        ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
+        I HLN("ACAT")="NE",HLN("APAT")="NE" D  Q
+        .D DONE(3)
+        .;
+        .;
+        .H $G(HLDWAIT)
+        ;
+        ;do structure is to stack error
+        D
+        . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+        . ;HL*1.6*87: Read acknowledgement.
+        . ;Loop to re-read from buffer when receiving incorrect ack.
+        . F  D  Q:'+$G(HLREREAD)
+        .. S HLREREAD=1
+        .. ;override ack timeout
+        .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
+        .. ;check for response, quit if no-response, msg will be resent
+        .. ;HLRESP=ien 773^ien 772 for response message
+        .. S HLRESP=$$READ^HLCSTCP1()
+        .. ;if no response, decrement counter and quit
+        .. I 'HLRESP D  Q
+        ...D LLCNT^HLCSTCP(HLDP,4,1)
+        ...S HLREREAD="0^No Response"
+        ...;check if the port needs to be closed and re-opened before the next re-transmission attempt
+        ...I $G(HLDRETRY("CLOSE")) D CLOSE^%ZISTCP K HLPORT
+        .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
+        .. S X=$$RSP^HLTP31(HLRESP,.HLN)
+        .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
+        .. Q:'X
+        .. ;commit ack - done
+        .. I X=1 D  S HLREREAD="0^Commit Ack" Q
+        ... ;don't need app. ack, set status to complete
+        ... I "NE"[HLN("APAT") D  Q
+        ....D DONE(3)
+        ....;
+        ... ;response is deferred, set status to awaiting ack
+        ... D DONE(2)
+        ...;
+        .. ;Error, HLRESLT=error number^error message from HLTP3
+        .. I X=4 D  Q
+        ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
+        ...;
+        ... S HLREREAD="0^Error"
+        .. ;app ack was successful
+        .. D DONE(3) S HLREREAD="0^App Ack"
+        ..;
+        Q
+        ;
+DCSEND  ;direct connect
+        ; Set up error trap
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+        ; patch HL*1.6*122
+        N HLTMBUF
+        ;override ack timeout
+        I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
+        I $$WRITE(HLMSG)<0 D:$G(HLERROR)]""  Q  ;HL*1.6*77
+        .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
+        .  D LLCNT^HLCSTCP(HLDP,3,1)
+        D LLCNT^HLCSTCP(HLDP,4)
+        ;do structure is to stack error
+        D
+        . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+        . ;HLRESP=ien 773^ien 772 for response message
+        . S HLRESP=$$READ^HLCSTCP1()
+        ;
+        D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
+        I $G(HLERROR)']"" D
+        .D MON^HLCSTCP("Idle")
+        .I '$G(HLRESP) S HLERROR="108^No response"
+        ;Close port
+        I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+        Q
+        ;
+DONE(ST,ERR,ERRMSG)     ;set status to complete
+        ;ST=status, ERR=error ien, ERRMSG=error msg
+        D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
+        ;
+        D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+        ;
+        ;check for more msg.
+        I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
+        Q
+        ;
+CHKMSG(HLI)     ;check status of message and update if not cancelled
+        ;input: HLI=new status, HLMSG=ien of msg in 773
+        ;returns 1=msg was updated, 0=msg has been canceled
+        N X
+        ;
+        ; New HL*1.6*77 code starting here...
+        I '$D(^HLMA(HLMSG,"P")) D  Q 0
+        .  S HLERROR="2^Missing status field"
+        .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
+        .;
+        . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+        ;
+        ; End of HL*1.6*77
+        ;
+        ;get status, quit if msg was cancelled
+        ;
+        S X=+^HLMA(HLMSG,"P") Q:X=3 0
+        ;
+        ;update status if it is different
+        I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
+        ;
+        Q 1
+        ;
+WRITE(HLDA)     ; write message in HL7 format
+        ;  HLDA       - ien of message in 773
+        ;             - start block $C(11)
+        ;             - end block $C(28)
+        ;             - record separator $C(13)
+        ;Output(s): 1 - Successful
+        ;           -1 - Unsuccessful
+        ;
+        N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
+        S CRCOUNT=0
+        ;set error trap, used when called from HLTP3
+        ;
+        ; New HL*1.6*77 code starts here...
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+        I $G(^HLMA(HLDA,0))'>0 D  Q -1
+        .  S HLERROR="2^Message Text pointer missing"
+        S HLDA2=+$G(^HLMA(HLDA,0))
+        ; End of HL*1.6*77 modifications...
+        ;
+        Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
+        ; header is in ^HLMA(, message is in ^HL(772,
+        S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
+        U IO
+        D  W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
+        . F  S HLI=$O(@HLAR@(HLI)) Q:'HLI  S X=$G(^(HLI,0)) D
+        .. ;first line, need start block char.
+        .. S:LINENO=1 X=$C(11)_X
+        .. ; HL*1.6*122
+        .. ; I X]"" W X,!
+        .. N LENGTH
+        .. S LENGTH=$L(X)
+        .. ; buffer should be limited to 512
+        .. I LENGTH>512 D
+        ... N X1
+        ... F  Q:LENGTH<512  D
+        .... S X1=$E(X,1,512),X=$E(X,513,999999)
+        .... S LENGTH=$L(X)
+        .... ; patch HL*1.6*140
+        .... ; W X1,@IOF
+        .... W X1,@HLTCPLNK("IOF")
+        .. ;
+        .. ; @HLTCPLNK("IOF") (! or #) for flush character
+        .. I X]"" W X,@HLTCPLNK("IOF") S CRCOUNT=0
+        .. ;send CR
+        .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1
+        .. ; prevent from maxstring error
+        .. I CRCOUNT>200 W @HLTCPLNK("IOF") S CRCOUNT=0
+        .. S LINENO=LINENO+1
+        ; Sends end block for this message
+        S X=$C(28)_$C(13)
+        ; U IO W X,!
+        U IO W X,@HLTCPLNK("IOF")
+        ;switch to null device
+        I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
+        Q 1
+        ;
+OPEN()  ; -- Open TCP/IP device (Client)
+        ;HLPORT=port, defined only if port is open
+        ;HLPORTA=number of attempted opens
+        I $D(HLPORT) S IO=HLPORT D  Q 1
+        . U IO
+        . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
+        N HLDOM,HLI,HLIP,HLPORTA
+        G OPENA^HLCSTCP3
+        ;
+RDERR   D RDERR^HLCSTCP4 Q
+ERROR   D ERROR^HLCSTCP4 Q
+        ;
+CC(X)   ;cleanup and close
+        D MON^HLCSTCP(X)
+        I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+        ; patch HL*1.6*140
+        ; H 2
+        H 1
+        Q
+HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133**;Oct 13,1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;Sender
+ ;Request connection, send outbound message(s) delimited by MLLP
+ ;Input : HLDP=Logical Link to use
+ ; Set up error trap
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+ N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
+ ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
+ S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
+ ;
+ ;set IO(0) to the null device
+ S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
+ O IO(0) U IO(0)
+ ;
+ ;persistent conection, open connection first, HLPORT=open port
+ I $G(HLTCPLNK)["Y" F  Q:$$OPEN  G EXIT:$$STOP^HLCSTCP H 1
+ F  D QUE Q:$$STOP^HLCSTCP  D:'HLMSG  Q:$G(HLCSOUT)
+ . ;no messages to send
+ . D MON^HLCSTCP("Idle") H 3
+ . ;persistent connection, no retention
+ . Q:$G(HLTCPLNK)["Y"
+ . D MON^HLCSTCP("Retention")
+ . N % I 0
+ . ;if message comes in or ask to stop
+ . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
+ . E  S HLCSOUT=2 Q
+ . Q:$$STOP^HLCSTCP
+ . D MON^HLCSTCP("Idle")
+ ;Close port
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+EXIT Q
+ ;
+QUE ; -- Check "OUT" queue for processing IF there is a message do it
+ ; and then check the link if it open or not
+ N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
+ D MON^HLCSTCP("Check out")
+ ;HLMSG=next msg, set at tag DONE
+ I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
+ ;
+ ;**109**
+ ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete
+ ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q
+ ;L -^HLMA(HLMSG)
+ ;
+ S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
+ ;don't have message text or MSH, kill x-ref and decrement 'to send'
+ I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+ ;update msg status to 'being transmitted'; if cancelled decrement link and quit
+ I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+ ;number of retransmissions for message
+ S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
+ ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
+ ;quit if restart or shutdown, link is going down
+ I HLRETRY>HLDRETR D  Q:"I"'[HLRETRA
+ . D MON^HLCSTCP("Error")
+ . ;only 1 alert per link up time, don't send if restart
+ . D:'HLRETMG&(HLRETRA'="R")
+ .. ;send alert
+ .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+ .. ;get mailgroup from file 869.3
+ .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
+ .. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
+ .. D SETUP^XQALERT
+ . ;quit if action is ignore
+ . Q:"I"[HLRETRA
+ . ;this will shutdown this link
+ . S HLCSOUT=1
+ . ;action is shutdown, set shutdown flag so LM won't restart
+ . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
+ . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
+ I '$$OPEN Q
+ D MON^HLCSTCP("Send")
+ ; -- data passed in global array, success=1
+ I $$WRITE(HLMSG)<0 Q
+ S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
+ ;update status to awaiting response, decrement link if cancelled
+ I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+ ;set transmission count, get ACKTIMEOUT override
+ S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
+ ;get header of message just sent
+ K HLJ M HLJ=^HLMA(HLMSG,"MSH")
+ ;first component of sending app.
+ S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
+ ;msg type, msg. id, commit ack, and app. ack parameter
+ S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
+ ;MSA segment, message is a response, can't have an a. ack.
+ S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
+ ;for batch/file with commit ack, reset c. ack and a. ack variables
+ I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11)
+ ;get event protocol
+ S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
+ ;set link counter to msg sent
+ D LLCNT^HLCSTCP(HLDP,4)
+ ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
+ I HLN("ACAT")="NE",HLN("APAT")="NE" D  Q
+ .D DONE(3)
+ .;
+ .;
+ .H $G(HLDWAIT)
+ ;
+ ;do structure is to stack error
+ D
+ . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+ . ;HL*1.6*87: Read acknowledgement.
+ . ;Loop to re-read from buffer when receiving incorrect ack.
+ . F  D  Q:'+$G(HLREREAD)
+ .. S HLREREAD=1
+ .. ;override ack timeout
+ .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
+ .. ;check for response, quit if no-response, msg will be resent
+ .. ;HLRESP=ien 773^ien 772 for response message
+ .. S HLRESP=$$READ^HLCSTCP1()
+ .. ;if no response, decrement counter and quit
+ .. I 'HLRESP D  Q
+ ...D LLCNT^HLCSTCP(HLDP,4,1)
+ ...S HLREREAD="0^No Response"
+ ...;check if the port needs to be closed and re-opened before the next re-transmission attempt
+ ...I $G(HLDRETRY("CLOSE")) D CLOSE^%ZISTCP K HLPORT
+ .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
+ .. S X=$$RSP^HLTP31(HLRESP,.HLN)
+ .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
+ .. Q:'X
+ .. ;commit ack - done
+ .. I X=1 D  S HLREREAD="0^Commit Ack" Q
+ ... ;don't need app. ack, set status to complete
+ ... I "NE"[HLN("APAT") D  Q
+ ....D DONE(3)
+ ....;
+ ... ;response is deferred, set status to awaiting ack
+ ... D DONE(2)
+ ...;
+ .. ;Error, HLRESLT=error number^error message from HLTP3
+ .. I X=4 D  Q
+ ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
+ ...;
+ ... S HLREREAD="0^Error"
+ .. ;app ack was successful
+ .. D DONE(3) S HLREREAD="0^App Ack"
+ ..;
+ Q
+ ;
+DCSEND ;direct connect
+ ; Set up error trap
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+ ;override ack timeout
+ I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
+ I $$WRITE(HLMSG)<0 D:$G(HLERROR)]""  Q  ;HL*1.6*77
+ .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
+ .  D LLCNT^HLCSTCP(HLDP,3,1)
+ D LLCNT^HLCSTCP(HLDP,4)
+ ;do structure is to stack error
+ D
+ . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+ . ;HLRESP=ien 773^ien 772 for response message
+ . S HLRESP=$$READ^HLCSTCP1()
+ ;
+ D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
+ I $G(HLERROR)']"" D
+ .D MON^HLCSTCP("Idle")
+ .I '$G(HLRESP) S HLERROR="108^No response"
+ ;Close port
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+ Q
+ ;
+DONE(ST,ERR,ERRMSG) ;set status to complete
+ ;ST=status, ERR=error ien, ERRMSG=error msg
+ D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
+ ;
+ ;**109**
+ D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+ ;
+ ;check for more msg.
+ I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
+ Q
+ ;
+CHKMSG(HLI) ;check status of message and update if not cancelled
+ ;input: HLI=new status, HLMSG=ien of msg in 773
+ ;returns 1=msg was updated, 0=msg has been canceled
+ N X
+ ;
+ ;**109**
+ ;F  L +^HLMA(HLMSG,"P"):1 Q:$T  H 1
+ ;
+ ;
+ ; New HL*1.6*77 code starting here...
+ I '$D(^HLMA(HLMSG,"P")) D  Q 0
+ .  S HLERROR="2^Missing status field"
+ .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
+ .;
+ .;**109**
+ . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+ .;L -^HLMA(HLMSG,"P")
+ ;**end 109**
+ ;
+ ; End of HL*1.6*77 modifications
+ ;
+ ;get status, quit if msg was cancelled
+ ;
+ ;**109**
+ ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0
+ S X=+^HLMA(HLMSG,"P") Q:X=3 0
+ ;
+ ;update status if it is different
+ I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
+ ;
+ ;**109**
+ ;L -^HLMA(HLMSG,"P")
+ ;
+ Q 1
+ ;
+WRITE(HLDA) ; write message in HL7 format
+ ;  HLDA       - ien of message in 773
+ ;             - start block $C(11)
+ ;             - end block $C(28)
+ ;             - record separator $C(13)
+ ;Output(s): 1 - Successful
+ ;           -1 - Unsuccessful
+ ;
+ N HLDA2,HLAR,HLI,LINENO,X
+ ;set error trap, used when called from HLTP3
+ ;
+ ; New HL*1.6*77 code starts here...
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+ I $G(^HLMA(HLDA,0))'>0 D  Q -1
+ .  S HLERROR="2^Message Text pointer missing"
+ S HLDA2=+$G(^HLMA(HLDA,0))
+ ; End of HL*1.6*77 modifications...
+ ;
+ Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
+ ; header is in ^HLMA(, message is in ^HL(772,
+ S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
+ U IO
+ D  W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
+ . F  S HLI=$O(@HLAR@(HLI)) Q:'HLI  S X=$G(^(HLI,0)) D
+ .. ;first line, need start block char.
+ .. S:LINENO=1 X=$C(11)_X
+ .. I X]"" W X,!
+ .. ;send CR for blank lines
+ .. I X="" W $C(13)
+ .. S LINENO=LINENO+1
+ ; Sends end block for this message
+ S X=$C(28)_$C(13)
+ U IO W X,!
+ I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage'
+ Q 1
+ ;
+OPEN() ; -- Open TCP/IP device (Client)
+ ;HLPORT=port, defined only if port is open
+ ;HLPORTA=number of attempted opens
+ I $D(HLPORT) S IO=HLPORT D  Q 1
+ . U IO
+ . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
+ N HLDOM,HLI,HLIP,HLPORTA
+ G OPENA^HLCSTCP3
+ ;
+RDERR D RDERR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+ERROR D ERROR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+ ;
+CC(X) ;cleanup and close
+ D MON^HLCSTCP(X)
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+ H 2
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m

-              r613
+              r623
+HLCSTCP3        ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 09/13/2006  15:36
+        ;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122**;OCT 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+OPENA   ;
+        ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA
+        ;
+        I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+        S POP=1
+        ;
+        ; patch HL*1.6*122 start
+        ; variable HLDRETR=re-transmit attemps (#870,200.02)
+        ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()
+        ; defined in HLCSTCP routine
+        ;
+        I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=1
+        I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=5
+        S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR
+        ; patch 133
+        ; I $G(HLDIRECT("OPEN TIMEOUT")) D
+        ; .S HLI=1
+        ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
+        ; E  D
+        ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
+        I $G(HLDIRECT("OPEN TIMEOUT")) D
+        . D MON^HLCSTCP("Open")
+        . D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
+        . ; give site one more chance to override the application setup
+        . I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D
+        .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
+        E  D
+        . N COUNT
+        . ; try to connect HLDRETR times
+        . F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D  Q:('POP)!($$STOP^HLCSTCP)
+        .. D MON^HLCSTCP("Open")
+        .. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT)
+        .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
+        .. ;open error
+        .. I POP D
+        ... D CC^HLCSTCP2("Openfail")
+        ... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8)
+        ... I '$D(^XTMP("HL7-Openfail",$J)) D
+        .... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT
+        .... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT
+        ... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1
+        ... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT
+        ;
+        ;set # of opens back in msg
+        ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
+        I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT")
+        ; patch HL*1.6*122 end
+        ;
+        ;device open
+        I 'POP S HLPORT=IO D  Q $S($G(HLERROR)]"":0,1:1)
+        . N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77
+        . ;if address came from DNS, set back into LL
+        . I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD
+        . ; write and read to check if still open
+        . Q:HLOS'["OpenM"  X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
+        . Q:$P(^HLCS(870,HLDP,400),U,7)'="Y"  ; must want to SAY HELO
+        . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
+        ;openfail-try DNS lookup
+        ;
+        ; patch HL*1.6*122 start
+        ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
+        I '$D(HLDOM) D
+        . S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U)
+        . S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
+        . D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS
+        ;
+        Q:$$STOP^HLCSTCP 0
+        ;HLIP=ip add. from DNS call, get first one and try open again
+        I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
+        ; open error
+        ;cleanup and close
+        ; patch 133
+        I $G(HLDIRECT("OPEN TIMEOUT")) D
+        . D MON^HLCSTCP("Openfail")
+        . I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+        E  D
+        . D CC^HLCSTCP2("Openfail")
+        Q 0
+        ; patch HL*1.6*122 end
+        ;
+        ;
+        ;following code was removed, site's complained of to many alerts
+        ;couldn't open, send 1 alert
+        ;I '$G(HLPORTA) D
+        ;. ;send alert
+        ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+        ;. ;get mailgroup from file 869.3
+        ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
+        ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
+        ;. D SETUP^XQALERT
+        ;open error
+        ;D CC("Openfail") H 3
+        ;Q 0
+        ;
+        ;
+DNS     ;VA domains must have "med" inserted.
+        ;All domains must use port 5000 and are prepended with "HL7"
+        ;non-VA DNS lookups will succeed if site uses port 5000 and
+        ;configure their local DNS with "HL7.yourdomain.com" and entries
+        ;are created in the logical link file and domain file.
+        D MON^HLCSTCP("DNS Lkup")
+        I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
+        I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
+        I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
+        ;
+        ; patch HL*1.6*122 start
+        I $L($G(HLDOM("DNS")),".")>2 D
+        . S HLDOM=HLDOM("DNS")
+        ; patch HL*1.6*122 end
+        ;
+        S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+        K:HLIP="" HLIP
+        Q
+        ;
+HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**76,77,133**;OCT 13, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+ D MON^HLCSTCP("Open")
+ S POP=1
+ I $G(HLDIRECT("OPEN TIMEOUT")) D
+ .S HLI=1
+ .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
+ E  D
+ .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
+ ;set # of opens back in msg
+ I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
+ ;device open
+ I 'POP S HLPORT=IO D  Q $S($G(HLERROR)]"":0,1:1)
+ . N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77
+ . ;if address came from DNS, set back into LL
+ . I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD
+ . ; write and read to check if still open
+ . Q:HLOS'["OpenM"  X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
+ . Q:$P(^HLCS(870,HLDP,400),U,7)'="Y"  ; must want to SAY HELO
+ . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
+ ;openfail-try DNS lookup
+ I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
+ ;HLIP=ip add. from DNS call, get first one and try open again
+ I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
+ ;open error
+ I $G(HLDIRECT("OPEN TIMEOUT")) D
+ .D MON^HLCSTCP("Openfail")
+ .I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+ E  D
+ .D CC^HLCSTCP2("Openfail") H 3
+ Q 0
+ ;
+ ;following code was removed, site's complained of to many alerts
+ ;couldn't open, send 1 alert
+ ;I '$G(HLPORTA) D
+ ;. ;send alert
+ ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+ ;. ;get mailgroup from file 869.3
+ ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
+ ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
+ ;. D SETUP^XQALERT
+ ;open error
+ ;D CC("Openfail") H 3
+ ;Q 0
+ ;
+ ;
+DNS ;VA domains must have "med" inserted.
+ ;All domains must use port 5000 and are prepended with "HL7"
+ ;non-VA DNS lookups will succeed if site uses port 5000 and
+ ;configure their local DNS with "HL7.yourdomain.com" and entries
+ ;are created in the logical link file and domain file.
+ D MON^HLCSTCP("DNS Lkup")
+ I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
+ I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
+ I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
+ S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+ K:HLIP="" HLIP
+ Q
+ ;

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m

-              r613
+              r623
+HLCSTCP4        ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/08  14:20
+        ;;1.6;HEALTH LEVEL SEVEN;**109,122,140**;Oct 13,1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        Q
+        ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
+        ;
+RDERR   ; Error during read process, decrement counter
+        D LLCNT^HLCSTCP(HLDP,4,1)
+ERROR   ; Error trap
+        ; OPEN ERROR-retry.
+        ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
+        ;
+        ;**109**
+        ;I $G(HLMSG) L -^HLMA(HLMSG)
+        ;
+        ; patch HL*1.6*122 start
+        N STOP
+        S STOP=0
+        I $G(HLDP) S STOP=$$STOP^HLCSTCP
+        ; patch HL*1.6*140
+        S $ETRAP="D HALT^ZU" ;RWF
+        S HLTCP("$ZA\8192#2")=""
+        I (^%ZOSF("OS")["OpenM") D
+        . S HLTCP("$ZA")=$ZA
+        . ; For TCP devices $ZA\8192#2: the device is currently in the
+        . ; Connected state talking to a remote host.
+        . S HLTCP("$ZA\8192#2")=$ZA\8192#2
+        ;
+        S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
+        ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
+        I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  G:STOP H2^XUSCLEAN Q
+        . D CC^HLCSTCP2("Op-err")
+        . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
+        . I STOP D  Q
+        .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
+        . I 'STOP D UNWIND^%ZTER
+        ; patch HL*1.6*140 start
+        ; I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
+        I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
+        . ; S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+        . I $G(HLPRIO)="I" D  Q
+        .. S HLERROR="108^Write Error"
+        .. D CC^HLCSTCP2("Wr-err")
+        .. D UNWIND^%ZTER
+        . ;
+        . I STOP D  Q
+        .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
+        . E  D  Q
+        .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q
+        .. E  D  Q
+        ... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
+        ... D UNWIND^%ZTER
+        ;
+        ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
+        ; I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
+        I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
+        . ; S:$G(HLPRIO)="I" HLERROR="108^Read Error"
+        . I $G(HLPRIO)="I" D  Q
+        .. S HLERROR="108^Read Error"
+        .. D CC^HLCSTCP2("Rd-err")
+        .. D UNWIND^%ZTER
+        . ;
+        . I STOP D  Q
+        .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
+        . E  D  Q
+        .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q
+        .. E  D  Q
+        ... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
+        ... D UNWIND^%ZTER
+        ;
+        ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
+        ; S:$G(HLPRIO)="I" HLERROR="9^Error"
+        D ^%ZTER
+        I $G(HLPRIO)="I" D  Q
+        . S HLERROR="9^Error"
+        . D CC^HLCSTCP2("Error")
+        . D UNWIND^%ZTER
+        ;
+        I STOP D  Q
+        . D CC^HLCSTCP2("Shutdown: (with 'Error')")
+        . D H2^XUSCLEAN
+        ;
+        D CC^HLCSTCP2("Error")
+        ; patch HL*1.6*122 end
+        D H2^XUSCLEAN
+        ; patch HL*1.6*140 end
+        Q
+        ;
+PROXY   ; set DUZ for application proxy user
+        ;
+        ; removed the execution: patch 122 TEST v2
+        Q
+        ;
+        ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
+        ;; S DUZ=HLDUZ
+        ;; D DUZ^XUP(DUZ)
+        ;; Q
+        ;
+HLDUZ   ; compare DUZ and set DUZ to application proxy user
+        ;
+        ; removed the execution: patch 122 TEST v2
+        Q
+        ;
+        ;; I '$G(HLDUZ) D PROXY
+        ;
+HLDUZ2  ; compare DUZ and HLDUZ
+        I $G(DUZ)'=HLDUZ D
+        . S DUZ=HLDUZ
+        . D DUZ^XUP(DUZ)
+        Q
+        ;
+CLEANVAR        ; clean variables for server, called from HLCSTCP1
+        ;
+        ; clean variables except Kernel related variables
+        ; protect variables defined in HLCSTCP
+        N HLDP
+        N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
+        N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
+        ;
+        ; protect variables defined in LISTEN^HLCSTCP
+        ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
+        ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+        N HLLSTN
+        ;
+        ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
+        N %
+        ; protect variables defined in this routine HLCSTCP1
+        N $ETRAP,$ESTACK
+        N HLMIEN,HLASTMSG
+        N HLTMBUF
+        N HLDUZ,DUZ
+        ; Kernel variables for single listener
+        N ZISOS,ZRULE
+        ;
+        D KILL^XUSCLEAN
+        Q
+MIEN    ; sets HLIND1=ien in 773^ien in 772 for message
+        N HLMID,X
+        I HLIND1 D
+        . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
+        . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
+        ;msg. id is 10th of MSH & 11th for BSH or FSH
+        S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
+        ;if HLIND1 is set, kill old message, use HLIND1 for new
+        ;message, it means we never got end block for 1st msg.
+        I HLIND1 D  Q
+        . ;get pointer to 772, kill header
+        . ;
+        . ; patch HL*1.6*122: MPI-client/server
+        . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
+        . K ^HLMA(+HLIND1,"MSH")
+        . L -^HLMA(+HLIND1)
+        . ;
+        . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
+        . S X=$$MAID^HLTF(+HLIND1,HLMID)
+        . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+        . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
+        D TCP^HLTF(.HLMID,.X,.HLDT)
+        S HLBUFF("IEN773")=X
+        I 'X D  Q
+        . ;error - record and reset array
+        . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+        . D CLEAN^HLCSTCP1 K HLLSTN
+        . ;error 100=LLP could not en-queue the message, reset array
+        . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
+        ;HLIND1=ien in 773^ien in 772
+        S HLIND1=X_U_+$G(^HLMA(X,0))
+        S HLBUFF("HLIND1")=HLIND1
+        ;save MSH into 773
+        D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+        Q
+        ;
+PMSH(MSH,P)     ;get piece P from MSH array (passed by ref.)
+        N FS,I,L,L1,L2,X,Y
+        S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
+        F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
+        . S:L1=1 L=L+1
+        . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
+        . S L2=Y,Y=L
+        Q X
+        ;
+ERROR1  ;
+        ; moved from ERROR^HLCSTCP1
+        ; Error trap for disconnect error and return back to the read loop.
+        ; patch HL*1.6*122 start
+        ; patch HL*1.6*140
+        ; S $ETRAP="D HALT^ZU" ;RWF
+        S $ETRAP="H 1 D HALT^ZU" ;RWF
+        I (^%ZOSF("OS")["OpenM") D
+        . S HLTCP("$ZA")=$ZA
+        . ; For TCP devices $ZA\8192#2: the device is currently in the
+        . ; Connected state talking to a remote host.
+        . S HLTCP("$ZA\8192#2")=$ZA\8192#2
+        . I HLTCP("$ZA\8192#2")=0 D
+        .. ; decrement counter of multi-listener
+        .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
+        .. ; process terminated
+        .. D H2^XUSCLEAN
+        ; patch HL*1.6*140
+        ;S $ETRAP="D UNWIND^%ZTER" ;RWF
+        ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+        I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
+        . ; if it is not a multi-listener
+        . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
+        . D UNWIND^%ZTER
+        I $$EC^%ZOSV["READ" D  Q
+        . ; if it is not a multi-listener
+        . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
+        . D UNWIND^%ZTER
+        ;
+        ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+        I $$EC^%ZOSV["WRITE" D  Q
+        . ; if it is not a multi-listener
+        . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
+        . D UNWIND^%ZTER
+        ;
+        ; for GT.M
+        I $ECODE["UREAD" D  Q
+        . ; if it is not a multi-listener
+        . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
+        . D UNWIND^%ZTER
+        ;
+        ; S HLCSOUT=1 D ^%ZTER,CC("Error")
+        S HLCSOUT=1
+        D ^%ZTER
+        ; if it is not a multi-listener
+        I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
+        ; patch HL*1.6*122 end
+        ;
+        D UNWIND^%ZTER
+        Q
+        ;
+CLRMCNTR        ;
+        ; clear the counter to set as "0 server" for multi-listener
+        ; HL*1.6*122 start
+        Q:'$G(HLDP)
+        Q:'$D(^HLCS(870,"E","M",HLDP))
+        S $P(^HLCS(870,HLDP,0),"^",4)="MS"
+        S $P(^HLCS(870,HLDP,0),U,5)="0 server"
+        Q
+        ;
+CREATUSR        ;
+        ; patch HL*1.6*122 TEST v2: DUZ code removed
+        ; create application proxy users for listeners and incoming filer
+        ;; N HLTEMP
+        ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
+        Q
+HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006  13:31
+ ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ Q
+ ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
+ ;
+RDERR ; Error during read process, decrement counter
+ D LLCNT^HLCSTCP(HLDP,4,1)
+ERROR ; Error trap
+ ; OPEN ERROR-retry.
+ ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
+ ;
+ ;**109**
+ ;I $G(HLMSG) L -^HLMA(HLMSG)
+ ;
+ S $ETRAP="D UNWIND^%ZTER"
+ ; patch HL*1.6*122
+ S HLTCPERR("$P")=$P
+ S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
+ ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
+ I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
+ . D CC^HLCSTCP2("Op-err")
+ . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
+ . D UNWIND^%ZTER
+ I $$EC^%ZOSV["WRITE" D  Q  ;HL*1.6*77 modifications start here
+ .  D CC^HLCSTCP2("Wr-err")
+ .  S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+ .  D UNWIND^%ZTER ;HL*1.6*77 modifications end here
+ ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
+ I $$EC^%ZOSV["READ" D  Q
+ . D CC^HLCSTCP2("Rd-err")
+ . S:$G(HLPRIO)="I" HLERROR="108^Read Error"
+ . D UNWIND^%ZTER
+ S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
+ S:$G(HLPRIO)="I" HLERROR="9^Error"
+ D UNWIND^%ZTER
+ Q
+ ;
+PROXY ; set DUZ for application proxy user
+ S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
+ S DUZ=HLDUZ
+ D DUZ^XUP(DUZ)
+ Q
+ ;
+HLDUZ ; compare DUZ and set DUZ to application proxy user
+ I '$G(HLDUZ) D PROXY
+ I $G(DUZ)'=HLDUZ D
+ . S DUZ=HLDUZ
+ . D DUZ^XUP(DUZ)
+ Q
+ ;
+CLEANVAR ; clean variables for server, called from HLCSTCP1
+ ;
+ ; clean variables except Kernel related variables
+ ; protect variables defined in HLCSTCP
+ N HLDP
+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
+ N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
+ ;
+ ; protect variables defined in LISTEN^HLCSTCP
+ ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
+ ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+ N HLLSTN
+ ;
+ ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
+ N %
+ ; protect variables defined in this routine HLCSTCP1
+ N $ETRAP,$ESTACK
+ N HLMIEN,HLASTMSG
+ N HLTMBUF
+ N HLDUZ,DUZ
+ ; Kernel variables for single listener
+ N ZISOS,ZRULE
+ ;
+ D KILL^XUSCLEAN
+ Q
+MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+ N HLMID,X
+ I HLIND1 D
+ . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
+ . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
+ ;msg. id is 10th of MSH & 11th for BSH or FSH
+ S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
+ ;if HLIND1 is set, kill old message, use HLIND1 for new
+ ;message, it means we never got end block for 1st msg.
+ I HLIND1 D  Q
+ . ;get pointer to 772, kill header
+ . K ^HLMA(+HLIND1,"MSH")
+ . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
+ . S X=$$MAID^HLTF(+HLIND1,HLMID)
+ . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+ . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
+ D TCP^HLTF(.HLMID,.X,.HLDT)
+ S HLBUFF("IEN773")=X
+ I 'X D  Q
+ . ;error - record and reset array
+ . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+ . D CLEAN^HLCSTCP1 K HLLSTN
+ . ;error 100=LLP Could not Enqueue the Message, reset array
+ . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
+ ;HLIND1=ien in 773^ien in 772
+ S HLIND1=X_U_+$G(^HLMA(X,0))
+ S HLBUFF("HLIND1")=HLIND1
+ ;save MSH into 773
+ D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+ Q
+ ;
+PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+ N FS,I,L,L1,L2,X,Y
+ S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
+ F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
+ . S:L1=1 L=L+1
+ . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
+ . S L2=Y,Y=L
+ Q X
+ ;

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m

-              r613
+              r623
+HLCSTCPA        ;OIFO-O/RJH - (TCP/IP) VMS ;07/26/2007  10:29
+        ;;1.6;HEALTH LEVEL SEVEN;**84,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM,
+        ;    HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port
+        ;    number.
+        ; 2. find the ien of #870(logical link file) for the multi-listener
+        Q
+        ;
+GTMPORT(%)      ; From tcpip ZFOO for GT.M
+        ; %: device^port number
+        N HLPORT
+        S HLPORT=$P($G(%),"^",2)
+        I $G(^%ZOSF("OS"))'["GT.M" D ^%ZTER Q
+        D IEN
+        Q
+        ;
+PORT    ;
+        ; HLPORT: port number of multi-listener
+        ; input of DSM: % = device^port number of multi-listener
+        ; input of Cache: port number of TCPIP
+        ;
+        N HLPORT
+        S HLPORT=0
+        I ^%ZOSF("OS")["OpenM" D
+        . S HLPORT=$ZF("GETSYM","PORT")
+        I ^%ZOSF("OS")["DSM" D
+        . S HLPORT=$P(%,"^",2)
+        ;
+IEN     ;
+        ; HLIEN870: ien in #870 (logical link file)
+        ; HLPRTS: port number in entry to be tested
+        ;
+        N HLIEN870
+        I 'HLPORT D ^%ZTER Q
+        S HLIEN870=0
+        F  S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870  D  Q:(HLPRTS=HLPORT)
+        . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2)
+        I 'HLIEN870 D ^%ZTER Q
+        ;
+        K HLPORT,HLPRTS
+        ; patch 122
+        S U="^"
+        ;
+        ;for Cache/VMS
+        I ^%ZOSF("OS")["OpenM" D  Q
+        . D CACHEVMS(HLIEN870)
+        ;
+        ;for DSM
+        I ^%ZOSF("OS")["DSM" D  Q
+        . S $P(%,"^",2)=HLIEN870   ;set % = device^ien of #870
+        . K HLIEN870
+        . D EN
+        ;
+        ;for GT.M
+        I ^%ZOSF("OS")["GT.M" D  Q
+        . S HLDP=HLIEN870   ;set HLDP = ien of #870
+        . K HLIEN870
+        . D GTMUCX
+        ;
+        D ^%ZTER
+        Q
+GTMUCX  ; GT.M /VMS tcpip
+        ;listener,  % = device^port
+        S U="^",IO=$P(%,U)
+        ; S IO(0)=$P O IO(0) ;Setup null device
+        ; GTM specific code
+        S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+        X "O IO:(RECORDSIZE=512)"
+        D LISTEN^HLCSTCP
+        C IO
+        Q
+        ;
+        ; $ x=f$trnlnm("sys$net")  !This is our MBX device
+        ; $!
+        ; $! for GT.M
+        ; $ assign 'f$trnlnm("SYS$NET")' SYS$NET
+        ; $! Depending on how your command files are set up, you may need to
+        ; $! run the GT.M profile file.
+        ; $ @<user$:[gtmmgr]>gtmprofile.com
+        ; $ forfoo="$" + f$parse("user$:[gtmmgr.r]ZFOO.exe")
+        ; $ PORT=5000
+        ; $ data="''x'^''PORT'"
+        ; $ forfoo GTMPORT^HLCSTCPA("''data'")
+        ;
+CACHEVMS(%)     ;Cache'/VMS tcpip
+        ;listener,  % = HLDP
+        I $G(%)="" D ^%ZTER Q
+        ; patch 133
+        S IO="SYS$NET",U="^",HLDP=%
+        S IO(0)="_NLA0:" O IO(0) ;Setup null device
+        ; **Cache'/VMS specific code**
+        O IO::5 E  D MON^HLCSTCP("Openfail") Q
+        X "U IO:(::""-M"")" ;Packet mode like DSM
+        D LISTEN^HLCSTCP
+        C IO
+        Q
+        ;
+EN      ; DSM/VMS tcpip
+        ;listener,  % = device^HLDP
+        I $G(%)="" D ^%ZTER Q
+        ; patch 122
+        ; S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
+        S U="^",IO=$P(%,U),HLDP=$P(%,U,2)
+        ; patch 133
+        S IO(0)="_NLA0:" O IO(0) ;Setup null device
+        ; **VMS specific code, need to share device**
+        O IO:(TCPDEV):60 E  D MON^HLCSTCP("Openfail") Q
+        ; patch 122
+        D LISTEN^HLCSTCP
+        C IO
+        Q
+HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/10/2003  10:12
+ ;;1.6;HEALTH LEVEL SEVEN;**84**;Oct 13, 1995
+ ;
+ ; 1. port number is input from VMS HLSxxxxDSM.COM or HLSxxxxCACHE.COM
+ ;    file, where xxxx is port number.
+ ; 2. find the ien of #870(logical link file) for the HL7 multi-listener
+ ; 3. call the appropriate entry:
+ ;    for Cache: CACHEVMS^HLCSTCP(ien of #870)
+ ;    for DSM:   EN^HLCSTCP
+ Q
+PORT ;
+ ;HLIEN870: ien in #870 (logical link file)
+ ;HLPORT: port number of multi-listener
+ ;HLPRTS: port number in entry to be tested
+ ;input of DSM: % = device^port number of multi-listener
+ ;input of Cache: port number of TCPIP
+ ;
+ I ^%ZOSF("OS")["OpenM" D
+ . S HLPORT=$ZF("GETSYM","PORT")
+ I ^%ZOSF("OS")["DSM" D
+ . S HLPORT=$P(%,"^",2)
+ I 'HLPORT D ^%ZTER Q
+ S HLIEN870=0
+ F  S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870  D  Q:(HLPRTS=HLPORT)
+ . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2)
+ I 'HLIEN870 D ^%ZTER Q
+ ;
+ K HLPORT,HLPRTS
+ ;
+ ;for Cache/VMS
+ I ^%ZOSF("OS")["OpenM" D  Q
+ .D CACHEVMS^HLCSTCP(HLIEN870)
+ ;
+ ;for DSM
+ I ^%ZOSF("OS")["DSM" D  Q
+ . S $P(%,"^",2)=HLIEN870   ;set % = device^ien of #870
+ . K HLIEN870
+ . D EN^HLCSTCP
+ ;
+ D ^%ZTER
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m

-              r613
+              r623
+HLCSTERM        ;ALB/RJS - SET UP VIDEO ATTRIBUTES ;06/27/2007  17:04
+        ;;1.6;HEALTH LEVEL SEVEN;**40,49,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+TERM    ; -- set up term characteristics
+        N X
+        I '$D(IOST(0)) D HOME^%ZIS
+        S X=$$IO D ENDR^%ZISS
+        S (HLCON,HLCOFF)=""
+        I $E(IOST,1,4)="C-VT" S HLCOFF=$C(13,27,91)_"?25l"_$C(13),HLCON=$C(27,91)_"?25h"
+        Q
+HEADER  ;
+        ;Write out Header
+        ;
+        N HLMIDDLE,HLLNGTH,HLJUST
+        W @IOF,!
+        S HLPARAM=$$PARAM^HLCS2
+        S HLSITE=$P(HLPARAM,U,5),HLPROD=$P(HLPARAM,U,3)
+        S HLHDR="SYSTEM LINK MONITOR for "_HLSITE_" ("_HLPROD_" System)"
+        S HLMIDDLE=IOM\2,HLLNGTH=$L(HLHDR)\2,HLJUST=HLMIDDLE-HLLNGTH
+        D WDATA^HLCSMON1(HLJUST,1,IORVON,IORVOFF,HLHDR,75)
+        D WDATA^HLCSMON1(5,4,IOUON,IOUOFF,"NODE",8)
+        D WDATA^HLCSMON1(16,3,"","","MESSAGES",8),WDATA^HLCSMON1(16,4,IOUON,IOUOFF,"RECEIVED",8)
+        D WDATA^HLCSMON1(26,3,"","","MESSAGES",8),WDATA^HLCSMON1(26,4,IOUON,IOUOFF,"PROCESSED",9)
+        D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8)
+        D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT    ",8)
+        ; patch HL*1.6*122
+        ; D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
+        D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",6)
+        ;
+        D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8)
+        Q
+KVAR    ;
+        D KILL^%ZISS
+        K HLCON,HLCOFF
+        Q
+IO()    ; -- what device params
+        Q "IOELALL;IOELEOL;IORESET;IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF;IOBOFF;IOBON"
+        Q
+HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES - 8/1/94 ;07/28/98  09:43
+ ;;1.6;HEALTH LEVEL SEVEN;**40,49**;Oct 13, 1995
+TERM ; -- set up term characteristics
+ N X
+ I '$D(IOST(0)) D HOME^%ZIS
+ S X=$$IO D ENDR^%ZISS
+ S (HLCON,HLCOFF)=""
+ I $E(IOST,1,4)="C-VT" S HLCOFF=$C(13,27,91)_"?25l"_$C(13),HLCON=$C(27,91)_"?25h"
+ Q
+HEADER ;
+ ;Write out Header
+ ;
+ N HLMIDDLE,HLLNGTH,HLJUST
+ W @IOF,!
+ S HLPARAM=$$PARAM^HLCS2
+ S HLSITE=$P(HLPARAM,U,5),HLPROD=$P(HLPARAM,U,3)
+ S HLHDR="SYSTEM LINK MONITOR for "_HLSITE_" ("_HLPROD_" System)"
+ S HLMIDDLE=IOM\2,HLLNGTH=$L(HLHDR)\2,HLJUST=HLMIDDLE-HLLNGTH
+ D WDATA^HLCSMON1(HLJUST,1,IORVON,IORVOFF,HLHDR,75)
+ D WDATA^HLCSMON1(5,4,IOUON,IOUOFF,"NODE",8)
+ D WDATA^HLCSMON1(16,3,"","","MESSAGES",8),WDATA^HLCSMON1(16,4,IOUON,IOUOFF,"RECEIVED",8)
+ D WDATA^HLCSMON1(26,3,"","","MESSAGES",8),WDATA^HLCSMON1(26,4,IOUON,IOUOFF,"PROCESSED",9)
+ D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8)
+ D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT    ",8)
+ D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
+ D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8)
+ Q
+KVAR ;
+ D KILL^%ZISS
+ K HLCON,HLCOFF
+ Q
+IO() ; -- what device params
+ Q "IOELALL;IOELEOL;IORESET;IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF;IOBOFF;IOBON"
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m

-              r613
+              r623
+HLDIE   ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
+        ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        Q
+        ;
+        ; Rules: if any of these rules is broken, FILE^DIE is called instead
+        ;
+        ;         * Can't edit files other than 772,773
+        ;         * Don't pass IENS value with multiples IENs.  You can only
+        ;             edit one IEN at a time!
+        ;         * Only flag "S" is honored.  Flag "K" is ignored. Other
+        ;             flags result in FILE^DIE being called.
+        ;         * Can't edit ^HLMA(IEN,90) data.
+        ;         * Can't edit ^HLMA(IEN,91) data.
+        ;         * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
+        ;         * No checking of data performed!  (Data format MUST be OK.)
+        ;         * No locking of records in files 772 or 773. (Locks on queues.)
+        ;
+FILE(FLAGS,ROOT,ERR,SUB,RTN)    ; FILE^DIE functional equivalent...
+        ; This call has similar parameters to FILE^DIE, but changes data
+        ; using hard sets.  The first two parameters of this API are the
+        ; same as FILE^DIE.  So, if any file other than 772 or 773 is being
+        ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
+        ; FILE^DIE and quits.  If file 772 or 773 is being edited, the hard
+        ; set code in HLDIE772 and HLDIE773 is called.
+        ;
+        N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
+        ;
+        S DT=$$NOW^XLFDT\1
+        ;
+        D BEGIN ; Debug call at beginning or process
+        ;
+        ; Check FILE, IEN, FIELDs passed, etc...
+        I '$$CHECKS D  QUIT  ;->
+        .
+        .  S HLEDITOR="FILE^DIE"
+        .
+        .  ; Call FILEMAN...
+        .  D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
+        .
+        .  ; Debug call made even with Fileman...
+        .  D END
+        ;
+        S HLEDITOR="FILE^HLDIE"
+        ;
+        ; If this point is reached, file 772 or 773 is being edited, data
+        ; in ROOT() has been checked, and data is being hard set...
+        ;
+        ;
+        ; Make sure ERR is defined...
+        I $G(ERR)']"" N HLERR S ERR="HLERR"
+        ;
+        ; All editing occurs in this call...
+        D EDITALL(.ROOT,FILE,IEN)
+        ;
+        ; Store debug data if XTMP debug string set...
+        D END
+        ;
+        ;check if ROOT needs to be retained
+        I FLAGS'["S" K @ROOT,FLAGS
+        ;
+        Q
+        ;
+EDITALL(ROOT,FILE,IEN)  ; Edit 772 or 773 by direct sets...
+        ;
+        ; FILE,IEN -- optional (parsed from ROOT())
+        ;
+        N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
+        ;
+        S GBL=$$GBL(FILE,+IEN)
+        ;
+        ;check if .01="@" for deletion of record...
+        I $G(@ROOT@(FILE,IEN,.01))="@" D  Q
+        .I FILE=773 D DEL773^HLUOPT3(+IEN) Q
+        .I FILE=772 D DEL772^HLUOPT3(+IEN)
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        ; If no data in record passed in, log an error and quit...
+        ; I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
+        N HLDGBL
+        F  L +@GBL:10 Q:$T  H 1
+        S HLDGBL=$D(@GBL)
+        L -@GBL
+        I 'HLDGBL D  Q  ; Remember.  GBL contains IEN...
+        .  S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
+        .  S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
+        ;
+        ;
+        ; What routine holds the file-specific field/xref set code?
+        S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
+        ;
+        ; Load NODEs...
+        D GETNODES(FILE,+IEN,.NODE)
+        ;
+        ; When a field is edited, the NODE(1) is changed
+        ;
+        ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
+        S FIELD=0
+        F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0  D
+        .  ; VALUE = value passed in by process that is to be stored in file
+        .  S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
+        .
+        .  ; If field should be deleted, VALUE will equal @...
+        .  I VALUE="@" S VALUE=""
+        .
+        .  ; Get and check tag...
+        .  S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
+        .  S TAG(1)=$T(@TAG) I TAG(1)']"" D  QUIT  ;->
+        .  .  S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
+        .  .  S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+        .  .  S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
+        .
+        .  ; Call the subroutine below that is for the specific field...
+        .  ; (No editing of xrefs or global data occurs in these calls.)
+        .  D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
+        ;
+        ; If no data actually changed, quit...
+        QUIT:'$D(NODE("CHG"))  ;->
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        I FILE=773 D
+        . F  L +^HLMA(IEN):10 Q:$T  H 1
+        E  D
+        . F  L +^HL(772,IEN):10 Q:$T  H 1
+        ;
+        ; Store changes in the global now...
+        D STORE(FILE,IEN,.NODE)
+        ;
+        ; Set xrefs to correspond to the just-stored data...
+        S XRF=""
+        F  S XRF=$O(XRF(XRF)) Q:XRF']""  D
+        .  D @("XRF"_XRF_U_ROUTINE)
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        I FILE=773 L -^HLMA(IEN)
+        E  L -^HL(772,IEN)
+        ;
+        Q
+        ;
+GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
+        ; NODE(node,0), and load node to be changed in NODE(node,1).
+        ; GBL -- req
+        F NODE=0,1,2,"P","S" D
+        .  ; After setting, NODE(NODE,0) will equal each other.
+        .  ; However, after each edited field is processed, the pieces of
+        .  ; data in NODE(NODE,1) will be changed.  The pre and post nodes
+        .  ; then are of comparison value.
+        .  S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
+        .  S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
+        Q
+        ;
+STORE(FILE,IEN,NODE)    ; Store changes in file...
+        N DATA,ND
+        ;
+        ; Loop thru change nodes, get changed data, and store it...
+        S ND=""
+        F  S ND=$O(NODE("CHG",ND)) Q:ND']""  D
+        .  S DATA=$G(NODE(ND,1))
+        .  ; Even if no data no node, store it.  (Will be removed by purge.)
+        .  I FILE=772 S ^HL(772,+IEN,ND)=DATA
+        .  I FILE=773 S ^HLMA(+IEN,ND)=DATA
+        ;
+        QUIT
+        ;
+GBL(FILE,IEN)   QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
+        ;
+CHKFLD(FILE,FIELD)      ; Does passed-in field exist?
+        ; Returns -- @ERR@(...) ->
+        ;
+        ; Quit if field exists...
+        QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
+        ;
+        ; Field doesn't exist.  Log error...
+        S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
+        S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+        S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
+        ;
+        Q ""
+        ;
+ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
+        N NO
+        S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
+        S @ERR@("DIERR",NO)=NUM
+        S @ERR@("DIERR",NO,"PARAM",0)=PNO
+        S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
+        S @ERR@("DIERR",NO,"TEXT",1)=TXT
+        S @ERR@("DIERR","E",NUM,NO)=""
+        Q NO
+        ;
+GENLERR(ETXT)   ; Store GENERAL (and fatal) error...
+        ; ERR -- req
+        N NO
+        S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
+        S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
+        Q
+        ;
+CHECKS()        ; Check ROOT() for file and validity of data...
+        ; FLAGS, ROOT() -- req --> FILE,IEN
+        N I,OK,FIELD
+        ;
+        ;check the file & ien
+        S FILE=$O(@ROOT@(0))
+        I FILE'=772,FILE'=773 D  QUIT "" ;->
+        .  S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
+        ;
+        ; ;shouldn't be more than 1 file!
+        QUIT:$O(@ROOT@(FILE)) "" ;->
+        ;
+        ;check the ien structure, and that only ien passed...
+        S IEN=$O(@ROOT@(FILE,0))
+        ; Structure check...
+        QUIT:$P(IEN,",")'=+IEN_"," "" ;->
+        ; Is it numeric?
+        QUIT:'(+IEN) "" ;->
+        ; Has more than one IEN been passed?
+        QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
+        ;
+        ;check the flags.  Only K and S flags allowed...
+        I $L(FLAGS) D  QUIT:'OK "" ;->
+        .  S OK=1
+        .  F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
+        ;
+        ; Check for existence of FIELD in FILE's DD & if an excluded field.
+        ; (See rules for fields which cannot be updated by FILE^HLDIE.)
+        S FIELD=0,OK=1
+        F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD=""  D  Q:'OK
+        .  I '$$CHKFLD(FILE,FIELD) S OK=0 Q
+        .  I FILE=773,FIELD\1=90 S OK=0 Q
+        .  I FILE=773,FIELD\1=91 S OK=0 Q
+        .  I FILE=772,FIELD=200 S OK=0 Q
+        ;
+        ; If not OK to use FILE^HLDIE, skip any further testing...
+        QUIT:'OK "" ;->
+        ;
+        ;                    *** WARNING ***
+        ; The following check **MUST** be removed after FILE^HLDIE is working.
+        ;
+        ; Final check for whether FILE^HLDIE should be used...
+        I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
+        ; If this node exists and follows null, FILE^DIE will be used.
+        ; Otherwise, execution defaults to using FILE^HLDIE.
+        ;
+        Q OK
+        ;
+BEGIN   ; Always call here before any ^HLDIE or ^DIE calls...
+        D DEBUG(1)
+        Q
+        ;
+END     ; Always call here after all ^HLDIE or ^DIE actions...
+        D DEBUG(2)
+        Q
+        ;
+DEBUG(LOC)      ; Debug presets and setup...
+        ; Most variables created here should be left around.  These variables
+        ; are newed above.
+        N STORE
+        ;
+        S RTN=$G(RTN),SUB=$G(SUB)
+        ;
+        ; First-time (beginning) call setups...
+        I LOC=1 D
+        .  S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
+        .  S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
+        .  S XECMCODE=$P(DEBUG,U,3)
+        ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
+        ; FILE^HLDIE.  So, set up variables only once, at beginning...
+        ;
+        ; Setup that is individual to each (1 or 2) call...
+        S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
+        ; Some, All, or no data stored?
+        ;
+        ; If no STORE instructions, and no M code to specify STORE, quit...
+        QUIT:'STORE&($G(XECMCODE)'=1)  ;->
+        ;
+        ; Call DEBUG to STORE data...
+        D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
+        ;
+        Q
+        ;
+EOR     ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17
+HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995
+ ;
+ ; Rules: if any of these rules is broken, FILE^DIE is called instead
+ ;
+ ;         * Can't edit files other than 772,773
+ ;         * Don't pass IENS value with multiples IENs.  You can only
+ ;             edit one IEN at a time!
+ ;         * Only flag "S" is honored.  Flag "K" is ignored. Other
+ ;             flags result in FILE^DIE being called.
+ ;         * Can't edit ^HLMA(IEN,90) data.
+ ;         * Can't edit ^HLMA(IEN,91) data.
+ ;         * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
+ ;         * No checking of data performed!  (Data format MUST be OK.)
+ ;         * No locking of records in files 772 or 773. (Locks on queues.)
+ ;
+FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
+ ; This call has similar parameters to FILE^DIE, but changes data
+ ; using hard sets.  The first two parameters of this API are the
+ ; same as FILE^DIE.  So, if any file other than 772 or 773 is being
+ ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
+ ; FILE^DIE and quits.  If file 772 or 773 is being edited, the hard
+ ; set code in HLDIE772 and HLDIE773 is called.
+ ;
+ N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
+ ;
+ S DT=$$NOW^XLFDT\1
+ ;
+ D BEGIN ; Debug call at beginning or process
+ ;
+ ; Check FILE, IEN, FIELDs passed, etc...
+ I '$$CHECKS D  QUIT  ;->
+ .
+ .  S HLEDITOR="FILE^DIE"
+ .
+ .  ; Call FILEMAN...
+ .  D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
+ .
+ .  ; Debug call made even with Fileman...
+ .  D END
+ ;
+ S HLEDITOR="FILE^HLDIE"
+ ;
+ ; If this point is reached, file 772 or 773 is being edited, data
+ ; in ROOT() has been checked, and data is being hard set...
+ ;
+ ;
+ ; Make sure ERR is defined...
+ I $G(ERR)']"" N HLERR S ERR="HLERR"
+ ;
+ ; All editing occurs in this call...
+ D EDITALL(.ROOT,FILE,IEN)
+ ;
+ ; Store debug data if XTMP debug string set...
+ D END
+ ;
+ ;check if ROOT needs to be retained
+ I FLAGS'["S" K @ROOT,FLAGS
+ ;
+ Q
+ ;
+EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
+ ;
+ ; FILE,IEN -- optional (parsed from ROOT())
+ ;
+ N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
+ ;
+ S GBL=$$GBL(FILE,+IEN)
+ ;
+ ;check if .01="@" for deletion of record...
+ I $G(@ROOT@(FILE,IEN,.01))="@" D  Q
+ .I FILE=773 D DEL773^HLUOPT3(+IEN) Q
+ .I FILE=772 D DEL772^HLUOPT3(+IEN)
+ ;
+ ; If no data in record passed in, log an error and quit...
+ I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
+ .  S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
+ .  S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
+ ;
+ ;
+ ; What routine holds the file-specific field/xref set code?
+ S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
+ ;
+ ; Load NODEs...
+ D GETNODES(FILE,+IEN,.NODE)
+ ;
+ ; When a field is edited, the NODE(1) is changed
+ ;
+ ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
+ S FIELD=0
+ F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0  D
+ .  ; VALUE = value passed in by process that is to be stored in file
+ .  S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
+ .
+ .  ; If field should be deleted, VALUE will equal @...
+ .  I VALUE="@" S VALUE=""
+ .
+ .  ; Get and check tag...
+ .  S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
+ .  S TAG(1)=$T(@TAG) I TAG(1)']"" D  QUIT  ;->
+ .  .  S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
+ .  .  S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+ .  .  S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
+ .
+ .  ; Call the subroutine below that is for the specific field...
+ .  ; (No editing of xrefs or global data occurs in these calls.)
+ .  D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
+ ;
+ ; If no data actually changed, quit...
+ QUIT:'$D(NODE("CHG"))  ;->
+ ;
+ ; Store changes in the global now...
+ D STORE(FILE,IEN,.NODE)
+ ;
+ ; Set xrefs to correspond to the just-stored data...
+ S XRF=""
+ F  S XRF=$O(XRF(XRF)) Q:XRF']""  D
+ .  D @("XRF"_XRF_U_ROUTINE)
+ ;
+ Q
+ ;
+GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
+ ; NODE(node,0), and load node to be changed in NODE(node,1).
+ ; GBL -- req
+ F NODE=0,1,2,"P","S" D
+ .  ; After setting, NODE(NODE,0) will equal each other.
+ .  ; However, after each edited field is processed, the pieces of
+ .  ; data in NODE(NODE,1) will be changed.  The pre and post nodes
+ .  ; then are of comparison value.
+ .  S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
+ .  S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
+ Q
+ ;
+STORE(FILE,IEN,NODE) ; Store changes in file...
+ N DATA,ND
+ ;
+ ; Loop thru change nodes, get changed data, and store it...
+ S ND=""
+ F  S ND=$O(NODE("CHG",ND)) Q:ND']""  D
+ .  S DATA=$G(NODE(ND,1))
+ .  ; Even if no data no node, store it.  (Will be removed by purge.)
+ .  I FILE=772 S ^HL(772,+IEN,ND)=DATA
+ .  I FILE=773 S ^HLMA(+IEN,ND)=DATA
+ ;
+ QUIT
+ ;
+GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
+ ;
+CHKFLD(FILE,FIELD) ; Does passed-in field exist?
+ ; Returns -- @ERR@(...) ->
+ ;
+ ; Quit if field exists...
+ QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
+ ;
+ ; Field doesn't exist.  Log error...
+ S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
+ S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+ S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
+ ;
+ Q ""
+ ;
+ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
+ N NO
+ S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
+ S @ERR@("DIERR",NO)=NUM
+ S @ERR@("DIERR",NO,"PARAM",0)=PNO
+ S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
+ S @ERR@("DIERR",NO,"TEXT",1)=TXT
+ S @ERR@("DIERR","E",NUM,NO)=""
+ Q NO
+ ;
+GENLERR(ETXT) ; Store GENERAL (and fatal) error...
+ ; ERR -- req
+ N NO
+ S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
+ S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
+ Q
+ ;
+CHECKS() ; Check ROOT() for file and validity of data...
+ ; FLAGS, ROOT() -- req --> FILE,IEN
+ N I,OK,FIELD
+ ;
+ ;check the file & ien
+ S FILE=$O(@ROOT@(0))
+ I FILE'=772,FILE'=773 D  QUIT "" ;->
+ .  S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
+ ;
+ ; ;shouldn't be more than 1 file!
+ QUIT:$O(@ROOT@(FILE)) "" ;->
+ ;
+ ;check the ien structure, and that only ien passed...
+ S IEN=$O(@ROOT@(FILE,0))
+ ; Structure check...
+ QUIT:$P(IEN,",")'=+IEN_"," "" ;->
+ ; Is it numeric?
+ QUIT:'(+IEN) "" ;->
+ ; Has more than one IEN been passed?
+ QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
+ ;
+ ;check the flags.  Only K and S flags allowed...
+ I $L(FLAGS) D  QUIT:'OK "" ;->
+ .  S OK=1
+ .  F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
+ ;
+ ; Check for existence of FIELD in FILE's DD & if an excluded field.
+ ; (See rules for fields which cannot be updated by FILE^HLDIE.)
+ S FIELD=0,OK=1
+ F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD=""  D  Q:'OK
+ .  I '$$CHKFLD(FILE,FIELD) S OK=0 Q
+ .  I FILE=773,FIELD\1=90 S OK=0 Q
+ .  I FILE=773,FIELD\1=91 S OK=0 Q
+ .  I FILE=772,FIELD=200 S OK=0 Q
+ ;
+ ; If not OK to use FILE^HLDIE, skip any further testing...
+ QUIT:'OK "" ;->
+ ;
+ ;                    *** WARNING ***
+ ; The following check **MUST** be removed after FILE^HLDIE is working.
+ ;
+ ; Final check for whether FILE^HLDIE should be used...
+ I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
+ ; If this node exists and follows null, FILE^DIE will be used.
+ ; Otherwise, execution defaults to using FILE^HLDIE.
+ ;
+ Q OK
+ ;
+BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
+ D DEBUG(1)
+ Q
+ ;
+END ; Always call here after all ^HLDIE or ^DIE actions...
+ D DEBUG(2)
+ Q
+ ;
+DEBUG(LOC) ; Debug presets and setup...
+ ; Most variables created here should be left around.  These variables
+ ; are newed above.
+ N STORE
+ ;
+ S RTN=$G(RTN),SUB=$G(SUB)
+ ;
+ ; First-time (beginning) call setups...
+ I LOC=1 D
+ .  S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
+ .  S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
+ .  S XECMCODE=$P(DEBUG,U,3)
+ ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
+ ; FILE^HLDIE.  So, set up variables only once, at beginning...
+ ;
+ ; Setup that is individual to each (1 or 2) call...
+ S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
+ ; Some, All, or no data stored?
+ ;
+ ; If no STORE instructions, and no M code to specify STORE, quit...
+ QUIT:'STORE&($G(XECMCODE)'=1)  ;->
+ ;
+ ; Call DEBUG to STORE data...
+ D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
+ ;
+ Q
+ ;
+EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m

-              r613
+              r623
+HLFNC   ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages  ;03/26/2008  11:34
+        ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+HLNAME(X,HLECDE)        ;Convert a name in DHCP format to HL7 format
+        ; INPUT: X - Name in DHCP format
+        ;        Optional - HLECDE - HL7 encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter than HLECH
+        ;must be define.
+        ;
+        Q:'$D(X) ""  Q:X="" ""
+        I '$D(HLECH),'$D(HLECDE) Q ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        I '$D(HLECH) Q ""
+        N %,X1,X2,Y
+        S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']""  S Y=Y_$E(HLECH)_$P(X1," ",%)
+        Q Y
+        ;
+FMNAME(X,HLECDE)        ;Convert a name in HL7 format to DHCP format
+        ; INPUT: X - Name in HL7 format
+        ;        Optional - HLECDE - HL7 encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter than HLECH
+        ;must be define.
+        ;
+        Q:'$D(X) ""  Q:X="" ""
+        I '$D(HLECH),'$D(HLECDE) Q ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        I '$D(HLECH) Q ""
+        N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D
+        .I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D
+        ..;Only last name,first name.
+        ..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q
+        ..S Y=Y_" "_$P(X,$E(HLECH),%)
+        Q Y
+        ;
+HLDATE(X,Y)     ;Convert date, date/time or time only in FM format to HL7 format
+        ;Optional Variables:
+        ;Y = The type of format to be returned if you want to force return of a
+        ;    specific format.  Y must be equal to one of the following:
+        ;    DT - Date only
+        ;    TM - Time only
+        ;    TS - Date and time
+        I X="" Q ""
+        S Y=$G(Y)
+        N %,Z
+        I $L(X)<7 D  Q % ;Time input
+        . S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0
+        . Q
+        I Y="TM" D  Q % ;Only time
+        . S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0
+        . Q
+        S %=$$FMTHL7^XLFDT(X)
+        Q $S(Y="DT":$E(%,1,8),1:%)
+        ;
+FMDATE(X)       ; Convert a date, date/time or time only in HL7 format to FM format
+        I X="" Q ""
+        N %
+        S %=$P($TR(X,"+-","^"),"^")
+        I $L(X)<7 Q %
+        Q $$HL7TFM^XLFDT(X)
+        ;
+M10(X,HLECDE)   ; M10  check digit scheme
+        ; INPUT : X - ID number
+        ;        Optional HLECDE - Encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter then HLECH
+        ;must be defined.
+        ;Return X if encoding character is not defined
+        ;Return X with encoding characters concatenated if X is alphanumeric
+        ;
+        N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT
+        Q:'$D(X) ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        ;Return X if encoding character is not defined
+        I '$D(HLECH) Q X
+        ;Return X with encoding characters concatenated if X is alphanumeric
+        I '(X?1.N) Q X_$E(HLECH)_$E(HLECH)
+        ;
+        S HLX1=+X
+        S HLODD=""
+        F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT)
+        S HLODD=HLODD*2
+        S HLEVEN=""
+        F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT)
+        S HLX1=HLEVEN_HLODD
+        S HLDIGIT=0
+        F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT)
+        S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10
+        Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10"
+        ;
+M11(X,HLECDE)   ; M11 check digit scheme
+        ; INPUT : X - ID number
+        ;        Optional HLECDE - Encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter then HLECH
+        ;must be defined.
+        ;Return X if encoding character is not defined
+        ;Return X with encoding characters concatenated if X is alphanumeric
+        ;
+        N HLX1,HLCNT,HLWT,HLDIGIT
+        Q:'$D(X) ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        ;Return X if encoding character is not defined
+        I '$D(HLECH) Q X
+        ;Return X with encoding characters concatenated if X is alphanumeric
+        I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH)
+        ;
+        S HLX1=+X
+        S HLDIGIT=0,HLWT=2
+        F HLCNT=$L(HLX1):-1:1 D
+        . I HLWT>7 S HLWT=2
+        . S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT)
+        . S HLWT=HLWT+1
+        S HLDIGIT=HLDIGIT#11
+        I HLDIGIT=0 S HLDIGIT=1
+        S HLDIGIT=(11-HLDIGIT)#10
+        Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11"
+        ;
+OLDM10(X,HLECDE)        ;Calculate M10 checksum
+        ; INPUT : X - String to calc checksum
+        ;        Optional HLECDE - Encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter than HLECH
+        ;must be define.
+        ;
+        Q:'$D(X) ""
+        I '$D(HLECH),'$D(HLECDE) Q ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        I '$D(HLECH) Q ""
+        N %,Y
+        S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
+        Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10"
+        ;
+OLDM11(X,HLECDE)        ;Calculate M11 checksum
+        ; INPUT : X - String to calc checksum
+        ;        Optional HLECDE - Encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter than HLECH
+        ;must be define.
+        ;
+        Q:'$D(X) ""
+        I '$D(HLECH),'$D(HLECDE) Q ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        I '$D(HLECH) Q ""
+        N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
+        Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11"
+UPPER(X)        ;Convert lowercase letters to uppercase
+        Q:'$D(X) ""
+        Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+HLPHONE(X,B,C)  ;Convert DHCP Phone Number to HL7 Format
+        ;Required parameters:
+        ;X = Seven digit phone number at a minimum.  Optionally, in addition,
+        ;    a three digit area code, two digit country code and other
+        ;    formatting characters (e.g., dashes)
+        ;Optional Variables:
+        ;B = Beeper number
+        ;C = Comments
+        Q:'$D(X) ""  Q:$L(X)<7 ""
+        N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
+        ;
+        ; patch HL*1.6*141 start
+        ; S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
+        N CH
+        S Y=""
+        F I=1:1:$L(X) D
+        . S CH=$E(X,I)
+        . ; Next line modified by RBN
+        . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
+        . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"")
+        . I "Xx"[CH S Z=""
+        ;
+        ; the number, following "X" character, should be greater than 0
+        I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X")
+        ; patch HL*1.6*141 end
+        ;
+        I $L(Y)<7 Q ""
+        S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
+        I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8)
+        I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11)
+        I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40)
+        I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40)
+        I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40)
+        Q ""
+HLADDR(AD,GL,HLECDE)    ;Convert DHCP address fields to HL7 address format
+        ;Required parameters:
+        ;AD = One to four street address lines separated by uparrows (^).
+        ;GL = Three to four geographic location components separated by
+        ;     uparrows (^).  City^State or Province^Zip Code^Country Code.
+        ;     If the fourth component is not defined, it will be set to 'USA'.
+        ;     The second component must be null or an IEN in the
+        ;     State file (#5).  The third component must be null or pattern
+        ;     match 5N, 9N or 5N1"-"4N.
+        ;
+        ;        Optional HLECDE - Encoding chars
+        ;**** NOTE: ****
+        ;If this function is called without HLECDE as parameter than HLECH
+        ;must be define.
+        ;
+        ;
+        ;A string will be returned with six components separated by the HL7
+        ;component separator.  The length of the string (including separators)
+        ;may exceed 106 characters.
+        ;
+        Q:'$D(AD) ""  Q:'$D(GL) ""
+        I '$D(HLECH),'$D(HLECDE) Q ""
+        I $D(HLECDE) N HLECH S HLECH=HLECDE
+        I '$D(HLECH) Q ""
+        I $D(XRTL) D T0^%ZOSV
+        N I,X,Y
+        I $P(GL,"^",4)="" S $P(GL,"^",4)="USA"
+        I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"")
+        S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"")
+        S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4)
+        S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3)
+        I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1))
+        I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV
+        I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y
+        I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y
+        I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y
+        I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y
+HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;08/03/2000  15:45
+ ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66**;Oct 13, 1995
+HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
+ ; INPUT: X - Name in DHCP format
+ ;        Optional - HLECDE - HL7 encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter than HLECH
+ ;must be define.
+ ;
+ Q:'$D(X) ""  Q:X="" ""
+ I '$D(HLECH),'$D(HLECDE) Q ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ I '$D(HLECH) Q ""
+ N %,X1,X2,Y
+ S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']""  S Y=Y_$E(HLECH)_$P(X1," ",%)
+ Q Y
+ ;
+FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format
+ ; INPUT: X - Name in HL7 format
+ ;        Optional - HLECDE - HL7 encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter than HLECH
+ ;must be define.
+ ;
+ Q:'$D(X) ""  Q:X="" ""
+ I '$D(HLECH),'$D(HLECDE) Q ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ I '$D(HLECH) Q ""
+ N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D
+ .I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D
+ ..;Only last name,first name.
+ ..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q
+ ..S Y=Y_" "_$P(X,$E(HLECH),%)
+ Q Y
+ ;
+HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format
+ ;Optional Variables:
+ ;Y = The type of format to be returned if you want to force return of a
+ ;    specific format.  Y must be equal to one of the following:
+ ;    DT - Date only
+ ;    TM - Time only
+ ;    TS - Date and time
+ I X="" Q ""
+ S Y=$G(Y)
+ N %,Z
+ I $L(X)<7 D  Q % ;Time input
+ . S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0
+ . Q
+ I Y="TM" D  Q % ;Only time
+ . S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0
+ . Q
+ S %=$$FMTHL7^XLFDT(X)
+ Q $S(Y="DT":$E(%,1,8),1:%)
+ ;
+FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format
+ I X="" Q ""
+ N %
+ S %=$P($TR(X,"+-","^"),"^")
+ I $L(X)<7 Q %
+ Q $$HL7TFM^XLFDT(X)
+ ;
+M10(X,HLECDE) ; M10  check digit scheme
+ ; INPUT : X - ID number
+ ;        Optional HLECDE - Encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter then HLECH
+ ;must be defined.
+ ;Return X if encoding character is not defined
+ ;Return X with encoding characters concatenated if X is alphanumeric
+ ;
+ N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT
+ Q:'$D(X) ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ ;Return X if encoding character is not defined
+ I '$D(HLECH) Q X
+ ;Return X with encoding characters concatenated if X is alphanumeric
+ I '(X?1.N) Q X_$E(HLECH)_$E(HLECH)
+ ;
+ S HLX1=+X
+ S HLODD=""
+ F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT)
+ S HLODD=HLODD*2
+ S HLEVEN=""
+ F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT)
+ S HLX1=HLEVEN_HLODD
+ S HLDIGIT=0
+ F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT)
+ S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10
+ Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10"
+ ;
+M11(X,HLECDE) ; M11 check digit scheme
+ ; INPUT : X - ID number
+ ;        Optional HLECDE - Encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter then HLECH
+ ;must be defined.
+ ;Return X if encoding character is not defined
+ ;Return X with encoding characters concatenated if X is alphanumeric
+ ;
+ N HLX1,HLCNT,HLWT,HLDIGIT
+ Q:'$D(X) ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ ;Return X if encoding character is not defined
+ I '$D(HLECH) Q X
+ ;Return X with encoding characters concatenated if X is alphanumeric
+ I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH)
+ ;
+ S HLX1=+X
+ S HLDIGIT=0,HLWT=2
+ F HLCNT=$L(HLX1):-1:1 D
+ . I HLWT>7 S HLWT=2
+ . S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT)
+ . S HLWT=HLWT+1
+ S HLDIGIT=HLDIGIT#11
+ I HLDIGIT=0 S HLDIGIT=1
+ S HLDIGIT=(11-HLDIGIT)#10
+ Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11"
+ ;
+OLDM10(X,HLECDE) ;Calculate M10 checksum
+ ; INPUT : X - String to calc checksum
+ ;        Optional HLECDE - Encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter than HLECH
+ ;must be define.
+ ;
+ Q:'$D(X) ""
+ I '$D(HLECH),'$D(HLECDE) Q ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ I '$D(HLECH) Q ""
+ N %,Y
+ S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
+ Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10"
+ ;
+OLDM11(X,HLECDE) ;Calculate M11 checksum
+ ; INPUT : X - String to calc checksum
+ ;        Optional HLECDE - Encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter than HLECH
+ ;must be define.
+ ;
+ Q:'$D(X) ""
+ I '$D(HLECH),'$D(HLECDE) Q ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ I '$D(HLECH) Q ""
+ N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
+ Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11"
+UPPER(X) ;Convert lowercase letters to uppercase
+ Q:'$D(X) ""
+ Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format
+ ;Required parameters:
+ ;X = Seven digit phone number at a minimum.  Optionally, in addition,
+ ;    a three digit area code, two digit country code and other
+ ;    formatting characters (e.g., dashes)
+ ;Optional Variables:
+ ;B = Beeper number
+ ;C = Comments
+ Q:'$D(X) ""  Q:$L(X)<7 ""
+ N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
+ S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
+ I $L(Y)<7 Q ""
+ S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
+ I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8)
+ I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11)
+ I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40)
+ I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40)
+ I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40)
+ Q ""
+HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format
+ ;Required parameters:
+ ;AD = One to four street address lines separated by uparrows (^).
+ ;GL = Three to four geographic location components separated by
+ ;     uparrows (^).  City^State or Province^Zip Code^Country Code.
+ ;     If the fourth component is not defined, it will be set to 'USA'.
+ ;     The second component must be null or an IEN in the
+ ;     State file (#5).  The third component must be null or pattern
+ ;     match 5N, 9N or 5N1"-"4N.
+ ;
+ ;        Optional HLECDE - Encoding chars
+ ;**** NOTE: ****
+ ;If this function is called without HLECDE as parameter than HLECH
+ ;must be define.
+ ;
+ ;
+ ;A string will be returned with six components separated by the HL7
+ ;component separator.  The length of the string (including separators)
+ ;may exceed 106 characters.
+ ;
+ Q:'$D(AD) ""  Q:'$D(GL) ""
+ I '$D(HLECH),'$D(HLECDE) Q ""
+ I $D(HLECDE) N HLECH S HLECH=HLECDE
+ I '$D(HLECH) Q ""
+ I $D(XRTL) D T0^%ZOSV
+ N I,X,Y
+ I $P(GL,"^",4)="" S $P(GL,"^",4)="USA"
+ I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"")
+ S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"")
+ S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4)
+ S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3)
+ I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1))
+ I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV
+ I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y
+ I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y
+ I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y
+ I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m

-              r613
+              r623
+HLMA    ;AISC/SAW-Message Administration Module ;05/02/2008  10:27
+        ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122,140**;Oct 13, 1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP)   ;
+        ;Entry point to generate a deferred message
+        ;
+        ;This is a subroutine call with parameter passing.  It returns a
+        ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows
+        ;as follows:  1st message ID^error code^error description
+        ;If no error occurs, only the first piece is returned equal to a unique
+        ;ID for the 1st message.  If message was sent to more than 1 subscriber
+        ;than the other message IDs will be in the array HLRESLT(n)=ID
+        ;Otherwise, three pieces are returned with the
+        ;first piece equal to the message ID, if one was assigned, otherwise 0
+        ;
+        ;Required Input Parameters
+        ;     HLEID = Name or IEN of event driver protocol in the Protocol file
+        ;  HLARYTYP = Array type.  One of the following codes:
+        ;               LM = local array containing a single message
+        ;               LB = local array containig a batch of messages
+        ;               GM = global array containing a single message
+        ;               GB = global array containing a batch of messages
+        ;  HLFORMAT = Format of array, 1 for pre-formatted in HL7 format,
+        ;               otherwise 0
+        ;NOTE:  The parameter HLRESLT must be passed by reference
+        ;   HLRESLT = The variable that will be returned to the calling
+        ;               application as descibed above
+        ;Optional Parameters
+        ;   HLMTIEN = IEN of entry in Message Text file where the message
+        ;               being generated is to be stored.  This parameter is
+        ;               only passed for a batch type message
+        ;NOTE:  The parameter HLP used for the following parameters must be
+        ;       passed by reference
+        ;  HLP("SECURITY") = A 1 to 40 character string
+        ;   HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
+        ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
+        ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or
+        ;   <subscriber protocol name> - A list of protocols to dynamically
+        ;   drop from the event protocol's subscriber multiple.
+        ;
+        ;can't have link open when generating new message
+        N HLTCP,HLTCPO,HLPRIO,HLMIDAR
+        S HLPRIO="D"
+        S HLRESLT=""
+        ;Check for required parameters
+CONT    ;
+        I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D  G EXIT
+        . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point"
+        I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT
+        N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)=""
+        I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT
+        I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT
+        I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT
+        I $D(HLL("LINKS")) D  G:$G(HLRESLT)]"" EXIT
+        . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN
+        . S I=0
+        . F  S I=$O(HLL("LINKS",I)) Q:'I  D  Q:$G(HLRESLT)]""
+        . . S HLPNAM=$P(HLL("LINKS",I),U)
+        . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0))
+        . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q
+        . . S HLLNAM=$P(HLL("LINKS",I),U,2)
+        . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0))
+        . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q
+        ;Extract data from Protocol file
+        D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN)
+        S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15))
+        S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT
+        ;Create message ID and Message Text IEN if Message Text IEN not
+        ;previously created ('$G(HLMTIEN))
+        I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
+        ;Get message ID if Message Text IEN already created
+        I '$G(HLMID) D
+        .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT
+        .S HLDT1=$$HLDATE^HLFNC(HLDT)
+        S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1
+        ;Execute entry action for event driver protocol
+        I HLENROU]"" X HLENROU
+        ;Invoke transaction processor
+        K HLDT,HLDT1,HLENROU
+        D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP)
+        ;HLMIDAR is array of message IDs, only set for broadcast messages
+        I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR
+        S HLRESLT=HLRESLT_"^"_HLRESLT1
+        ;
+        ; patch HL*1.6*122
+        S HLRESLT("HLMID")=$G(HLMIDAR("HLMID"))
+        S HLRESLT("IEN773")=$G(HLMIDAR("IEN773"))
+        ;
+        ;Execute exit action for event driver protocol
+        I HLEXROU]"" X HLEXROU
+EXIT    ;Update status if Message Text file entry has been created
+        K HLTCP
+        I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:""))
+        K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU
+        Q
+DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP)    ;
+        ;Entry point to generate an immediate message, must be TCP Logical Link
+        ;Input:
+        ;  The same as GENERATE,with one additional subscript to the HLP input
+        ;  array:
+        ;
+        ;  HLP("OPEN TIMEOUT") (optional, pass by reference) a number between
+        ;    1 and 120 that specifies how many seconds the DIRECT CONNECT should
+        ;    try to open a connection before failing.  It is killed upon
+        ;    completion.
+        ;
+        N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
+        ; patch HL*1.6*140- to protect application who call this entry
+        N IO,IOF,ION,IOT,IOST,POP
+        S HLRESLT=""
+        ;HLMTIENO=ien passed in, batch message
+        S HLMTIEN=$G(HLMTIENO)
+        I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER"
+        I $G(HLP("OPEN TIMEOUT")) D
+        .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT")
+        .K HLP("OPEN TIMEOUT")
+        K HL,HLMTIENO
+        D INIT^HLFNC2(HLEID,.HL)
+        I $G(HL) S HLRESLT="0^"_HL Q
+        S HLPRIO="I" D CONT
+        ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2
+        S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR)
+        ;Set special HL variables
+        S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
+        Q
+        ;
+CLOSE(LOGLINK)  ;close connection that was open in tag DIRECT
+        Q
+PING    ;ping another VAMC to test Link
+        ;set HLQUIET =1 to skip writes
+        ;look for HLTPUT to get turnaround time over network.
+        N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM
+        N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2
+        S HLQUIET=$G(HLQUIET)
+        S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT"
+        S DIC="^HLCS(870,",DIC(0)="QEAMZ"
+        D ^DIC Q:Y<0
+        S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2)
+        ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
+        D SETUP^HLCSAC G:HLCS PINGQ
+        ; patch HL*1.6*122
+        G:$$DONTPING^HLMA4 PINGQ
+        ;PING header=MSH^PING^domain^PING^logical link^datetime
+        S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H)
+        D OPEN^HLCSAC
+        I HLCS D DNS G:HLCS PINGQ
+        D
+        . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA"
+        . ;non-standard HL7 header; start block,header,end block
+        . S HLX1=$H
+        . ;
+        . ; HL*1.6*122 start
+        . ; replace flush character '!' with @IOF (! or #)
+        . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
+        . ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
+        . ; W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF
+        . W $C(11)_INPUT(1)_$C(28)_$C(13),@HLTCPLNK("IOF")
+        . ; HL*1.6*122 end
+        . ;
+        . ;read response
+        . R X:HLDREAD
+        . S HLX2=$H
+        . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response")
+        . ;Get roundtrip time
+        . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2)
+        D CLOSE^%ZISTCP
+PINGQ   ;write back status and quit
+        I 'HLQUIET W !,HLCS,!
+        Q
+PINGERR ;process errors from PING
+        S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error"
+        ;I $ZE["READ" S HLCS="-1^Error during read"
+        ;I $ZE["WRITE" S HLCS="-1^Error during write"
+        ; HL*1.6*115, SACC compliance
+        I $$EC^%ZOSV["READ" S HLCS="-1^Error during read"
+        I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write"
+        G UNWIND^%ZTER
+DNS     ;
+        ;openfail-try DNS lookup-Link must contain point to Domain Name
+        S POP=$G(POP)
+        S HLQUIET=$G(HLQUIET)
+        I 'HLQUIET W !,"Calling DNS"
+        N HLDOM,HLIP S HLCS=""
+        S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
+        ; patch HL*1.6*122 start
+        S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
+        ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
+        I 'HLDOM,($L(HLDOM("DNS"),".")<3) D  Q
+        . I 'HLQUIET W !,"Domain Unknown"
+        . S HLCS="-1^Connection Fail"
+        ; patch HL*1.6*122 end
+        I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
+        ; patch HL*1.6*122
+        ; I HLDOM]"" D  Q:'POP
+        I HLDOM]""!($L(HLDOM("DNS"),".")>2) D  Q:'POP
+        . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
+        . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
+        . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
+        . ; patch HL*1.6*122
+        . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS")
+        . I 'HLQUIET W !,"Domain, "_HLDOM
+        . I 'HLQUIET W !,"Port: ",HLTCPORT
+        . S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+        . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP
+        . I HLIP]"" D
+        . . ;If more than one IP returned, try each, cache successful open
+        . . N HLI,HLJ,HLIP1
+        . . F HLJ=1:1:$L(HLIP,",") D  Q:'POP
+        . . . S HLIP1=$P(HLIP,",",HLJ)
+        . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP
+        . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1
+        . . . U IO
+        I POP S HLCS="-1^DNS Lookup Failed"
+HLMA ;AISC/SAW-Message Administration Module ;10/25/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ;
+ ;Entry point to generate a deferred message
+ ;
+ ;This is a subroutine call with parameter passing.  It returns a
+ ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows
+ ;as follows:  1st message ID^error code^error description
+ ;If no error occurs, only the first piece is returned equal to a unique
+ ;ID for the 1st message.  If message was sent to more than 1 subscriber
+ ;than the other message IDs will be in the array HLRESLT(n)=ID
+ ;Otherwise, three pieces are returned with the
+ ;first piece equal to the message ID, if one was assigned, otherwise 0
+ ;
+ ;Required Input Parameters
+ ;     HLEID = Name or IEN of event driver protocol in the Protocol file
+ ;  HLARYTYP = Array type.  One of the following codes:
+ ;               LM = local array containing a single message
+ ;               LB = local array containig a batch of messages
+ ;               GM = global array containing a single message
+ ;               GB = global array containing a batch of messages
+ ;  HLFORMAT = Format of array, 1 for pre-formatted in HL7 format,
+ ;               otherwise 0
+ ;NOTE:  The parameter HLRESLT must be passed by reference
+ ;   HLRESLT = The variable that will be returned to the calling
+ ;               application as descibed above
+ ;Optional Parameters
+ ;   HLMTIEN = IEN of entry in Message Text file where the message
+ ;               being generated is to be stored.  This parameter is
+ ;               only passed for a batch type message
+ ;NOTE:  The parameter HLP used for the following parameters must be
+ ;       passed by reference
+ ;  HLP("SECURITY") = A 1 to 40 character string
+ ;   HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
+ ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
+ ; HLP("EXLCLUDE SUBSCRIBER",<n=1,2,3...>)=<subsciber protocol ien> - A list of protocols to dynamically drop from the event protocol's subscriber multiple.
+ ;
+ ;can't have link open when generating new message
+ N HLTCP,HLTCPO,HLPRIO,HLMIDAR
+ S HLPRIO="D"
+ S HLRESLT=""
+ ;Check for required parameters
+CONT I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" G EXIT
+ I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT
+ N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)=""
+ I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT
+ I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT
+ I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT
+ I $D(HLL("LINKS")) D  G:$G(HLRESLT)]"" EXIT
+ . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN
+ . S I=0
+ . F  S I=$O(HLL("LINKS",I)) Q:'I  D  Q:$G(HLRESLT)]""
+ . . S HLPNAM=$P(HLL("LINKS",I),U)
+ . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0))
+ . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q
+ . . S HLLNAM=$P(HLL("LINKS",I),U,2)
+ . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0))
+ . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q
+ ;Extract data from Protocol file
+ D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN)
+ S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15))
+ S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT
+ ;Create message ID and Message Text IEN if Message Text IEN not
+ ;previously created ('$G(HLMTIEN))
+ I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
+ ;Get message ID if Message Text IEN already created
+ I '$G(HLMID) D
+ .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT
+ .S HLDT1=$$HLDATE^HLFNC(HLDT)
+ S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1
+ ;Execute entry action for event driver protocol
+ I HLENROU]"" X HLENROU
+ ;Invoke transaction processor
+ K HLDT,HLDT1,HLENROU
+ D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP)
+ ;HLMIDAR is array of message IDs, only set for broadcast messages
+ I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR
+ S HLRESLT=HLRESLT_"^"_HLRESLT1
+ ;Execute exit action for event driver protocol
+ I HLEXROU]"" X HLEXROU
+EXIT ;Update status if Message Text file entry has been created
+ K HLTCP
+ I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:""))
+ K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU
+ Q
+DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ;
+ ;Entry point to generate an immediate message, must be TCP Logical Link
+ ;Input:
+ ;  The same as GENERATE,with one additional subscript to the HLP input array:
+ ;
+ ;  HLP("OPEN TIMEOUT") (optional, pass by reference) a number between
+ ;    1 and 120 that specifies how many seconds the DIRECT CONNECT should
+ ;    try to open a connection before failing.  It is killed upon completion.
+ ;
+ N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
+ S HLRESLT=""
+ ;HLMTIENO=ien passed in, batch message
+ S HLMTIEN=$G(HLMTIENO)
+ I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER"
+ I $G(HLP("OPEN TIMEOUT")) D
+ .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT")
+ .K HLP("OPEN TIMEOUT")
+ K HL,HLMTIENO
+ D INIT^HLFNC2(HLEID,.HL)
+ I $G(HL) S HLRESLT="0^"_HL Q
+ S HLPRIO="I" D CONT
+ ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2
+ S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR)
+ ;Set special HL variables
+ S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
+ Q
+ ;
+CLOSE(LOGLINK) ;close connection that was open in tag DIRECT
+ Q
+PING ;ping another VAMC to test Link
+ ;set HLQUIET =1 to skip writes
+ ;look for HLTPUT to get turnaround time over network.
+ N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM
+ N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2
+ S HLQUIET=$G(HLQUIET)
+ S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT"
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ"
+ D ^DIC Q:Y<0
+ S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2)
+ ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
+ D SETUP^HLCSAC G:HLCS PINGQ
+ ;PING header=MSH^PING^domain^PING^logical link^datetime
+ S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H)
+ D OPEN^HLCSAC
+ I HLCS D DNS G:HLCS PINGQ
+ D
+ . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA"
+ . ;non-standard HL7 header; start block,header,end block
+ . S HLX1=$H
+ . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
+ . ;read response
+ . R X:HLDREAD
+ . S HLX2=$H
+ . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response")
+ . ;Get roundtrip time
+ . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2)
+ D CLOSE^%ZISTCP
+PINGQ ;write back status and quit
+ I 'HLQUIET W !,HLCS,!
+ Q
+PINGERR ;process errors from PING
+ S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error"
+ ;I $ZE["READ" S HLCS="-1^Error during read"
+ ;I $ZE["WRITE" S HLCS="-1^Error during write"
+ ; HL*1.6*115, SACC compliance
+ I $$EC^%ZOSV["READ" S HLCS="-1^Error during read"
+ I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write"
+ G UNWIND^%ZTER
+DNS ;
+ ;openfail-try DNS lookup-Link must contain point to Domain Name
+ S POP=$G(POP)
+ S HLQUIET=$G(HLQUIET)
+ I 'HLQUIET W !,"Calling DNS"
+ N HLDOM,HLIP S HLCS=""
+ S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
+ I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
+ I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
+ I HLDOM]"" D  Q:'POP
+ . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
+ . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
+ . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
+ . I 'HLQUIET W !,"Domain, "_HLDOM
+ . I 'HLQUIET W !,"Port: ",HLTCPORT
+ . S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+ . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP
+ . I HLIP]"" D
+ . . ;If more than one IP returned, try each, cache successful open
+ . . N HLI,HLJ,HLIP1
+ . . F HLJ=1:1:$L(HLIP,",") D  Q:'POP
+ . . . S HLIP1=$P(HLIP,",",HLJ)
+ . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP
+ . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1
+ . . . U IO
+ I POP S HLCS="-1^DNS Lookup Failed"

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m

-              r613
+              r623
+HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;07/18/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+SENDONE(HLMSTATE,PARMS,WHOTO,ERROR)     ;
+        ;Sends the message to a single receiving application.
+        ;
+        ;Input:
+        ;HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message.  The application MUST NOT touch it
+        ;PARMS( *pass by reference*
+        ;  "APP ACK RESPONSE")=<tag^routine> to call when the app ack is received (optional)
+        ;    (NOTE: For batch messages, HLO best supports returning application
+        ;     acknowledgments via a batch response.  However, non-VistA systems
+        ;     may return individual messages as application acknowledgments to
+        ;     messages within the original batch message, so for applications
+        ;     sending batch messages might best code the "APP ACK RESPONSE"
+        ;     routine to first check whether the response message is a batch.
+        ;
+        ;  "ACCEPT ACK RESPONSE")=<tag^routine> to call when the commit ack is received (optional)
+        ;  "ACCEPT ACK TYPE") = <AL,NE> (optional, defaults to AL)
+        ;  "APP ACK TYPE") = <AL,NE> (optional, defaults to NE)
+        ;  "FAILURE RESPONSE" - <tag>^<routine> (optional) The sending application routine to execute when the transmission of the message fails, i.e., the message can not be sent or no commit ack is received.
+        ;  "QUEUE" - (optional) An application can name its own private queue - just a string up to 20 characters, it should be namespaced.
+        ;  "SECURITY")=security information to include in the header segment, SEQ 8 (optional)
+        ;  "SENDING APPLICATION")=name of sending app (required, 60 maximum length)
+        ;
+        ;  WHOTO (required,pass by reference) an array specifying a single recipient. These subscripts are allowed:
+        ;
+        ;    "RECEIVING APPLICATION" - (string, 60 char max, required)
+        ;
+        ;  EXACTLY ONE of these parameters must be provided to identify the Receiving Facility:
+        ;
+        ;   "FACILITY LINK IEN" - ien of the logical link
+        ;   "FACILITY LINK NAME" - name of the logical link
+        ;   "INSTITUTION IEN" - ptr to the INSTITUTION file
+        ;   "STATION NUMBER" -  station # with suffix
+        ;
+        ;  EXACTLY ONE of these MAY be provided - optionally - to identify the interface engine to route the message through:
+        ;
+        ;   "IE LINK IEN" -  ptr to a logical link for the interface engine
+        ;   "IE LINK NAME" - name of the logical link for the interface engine
+        ;
+        ;Output:
+        ;  Function returns the ien of the message in file 778 on success, 0 on failure
+        ;   HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message.  The application MUST NOT touch it!
+        ;   ERROR (pass by reference, optional) - on failure, will contain an error message
+        ;   PARMS - left undefined when the function returns
+        ;   WHOTO - left undefined when the function returns
+        ;
+        ;
+        N SUCCESS,ERR1,ERR2
+        S SUCCESS=0
+        D
+        .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q
+        .;
+        .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO^HLOAPI2(.HLMSTATE,.WHOTO,.ERR2) D
+        ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1
+        .E  D
+        ..S ERROR=$G(ERR1)_": "_$G(ERR2)
+        ..D DONTSEND(.HLMSTATE,ERROR)
+        K PARMS,WHOTO
+        Q $S(SUCCESS:HLMSTATE("IEN"),1:0)
+        ;
+SENDMANY(HLMSTATE,PARMS,WHOTO)  ;
+        ;Sends the message to a list of receiving applications
+        ;
+        ;Input: Same as for $$SENDONE, except WHOTO is a list.
+        ;  WHOTO (pass by reference)
+        ;    Specifies a list of recipients.  Each recipient should be on the
+        ;    list as WHOTO(i), where i=1,2,3,4, etc. for as many messages as to
+        ;    send.  At each subscript WHOTO(i), the same lower level subscripts
+        ;    may be defined as in the $$SENDONE API.  For example:
+        ;
+        ;      WHOTO(1,"LINK NAME")="VAALB"
+        ;      WHOTO(1,"RECEIVING APPLICATION")="MPI"
+        ;      WHOTO(2,"STATION NUMBER")=500
+        ;      WHOTO(2,"RECEIVING APPLICATION")="MPI"
+        ;
+        ;
+        ;Output:
+        ;  Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise
+        ;  PARMS - left undefined when the function returns
+        ;  WHOTO (pass by reference) returns the status of each message to be sent in the format:
+        ;    (<i>,"QUEUED")= <1 if queued to be sent, 0 otherwise)
+        ;   (<i>,"IEN")=<ien, file 778>
+        ;   (<i>,"ERROR")= error message if an error was encountered (status=0), not defined otherwise
+        ;
+        ;
+        N ERROR,RETURN,WHO,STATE,I
+        S RETURN=1
+        I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) D  K PARMS Q 0
+        .S ERROR="MESSAGE NOT YET CREATED"
+        .S I=0 F  S I=$O(WHOTO(I)) Q:'I  S WHOTO(I,"QUEUED")=0,WHOTO(I,"IEN")=0,WHOTO(I,"ERROR")=ERROR
+        ;
+        I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D  K PARMS Q 0
+        .S I=0 F  S I=$O(WHOTO(I)) Q:'I  D
+        ..K WHO M WHO=WHOTO(I)
+        ..K STATE M STATE=HLMSTATE S STATE("IEN")=""
+        ..S WHOTO(I,"QUEUED")=0
+        ..D DONTSEND(.STATE,$G(ERROR))
+        ..S WHOTO(I,"IEN")=$G(STATE("IEN"))
+        ..S WHOTO(I,"ERROR")=ERROR
+        ;
+        S I=0 F  S I=$O(WHOTO(I)) Q:'I  D
+        .K WHO M WHO=WHOTO(I)
+        .K STATE M STATE=HLMSTATE S STATE("IEN")=""
+        .S ERROR=""
+        .I $$CHKWHO^HLOAPI2(.STATE,.WHO,.ERROR) D
+        ..I $$SEND(.STATE,.ERROR) D
+        ...S WHOTO(I,"QUEUED")=1
+        ...S WHOTO(I,"IEN")=STATE("IEN")
+        ...S WHOTO(I,"ERROR")=""
+        ..E  D
+        ...S WHOTO(I,"QUEUED")=0
+        ...S WHOTO(I,"IEN")=$G(STATE("IEN"))
+        ...S WHOTO(I,"ERROR")=$G(ERROR)
+        ...S RETURN=0
+        .E  D  ;who not adequately determined
+        ..S WHOTO(I,"QUEUED")=0,RETURN=0
+        ..D DONTSEND(.STATE,$G(ERROR))
+        ..S WHOTO(I,"IEN")=$G(STATE("IEN")),WHOTO(I,"ERROR")=$G(ERROR)
+        K PARMS
+        Q RETURN
+        ;
+SENDSUB(HLMSTATE,PARMS,MESSAGES)        ;
+        ;Sends the message to a list of receiving applications based on the HL7 Subscription Registry
+        ;
+        ;Input:
+        ;  HLMSTATE (pass by reference, required) same as $$SENDMANY
+        ;  PARMS (pass by reference, required) same as $$SENDMANY, with one additional subscript:
+        ;    "SUBSCRIPTION IEN" - the ien of an entry in the HL7 Subscription Registry, defining the intended recipients of this message
+        ;
+        ;Output:
+        ;  Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise
+        ;  PARMS - left undefined when the function returns
+        ;  MESSAGES (pass by reference) returns the status of each message to be sent in this format, where subien is the ien of the recipient in the RECIPEINTS subfile of the HL7 Subscription Registry
+        ;   (<subien>,"QUEUED")= <1 if queued to be sent, 0 otherwise)
+        ;   (<subien>,"IEN")=<ien, file 778>
+        ;   (<subien>,"ERROR")= error message if an error was encountered (status=0), not defined otherwise
+        ;
+        ;
+        K MESSAGES
+        N ERROR,RETURN,STATE,SUBIEN,WHO
+        ;
+        S RETURN=1
+        ;
+        ;
+        I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" K PARMS Q 0
+        I '$G(PARMS("SUBSCRIPTION IEN")) S ERROR="SUBSCRIPTION REGISTRY IEN NOT PROVIDED" K PARMS Q 0
+        ;
+        I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D  K PARMS Q 0
+        .S SUBIEN=0 F  S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN  D
+        ..N SARY,HARY
+        ..S HARY="STATE(""HDR"")"
+        ..S SARY="STATE(""STATUS"")"
+        ..K STATE M STATE=HLMSTATE S STATE("IEN")=""
+        ..;move parameters into HLMSTATE
+        ..S @SARY@("LINK IEN")=WHO("LINK IEN")
+        ..S @SARY@("LINK NAME")=WHO("LINK NAME")
+        ..S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION")
+        ..M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY")
+        ..D DONTSEND(.STATE,$G(ERROR))
+        ..S MESSAGES(SUBIEN,"QUEUED")=0
+        ..S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN"))
+        ..S MESSAGES(SUBIEN,"ERROR")=$G(ERROR)
+        ;
+        F  S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN  D
+        .N SARY,HARY
+        .S HARY="STATE(""HDR"")"
+        .S SARY="STATE(""STATUS"")"
+        .K STATE M STATE=HLMSTATE S STATE("IEN")=""
+        .;move parameters into HLMSTATE
+        .S @SARY@("LINK IEN")=WHO("LINK IEN")
+        .S @SARY@("LINK NAME")=WHO("LINK NAME")
+        .S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION")
+        .M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY")
+        .S ERROR=""
+        .I $$SEND(.STATE,.ERROR) D
+        ..S MESSAGES(SUBIEN,"QUEUED")=1
+        .E  D
+        ..S MESSAGES(SUBIEN,"QUEUED")=0,RETURN=0
+        .S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")),MESSAGES(SUBIEN,"ERROR")=$G(ERROR)
+        K PARMS
+        Q RETURN
+        ;
+SEND(HLMSTATE,ERROR)    ;
+        ;
+        K ERROR
+        I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) S ERROR="$$SAVE^HLOF777 FAILED!" Q 0
+        ;
+        I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0
+        I HLMSTATE("BATCH"),$L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) S ERROR="SEQUENCE QUEUES NOT SUPPORTED FOR BATCH MESSAGES" Q 0
+        I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
+        .S HLMSTATE("STATUS","MOVED TO OUT QUEUE")=$$SQUE^HLOQUE(HLMSTATE("STATUS","SEQUENCE QUEUE"),HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) D:HLMSTATE("STATUS","MOVED TO OUT QUEUE")
+        ..S $P(^HLB(HLMSTATE("IEN"),5),"^",2)=1
+        E  D
+        .D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
+        Q HLMSTATE("IEN")
+        ;
+DONTSEND(HLMSTATE,ERROR)        ;
+        ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the status ER.
+        ;Input:
+        ;       HLMSTATE - pass-by-reference
+        ;       ERROR (optional, pass-by-value) error text to store with the message
+        ;Output: none
+        ;
+        I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue
+        ;
+        S HLMSTATE("STATUS")="ER"
+        S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE"))
+        S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR)
+        I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app
+        Q
+HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;02/06/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+SENDONE(HLMSTATE,PARMS,WHOTO,ERROR) ;
+ ;Sends the message to a single receiving application.
+ ;
+ ;Input:
+ ;HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message.  The application MUST NOT touch it
+ ;PARMS( *pass by reference*
+ ;  "APP ACK RESPONSE")=<tag^routine> to call when the app ack is received (optional)
+ ;    (NOTE: For batch messages, HLO best supports returning application
+ ;     acknowledgments via a batch response.  However, non-VistA systems
+ ;     may return individual messages as application acknowledgments to
+ ;     messages within the original batch message, so for applications
+ ;     sending batch messages might best code the "APP ACK RESPONSE"
+ ;     routine to first check whether the response message is a batch.
+ ;
+ ;  "ACCEPT ACK RESPONSE")=<tag^routine> to call when the commit ack is received (optional)
+ ;  "ACCEPT ACK TYPE") = <AL,NE> (optional, defaults to AL)
+ ;  "APP ACK TYPE") = <AL,NE> (optional, defaults to NE)
+ ;  "FAILURE RESPONSE" - <tag>^<routine> (optional) The sending application routine to execute when the transmission of the message fails, i.e., the message can not be sent or no commit ack is received.
+ ;  "QUEUE" - (optional) An application can name its own private queue - just a string up to 20 characters, it should be namespaced.
+ ;  "SECURITY")=security information to include in the header segment, SEQ 8 (optional)
+ ;  "SENDING APPLICATION")=name of sending app (required, 60 maximum length)
+ ;
+ ;  WHOTO (required,pass by reference) an array specifying a single recipient. These subscripts are allowed:
+ ;
+ ;    "RECEIVING APPLICATION" - (string, 60 char max, required)
+ ;
+ ;  EXACTLY ONE of these parameters must be provided to identify the Receiving Facility:
+ ;
+ ;   "FACILITY LINK IEN" - ien of the logical link
+ ;   "FACILITY LINK NAME" - name of the logical link
+ ;   "INSTITUTION IEN" - ptr to the INSTITUTION file
+ ;   "STATION NUMBER" -  station # with suffix
+ ;
+ ;  EXACTLY ONE of these MAY be provided - optionally - to identify the interface engine to route the message through:
+ ;
+ ;   "IE LINK IEN" -  ptr to a logical link for the interface engine
+ ;   "IE LINK NAME" - name of the logical link for the interface engine
+ ;
+ ;Output:
+ ;  Function returns the ien of the message in file 778 on success, 0 on failure
+ ;   HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message.  The application MUST NOT touch it!
+ ;   ERROR (pass by reference, optional) - on failure, will contain an error message
+ ;   PARMS - left undefined when the function returns
+ ;   WHOTO - left undefined when the function returns
+ ;
+ ;
+ N SUCCESS,ERR1,ERR2
+ S SUCCESS=0
+ D
+ .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q
+ .;
+ .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO(.HLMSTATE,.WHOTO,.ERR2) D
+ ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1
+ .E  D
+ .S ERROR=$G(ERR1)_": "_$G(ERR2)
+ .D DONTSEND(.HLMSTATE,ERROR)
+ K PARMS,WHOTO
+ Q $S(SUCCESS:HLMSTATE("IEN"),1:0)
+ ;
+SENDMANY(HLMSTATE,PARMS,WHOTO) ;
+ ;Sends the message to a list of receiving applications
+ ;
+ ;Input: Same as for $$SENDONE, except WHOTO is a list.
+ ;  WHOTO (pass by reference)
+ ;    Specifies a list of recipients.  Each recipient should be on the
+ ;    list as WHOTO(i), where i=1,2,3,4, etc. for as many messages as to
+ ;    send.  At each subscript WHOTO(i), the same lower level subscripts
+ ;    may be defined as in the $$SENDONE API.  For example:
+ ;
+ ;      WHOTO(1,"LINK NAME")="VAALB"
+ ;      WHOTO(1,"RECEIVING APPLICATION")="MPI"
+ ;      WHOTO(2,"STATION NUMBER")=500
+ ;      WHOTO(2,"RECEIVING APPLICATION")="MPI"
+ ;
+ ;
+ ;Output:
+ ;  Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise
+ ;  PARMS - left undefined when the function returns
+ ;  WHOTO (pass by reference) returns the status of each message to be sent in the format:
+ ;    (<i>,"QUEUED")= <1 if queued to be sent, 0 otherwise)
+ ;   (<i>,"IEN")=<ien, file 778>
+ ;   (<i>,"ERROR")= error message if an error was encountered (status=0), not defined otherwise
+ ;
+ ;
+ N ERROR,RETURN,WHO,STATE,I
+ S RETURN=1
+ I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) D  K PARMS Q 0
+ .S ERROR="MESSAGE NOT YET CREATED"
+ .S I=0 F  S I=$O(WHOTO(I)) Q:'I  S WHOTO(I,"QUEUED")=0,WHOTO(I,"IEN")=0,WHOTO(I,"ERROR")=ERROR
+ ;
+ I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D  K PARMS Q 0
+ .S I=0 F  S I=$O(WHOTO(I)) Q:'I  D
+ ..K WHO M WHO=WHOTO(I)
+ ..K STATE M STATE=HLMSTATE S STATE("IEN")=""
+ ..S WHOTO(I,"QUEUED")=0
+ ..D DONTSEND(.STATE,$G(ERROR))
+ ..S WHOTO(I,"IEN")=$G(STATE("IEN"))
+ ..S WHOTO(I,"ERROR")=ERROR
+ ;
+ S I=0 F  S I=$O(WHOTO(I)) Q:'I  D
+ .K WHO M WHO=WHOTO(I)
+ .K STATE M STATE=HLMSTATE S STATE("IEN")=""
+ .S ERROR=""
+ .I $$CHKWHO(.STATE,.WHO,.ERROR) D
+ ..I $$SEND(.STATE,.ERROR) D
+ ...S WHOTO(I,"QUEUED")=1
+ ...S WHOTO(I,"IEN")=STATE("IEN")
+ ...S WHOTO(I,"ERROR")=""
+ ..E  D
+ ...S WHOTO(I,"QUEUED")=0
+ ...S WHOTO(I,"IEN")=$G(STATE("IEN"))
+ ...S WHOTO(I,"ERROR")=$G(ERROR)
+ ...S RETURN=0
+ .E  D  ;who not adequately determined
+ ..S WHOTO(I,"QUEUED")=0,RETURN=0
+ ..D DONTSEND(.STATE,$G(ERROR))
+ ..S WHOTO(I,"IEN")=$G(STATE("IEN")),WHOTO(I,"ERROR")=$G(ERROR)
+ K PARMS
+ Q RETURN
+ ;
+SENDSUB(HLMSTATE,PARMS,MESSAGES) ;
+ ;Sends the message to a list of receiving applications based on the HL7 Subscription Registry
+ ;
+ ;Input:
+ ;  HLMSTATE (pass by reference, required) same as $$SENDMANY
+ ;  PARMS (pass by reference, required) same as $$SENDMANY, with one additional subscript:
+ ;    "SUBSCRIPTION IEN" - the ien of an entry in the HL7 Subscription Registry, defining the intended recipients of this message
+ ;
+ ;Output:
+ ;  Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise
+ ;  PARMS - left undefined when the function returns
+ ;  MESSAGES (pass by reference) returns the status of each message to be sent in this format, where subien is the ien of the recipient in the RECIPEINTS subfile of the HL7 Subscription Registry
+ ;   (<subien>,"QUEUED")= <1 if queued to be sent, 0 otherwise)
+ ;   (<subien>,"IEN")=<ien, file 778>
+ ;   (<subien>,"ERROR")= error message if an error was encountered (status=0), not defined otherwise
+ ;
+ ;
+ K MESSAGES
+ N ERROR,RETURN,STATE,SUBIEN,WHO
+ ;
+ S RETURN=1
+ ;
+ ;
+ I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" K PARMS Q 0
+ I '$G(PARMS("SUBSCRIPTION IEN")) S ERROR="SUBSCRIPTION REGISTRY IEN NOT PROVIDED" K PARMS Q 0
+ ;
+ I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D  K PARMS Q 0
+ .S SUBIEN=0 F  S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN  D
+ ..N SARY,HARY
+ ..S HARY="STATE(""HDR"")"
+ ..S SARY="STATE(""STATUS"")"
+ ..K STATE M STATE=HLMSTATE S STATE("IEN")=""
+ ..;move parameters into HLMSTATE
+ ..S @SARY@("LINK IEN")=WHO("LINK IEN")
+ ..S @SARY@("LINK NAME")=WHO("LINK NAME")
+ ..S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION")
+ ..M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY")
+ ..D DONTSEND(.STATE,$G(ERROR))
+ ..S MESSAGES(SUBIEN,"QUEUED")=0
+ ..S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN"))
+ ..S MESSAGES(SUBIEN,"ERROR")=$G(ERROR)
+ ;
+ F  S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN  D
+ .N SARY,HARY
+ .S HARY="STATE(""HDR"")"
+ .S SARY="STATE(""STATUS"")"
+ .K STATE M STATE=HLMSTATE S STATE("IEN")=""
+ .;move parameters into HLMSTATE
+ .S @SARY@("LINK IEN")=WHO("LINK IEN")
+ .S @SARY@("LINK NAME")=WHO("LINK NAME")
+ .S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION")
+ .M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY")
+ .S ERROR=""
+ .I $$SEND(.STATE,.ERROR) D
+ ..S MESSAGES(SUBIEN,"QUEUED")=1
+ .E  D
+ ..S MESSAGES(SUBIEN,"QUEUED")=0,RETURN=0
+ .S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")),MESSAGES(SUBIEN,"ERROR")=$G(ERROR)
+ K PARMS
+ Q RETURN
+ ;
+SEND(HLMSTATE,ERROR) ;
+ ;
+ K ERROR
+ I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) S ERROR="$$SAVE^HLOF777 FAILED!" Q 0
+ ;
+ I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0
+ D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
+ Q HLMSTATE("IEN")
+ ;
+DONTSEND(HLMSTATE,ERROR) ;
+ ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the
+ ;of "SE".
+ ;Input:
+ ;       HLMSTATE - pass-by-reference
+ ;       ERROR (optional, pass-by-value) error text to store with the message
+ ;Output: none
+ ;
+ I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue
+ ;
+ S HLMSTATE("STATUS")="SE"
+ S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE"))
+ S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR)
+ I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app
+ Q
+ ;
+CHKWHO(HLMSTATE,WHOTO,ERROR) ;
+ N RETURN,I
+ S RETURN=1
+ I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
+ ;
+ ;move parameters into HLMSTATE
+ S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
+ S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
+ S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
+ S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
+ F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
+ Q RETURN

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m

-              r613
+              r623
+HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/30/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+ACK(HLMSTATE,PARMS,ACK,ERROR)   ;Default behavior is to return a general
+        ;application ack. The application may optionally specify the message
+        ;type and event or call $$ADDSEG^HLOAPI to add segments.
+        ;A generic MSA segment (components 1-3) is added automatically IF the
+        ;application doesn't call $$ADDSEG^HLOAPI to add an MSA segment as the
+        ;FIRST segment following the header.
+        ;$$SENDACK must be called when the ack is completed. The return
+        ;destination is determined automatically from the original message
+        ;
+        ;This API should NOT be called for batch messages, use $$BATCHACK instead.
+        ;Input:
+        ;  HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message
+        ;  PARMS (pass by reference) These subscripts may be defined:
+        ;    "ACK CODE" (required) MSA1[ {AA,AE,AR}
+        ;    "ERROR MESSAGE" - MSA3, should be used only if AE or AR
+        ;    "ACCEPT ACK RESPONSE" - the <tag^routine> to call when the commit ack is received (optional)
+        ;    "ACCEPT ACK TYPE" - {AL,NE} (optional, defaults to AL)
+        ;    "CONTINUATION POINTER" (optional)indicates a fragmented message
+        ;    "COUNTRY" - the 3 character country code (optional)
+        ;    "EVENT" - the 3 character event type (optional, defaults to the event code of the original message)
+        ;     "ENCODING CHARACTERS" - the four HL7 encoding characters (optional,defaults to "^~\&"
+        ;    "FAILURE RESPONSE" (optional) the <tag>^<routine> that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received.
+        ;    "FIELD SEPARATOR" - field separator (optional, defaults to "|")
+        ;    "MESSAGE TYPE" - if not defined, ACK is used
+        ;    "MESSAGE STRUCTURE" (optional)
+        ;    "QUEUE" - (optional) An application can name its own private queue (a string under 20 characters,namespaced). The default is the name of the queue of the original message
+        ;    "SECURITY" (optional) security information to include in the header segment, SEQ 8 (optional)
+        ;    "VERSION" - the HL7 Version ID (optional, defaults to 2.4)
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure
+        ;  PARMS - left undefined when the function returns
+        ;  ACK (pass by reference, required) the acknowledgment message being built.
+        ;  ERROR (pass by reference) error msg
+        N I,SEG,TOLINK,SUCCESS
+        S SUCCESS=0,ERROR=""
+        ;
+        D
+        .N PORT
+        .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q
+        .;
+        .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGE IS NOT IDENTIFIED" Q
+        .I $G(HLMSTATE("BATCH")) S ERROR="BATCH ACKNOWLEDGMENTS MUST USE $$BATCHACK^HLOAPI3" Q
+        .;
+        .I $G(HLMSTATE("HDR","MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q
+        .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK")
+        .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK"
+        .S PARMS("EVENT")=$G(PARMS("EVENT"),$G(HLMSTATE("HDR","EVENT")))
+        .I $$NEWMSG^HLOAPI(.PARMS,.ACK)  ;can't fail!
+        .;
+        .;if the return link can not be determined, the HL Logical Link file has a problem that must be fixed at the site
+        .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2)
+        .S TOLINK=$$ACKLINK(.HLMSTATE)
+        .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q
+        .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK)
+        .;
+        .S ACK("HDR","APP ACK TYPE")="NE"
+        .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL")
+        .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE")))
+        .S ACK("STATUS","PORT")=PORT
+        .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY"))
+        .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION"))
+        .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
+        .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
+        .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
+        .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))
+        .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
+        .S ACK("STATUS","LINK NAME")=TOLINK
+        .S ACK("LINE COUNT")=0
+        .S ACK("MSA")="MSA"_ACK("HDR","FIELD SEPARATOR")_PARMS("ACK CODE")_ACK("HDR","FIELD SEPARATOR")_$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))_ACK("HDR","FIELD SEPARATOR")_$G(PARMS("ERROR MESSAGE"))
+        .S SUCCESS=1
+        K PARMS
+        K:'SUCCESS ACK
+        Q SUCCESS
+        ;
+SENDACK(ACK,ERROR)      ;This is used to signal that an application acknowledgment is complete.
+        ;Input:
+        ;  ACK (pass by reference,required) An array that contains the acknowledgment msg
+        ;Output:
+        ; Function returns 1 on success, 0 on failure
+        ; ERROR (pass by reference) error msg
+        ;
+        N SEG
+        ;if the application added its own MSA, then the ACK("MSA") node was killed
+        I $D(ACK("MSA")) S SEG(1)=ACK("MSA") D ADDSEG^HLOMSG(.ACK,.SEG)
+        ;
+        I $$SEND^HLOAPI1(.ACK,.ERROR) Q 1
+        Q 0
+        ;
+ACKLINK(HLMSTATE)       ;
+        ;Finds the link to return the application ack to.
+        N LINK
+        S LINK=$$RTRNLNK^HLOAPP($G(HLMSTATE("HDR","RECEIVING APPLICATION")))
+        Q:LINK]"" LINK
+        S LINK=$$RTRNLNK^HLOTLNK($G(HLMSTATE("HDR","SENDING FACILITY",1)),$G(HLMSTATE("HDR","SENDING FACILITY",2)),$G(HLMSTATE("HDR","SENDING FACILITY",3)))
+        Q LINK
+        ;
+CHKPARMS(HLMSTATE,PARMS,ERROR)  ;
+        N LEN,SARY,HARY
+        ;
+        ;shortcut to reference the header sub-array
+        S HARY="HLMSTATE(""HDR"")"
+        ;
+        ;shortcut to reference the status sub-array
+        S SARY="HLMSTATE(""STATUS"")"
+        ;
+        S ERROR=""
+        I $G(PARMS("ACCEPT ACK TYPE"))="" S PARMS("ACCEPT ACK TYPE")="AL"
+        I $G(PARMS("APP ACK TYPE"))="" S PARMS("APP ACK TYPE")="NE"
+        I PARMS("ACCEPT ACK TYPE")'="NE",PARMS("ACCEPT ACK TYPE")'="AL" S ERROR="INVALID ACCEPT ACKNOWLEDGMENT TYPE"
+        I PARMS("APP ACK TYPE")'="NE",PARMS("APP ACK TYPE")'="AL" S ERROR="INVALID APPLICATION ACKNOWLEDGMENT TYPE"
+        S LEN=$L($G(PARMS("QUEUE")))
+        I $G(PARMS("QUEUE"))["^" S ERROR="QUEUE NAME MAY NOT CONTAIN '^'"
+        I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20)
+        I 'LEN S PARMS("QUEUE")="DEFAULT"
+        D
+        .N APPIEN
+        .I $G(PARMS("SENDING APPLICATION"))="" D  Q
+        ..S ERROR="SENDING APPLICATION IS REQUIRED"
+        ..S PARMS("SENDING APPLICATION")=""
+        .E  D  Q:'APPIEN
+        ..S APPIEN=$$GETIEN^HLOAPP(PARMS("SENDING APPLICATION"))
+        ..I 'APPIEN S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
+        .I $L($G(PARMS("SEQUENCE QUEUE"))) D
+        ..I ($L(PARMS("SEQUENCE QUEUE"))>30) S ERROR="SEQUENCE QUEUE NAME > 30 CHARACTERS" Q
+        ..I PARMS("SEQUENCE QUEUE")["^" S ERROR="SEQUENCE QUEUE NAME MAY NOT CONTAIN '^'" Q
+        ..I $G(PARMS("APP ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN APPLICATION ACKNOWLEDGMENT" Q
+        ..I $G(PARMS("ACCEPT ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN ACCEPT ACKNOWLEDGMENT" Q
+        ;
+        ;move parameters into HLMSTATE
+        S @HARY@("ACCEPT ACK TYPE")=PARMS("ACCEPT ACK TYPE")
+        S @HARY@("APP ACK TYPE")=PARMS("APP ACK TYPE")
+        S @HARY@("SENDING APPLICATION")=$E(PARMS("SENDING APPLICATION"),1,60)
+        S @HARY@("SECURITY")=$G(PARMS("SECURITY"))
+        S @SARY@("APP ACK RESPONSE")=$G(PARMS("APP ACK RESPONSE"))
+        S @SARY@("ACCEPT ACK RESPONSE")=$G(PARMS("ACCEPT ACK RESPONSE"))
+        S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE"))
+        S @SARY@("QUEUE")=PARMS("QUEUE")
+        S @SARY@("SEQUENCE QUEUE")=$G(PARMS("SEQUENCE QUEUE"))
+        Q:$L(ERROR) 0
+        Q 1
+        ;
+        ;
+SETCODE(SEG,VALUE,FIELD,COMP,REP)       ;
+        ;Implements SETCNE and SETCWE
+        ;
+        N SUB,VAR
+        Q:'$G(FIELD)
+        S:'$G(REP) REP=1
+        I '$G(COMP) D
+        .S VAR="COMP",SUB=1
+        E  D
+        .S VAR="SUB"
+        S @VAR=1,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ID"))
+        S @VAR=2,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("TEXT"))
+        S @VAR=3,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM"))
+        S @VAR=4,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE ID"))
+        S @VAR=5,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE TEXT"))
+        S @VAR=6,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM"))
+        S @VAR=7,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM VERSION"))
+        S @VAR=8,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM VERSION"))
+        S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT"))
+        Q
+        ;
+CHKWHO(HLMSTATE,WHOTO,ERROR)    ;
+        N RETURN,I
+        S RETURN=1
+        I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
+        ;
+        ;move parameters into HLMSTATE
+        S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
+        S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
+        S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
+        S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
+        F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
+        Q RETURN
+HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;12/11/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ACK(HLMSTATE,PARMS,ACK,ERROR) ;Default behavior is to return a general
+ ;application ack. The application may optionally specify the message
+ ;type and event or call $$ADDSEG^HLOAPI to add segments.
+ ;A generic MSA segment (components 1-3) is added automatically IF the
+ ;application doesn't call $$ADDSEG^HLOAPI to add an MSA segment as the
+ ;FIRST segment following the header.
+ ;$$SENDACK must be called when the ack is completed. The return
+ ;destination is determined automatically from the original message
+ ;
+ ;This API should NOT be called for batch messages, use $$BATCHACK instead.
+ ;Input:
+ ;  HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message
+ ;  PARMS (pass by reference) These subscripts may be defined:
+ ;    "ACK CODE" (required) MSA1[ {AA,AE,AR}
+ ;    "ERROR MESSAGE" - MSA3, should be used only if AE or AR
+ ;    "ACCEPT ACK RESPONSE" - the <tag^routine> to call when the commit ack is received (optional)
+ ;    "ACCEPT ACK TYPE" - {AL,NE} (optional, defaults to AL)
+ ;    "CONTINUATION POINTER" (optional)indicates a fragmented message
+ ;    "COUNTRY" - the 3 character country code (optional)
+ ;    "EVENT" - the 3 character event type (optional, defaults to the event code of the original message)
+ ;     "ENCODING CHARACTERS" - the four HL7 encoding characters (optional,defaults to "^~\&"
+ ;    "FAILURE RESPONSE" (optional) the <tag>^<routine> that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received.
+ ;    "FIELD SEPARATOR" - field separator (optional, defaults to "|")
+ ;    "MESSAGE TYPE" - if not defined, ACK is used
+ ;    "MESSAGE STRUCTURE" (optional)
+ ;    "QUEUE" - (optional) An application can name its own private queue (a string under 20 characters,namespaced). The default is the name of the queue of the original message
+ ;    "SECURITY" (optional) security information to include in the header segment, SEQ 8 (optional)
+ ;    "VERSION" - the HL7 Version ID (optional, defaults to 2.4)
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  PARMS - left undefined when the function returns
+ ;  ACK (pass by reference, required) the acknowledgment message being built.
+ ;  ERROR (pass by reference) error msg
+ N I,SEG,TOLINK,SUCCESS
+ S SUCCESS=0,ERROR=""
+ ;
+ D
+ .N PORT
+ .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q
+ .;
+ .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGE IS NOT IDENTIFIED" Q
+ .I $G(HLMSTATE("BATCH")) S ERROR="BATCH ACKNOWLEDGMENTS MUST USE $$BATCHACK^HLOAPI3" Q
+ .;
+ .I $G(HLMSTATE("HDR","MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q
+ .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK")
+ .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK"
+ .S PARMS("EVENT")=$G(PARMS("EVENT"),$G(HLMSTATE("HDR","EVENT")))
+ .I $$NEWMSG^HLOAPI(.PARMS,.ACK)  ;can't fail!
+ .;
+ .;if the return link can not be determined, the HL Logical Link file has a problem that must be fixed at the site
+ .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2)
+ .S TOLINK=$$ACKLINK(.HLMSTATE)
+ .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q
+ .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK)
+ .;
+ .S ACK("HDR","APP ACK TYPE")="NE"
+ .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL")
+ .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE")))
+ .S ACK("STATUS","PORT")=PORT
+ .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY"))
+ .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION"))
+ .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
+ .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
+ .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
+ .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))
+ .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
+ .S ACK("STATUS","LINK NAME")=TOLINK
+ .S ACK("LINE COUNT")=0
+ .S ACK("MSA")="MSA"_ACK("HDR","FIELD SEPARATOR")_PARMS("ACK CODE")_ACK("HDR","FIELD SEPARATOR")_$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))_ACK("HDR","FIELD SEPARATOR")_$G(PARMS("ERROR MESSAGE"))
+ .S SUCCESS=1
+ K PARMS
+ K:'SUCCESS ACK
+ Q SUCCESS
+ ;
+SENDACK(ACK,ERROR) ;This is used to signal that an application acknowledgment is complete.
+ ;Input:
+ ;  ACK (pass by reference,required) An array that contains the acknowledgment msg
+ ;Output:
+ ; Function returns 1 on success, 0 on failure
+ ; ERROR (pass by reference) error msg
+ ;
+ N SEG
+ ;if the application added its own MSA, then the ACK("MSA") node was killed
+ I $D(ACK("MSA")) S SEG(1)=ACK("MSA") D ADDSEG^HLOMSG(.ACK,.SEG)
+ ;
+ I $$SEND^HLOAPI1(.ACK,.ERROR) Q 1
+ Q 0
+ ;
+ACKLINK(HLMSTATE) ;
+ ;Finds the link to return the application ack to.
+ N LINK
+ S LINK=$$RTRNLNK^HLOAPP($G(HLMSTATE("HDR","RECEIVING APPLICATION")))
+ Q:LINK]"" LINK
+ S LINK=$$RTRNLNK^HLOTLNK($G(HLMSTATE("HDR","SENDING FACILITY",1)),$G(HLMSTATE("HDR","SENDING FACILITY",2)),$G(HLMSTATE("HDR","SENDING FACILITY",3)))
+ Q LINK
+ ;
+CHKPARMS(HLMSTATE,PARMS,ERROR) ;
+ N LEN,SARY,HARY
+ ;
+ ;shortcut to reference the header sub-array
+ S HARY="HLMSTATE(""HDR"")"
+ ;
+ ;shortcut to reference the status sub-array
+ S SARY="HLMSTATE(""STATUS"")"
+ ;
+ S ERROR=""
+ I $G(PARMS("ACCEPT ACK TYPE"))="" S PARMS("ACCEPT ACK TYPE")="AL"
+ I $G(PARMS("APP ACK TYPE"))="" S PARMS("APP ACK TYPE")="NE"
+ I PARMS("ACCEPT ACK TYPE")'="NE",PARMS("ACCEPT ACK TYPE")'="AL" S ERROR="INVALID ACCEPT ACKNOWLEDGMENT TYPE"
+ I PARMS("APP ACK TYPE")'="NE",PARMS("APP ACK TYPE")'="AL" S ERROR="INVALID APPLICATION ACKNOWLEDGMENT TYPE"
+ S LEN=$L($G(PARMS("QUEUE")))
+ I $G(PARMS("QUEUE"))["^" S ERROR="QUEUE NAME MAY NOT CONTAIN '^'"
+ I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20)
+ I 'LEN S PARMS("QUEUE")="DEFAULT"
+ I $G(PARMS("SENDING APPLICATION"))="" D
+ .S ERROR="SENDING APPLICATION IS REQUIRED"
+ .S PARMS("SENDING APPLICATION")=""
+ E  D
+ .I '$D(^HLD(779.2,"C",PARMS("SENDING APPLICATION"))) S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
+ ;
+ ;move parameters into HLMSTATE
+ S @HARY@("ACCEPT ACK TYPE")=PARMS("ACCEPT ACK TYPE")
+ S @HARY@("APP ACK TYPE")=PARMS("APP ACK TYPE")
+ S @HARY@("SENDING APPLICATION")=$E(PARMS("SENDING APPLICATION"),1,60)
+ S @HARY@("SECURITY")=$G(PARMS("SECURITY"))
+ S @SARY@("APP ACK RESPONSE")=$G(PARMS("APP ACK RESPONSE"))
+ S @SARY@("ACCEPT ACK RESPONSE")=$G(PARMS("ACCEPT ACK RESPONSE"))
+ S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE"))
+ S @SARY@("QUEUE")=PARMS("QUEUE")
+ Q:$L(ERROR) 0
+ Q 1
+ ;
+SETCODE(SEG,VALUE,FIELD,COMP,REP) ;
+ ;Implements SETCNE and SETCWE
+ ;
+ N SUB,VAR
+ Q:'$G(FIELD)
+ S:'$G(REP) REP=1
+ I '$G(COMP) D
+ .S VAR="COMP",SUB=1
+ E  D
+ .S VAR="SUB"
+ S @VAR=1,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ID"))
+ S @VAR=2,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("TEXT"))
+ S @VAR=3,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM"))
+ S @VAR=4,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE ID"))
+ S @VAR=5,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE TEXT"))
+ S @VAR=6,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM"))
+ S @VAR=7,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM VERSION"))
+ S @VAR=8,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM VERSION"))
+ S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT"))
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m

-              r613
+              r623
 HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,133,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
 BATCHACK(HLMSTATE,PARMS,ACK,ERROR)      ;Starts a batch message that is the response to a batch message. Individual acks are placed in the batch by calling $$ADDACK.
         ;$$SENDACK^HLOAPI2 must be called when the batch of acks is complete. The return destination is determined automatically from the original message.
+        ;
         ;Input:
         ;  HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message
         ;  PARMS (optional, pass by reference) These subscripts may be defined:
         ;    "ACCEPT ACK RESPONSE")=<tag^routine> to call when the commit ack is received (optional)
         ;    "ACCEPT ACK TYPE") = <AL,NE> (optional, defaults to AL)
         ;    "COUNTRY") - a 3 character country code from the HL7 standard table (optional)
         ;     "ENCODING CHARACTERS" - the 4 HL7 encoding characters (optional,defaults to "^~\&"
         ;    "FAILURE RESPONSE" (optional) the <tag>^<routine> that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received.
         ;     "FIELD SEPARATOR" - the field separator (optional, defaults to "|")
         ;     "QUEUE" (optional) An application can name a private queue (a string under 20 characters, namespaced). The default is the name of the queue of the original message
         ;     "SECURITY" - security information to include in the header segment, SEQ 8 (optional)
         ;    "VERSION" - the HL7 Version ID (optional, defaults to 2.4)
         ;Output:
         ;  Function returns 1 on success, 0 on failure
         ;  PARMS - left undefined upon completion
         ;  ACK (pass by reference, required) the batch acknowledgment message being built.
         ;  ERROR (pass by reference) error message
         N I,TOLINK,SUCCESS
         S SUCCESS=0
+        ;
+        D
         .N PORT
         .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGMENT IS NOT IDENTIFIED" Q
         .;if the return link can not be determined, the HL Logical Link file has a problem
         .S TOLINK=$$ACKLINK^HLOAPI2(.HLMSTATE)
         .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q
         .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2)
         .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK)
         .;
         .I $$NEWBATCH^HLOAPI(.PARMS,.ACK)  ;can't fail!
         .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE")))
         .S ACK("STATUS","PORT")=PORT
         .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY"))
         .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION"))
         .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
         .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
         .S ACK("HDR","APP ACK TYPE")="NE"
         .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL")
         .S ACK("ACK TO")=$G(HLMSTATE("HDR","BATCH CONTROL ID"))
         .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
         .S ACK("ACK TO","BODY")=$G(HLMSTATE("BODY"))
         .S ACK("STATUS","LINK NAME")=TOLINK
         .S ACK("LINE COUNT")=0
         .S SUCCESS=1
         K PARMS
         Q SUCCESS
+        ;
 ADDACK(ACK,PARMS,ERROR) ;This API adds an application acknowledgment to a batch
         ;of acknowledgments that was started by calling $$BATCHACK.
         ;The Default behavior is to return a general application ack.
         ;The application may optionally specify the message
         ;type and event and/or call $$ADDSEG^HLOAPI to add segments.
         ;A generic MSA segment (components 1-3) will be added automatically
         ;if the application doesn't call $$ADDSEG^HLOAPI to add an MSA segment
         ;as the FIRST segment following the MSH segment.
         ;$$SENDACK^HLOAPI2 must be called when the batch is complete.
+        ;
         ;Input:
         ;  ACK (pass by reference,required) the batch of acks that is being built
         ;  PARMS (pass by reference) These subscripts may be defined:
         ;    "ACK CODE" (required) MSA1[ {AA,AE,AR}
         ;    "ERROR MESSAGE" (optional) MSA3, should be used only if AE or AR
         ;    "EVENT" - 3 character event type (optional, defaults to the event code of the original message)
         ;    "MESSAGE CONTROL ID" (required) this is the message control id of the original individual message within the batch which is being acknowledged
         ;    "MESSAGE STRUCTURE" (optional)
         ;    "MESSAGE TYPE" (optional, defaults to ACK)
         ;    "SECURITY" (optional) security information to include in the header segment SEQ 8
         ;Output:
         ;  Function returns 1 on success, 0 on failure
         ;  ACK (pass by reference, required) The batch, updated with another ack
         ;  PARMS  - left undefined when this function returns
         ;  ERROR (pass by reference) error msg
+        ;
         N SUB,SUCCESS
         S SUCCESS=0
+        D
         .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q
         .;
         .I $G(PARMS("MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q
         .S SUB=""
         .F  S SUB=$O(^HLB("AE",PARMS("MESSAGE CONTROL ID"),SUB)) Q:SUB=""  I $P(SUB,"^")=ACK("ACK TO","IEN"),$P(SUB,"^",2) S PARMS("ACK TO","IEN")=SUB Q
         .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK")
         .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK"
         .S PARMS("EVENT")=$G(PARMS("EVENT"))
         .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3)
         .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID")
         .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
         .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR)
         .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE"))
         .S SUCCESS=1
         K PARMS
         Q SUCCESS
+        ;
 RESEND(MSGIEN,ERROR)    ;
         ;This message will re-transmit an out-going message. It copies a copy the message, reusing all the original parameters. Then the message is requeued.
+        ;
         ;Input:
         ;  MSGIEN - the ien (file #778) of the message that is to be sent
         ;Output:
         ;  Function returns the ien of the message in file 778 on success, 0 on failure
         ;  ERROR (pass by reference, optional)an error message
+        ;
         N MSG,SUB,HDR
         I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
         I MSG("DIRECTION")'="OUT" S ERROR="MESSAGE IS NOT OUTGOING" Q 0
         I MSG("STATUS","LINK NAME")="" S ERROR="LINK NOT DEFINED" Q 0
         F SUB="ID","IEN","DT/TM","ACK BY","STATUS" S MSG(SUB)=""
         F SUB="PURGE" K MSG("STATUS",SUB)
         D GETSYS^HLOAPI(.MSG)
         I $$SAVEMSG^HLOF778(.MSG) D OUTQUE^HLOQUE(MSG("STATUS","LINK NAME"),$G(MSG("STATUS","PORT")),MSG("STATUS","QUEUE"),MSG("IEN")) Q +MSG("IEN")
         Q 0
+        ;
 SETPURGE(MSGIEN,TIME)   ;
         ;Resets the purge date/time.
         ;Input:
         ;   MSGIEN (required) ien of the message, file #778
         ;   TIME (optional) dt/time to set the purge time to, defaults to NOW
         ;Output:
         ;   Function returns 1 on success, 0 on failure
         N NODE,OLDTIME,HLDIR
         Q:'$G(MSGIEN) 0
         S NODE=$G(^HLB(MSGIEN,0))
         Q:NODE="" 0
         S OLDTIME=$P(NODE,"^",9)
         S:'$G(TIME) TIME=$$NOW^XLFDT
         S HLDIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
         K:OLDTIME ^HLB("AD",HLDIR,OLDTIME,MSGIEN)
         S $P(^HLB(MSGIEN,0),"^",9)=TIME
         S ^HLB("AD",HLDIR,TIME,MSGIEN)=""
         Q 1
+        ;
 REPROC(MSGIEN,ERROR)    ;
         ;This message will re-process an incoming message by placing it on an incoming queue. If successful the message will be purged.
+        ;
         ;Input:
         ;  MSGIEN - the ien (file #778) of the message that is to be processed
         ;Output:
         ;  Function returns 1 on success, 0 on failure
         ;  ERROR (pass by reference, optional) an error message
+        ;
         N MSG,HDR,ACTION,QUEUE,FROM
+        ;
         I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
         I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0
         M HDR=MSG("HDR")
         I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE")
         I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED"
         ;If this message references an earlier message, get the action specified by the original message
         I ACTION="",$G(MSG("ACK TO"))]"" D
         .N NODE,IEN
         .S IEN=$O(^HLB("B",$P(MSG("ACK TO"),"-"),0))
         .S:IEN NODE=$G(^HLB(IEN,0))
         .I ($P(NODE,"^",11)]"") S ACTION=$P(NODE,"^",10,11),QUEUE=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")
         I ACTION="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0
         S FROM=$S(MSG("HDR","SENDING FACILITY",2)]"":MSG("HDR","SENDING FACILITY",2),1:MSG("HDR","SENDING FACILITY",1))
         D INQUE^HLOQUE(FROM,QUEUE,MSGIEN,ACTION,1)
         Q 1
+        ;
 PROCNOW(MSGIEN,PURGE,ERROR)     ;
         ;This message will re-process an incoming message immediately.
+        ;
         ;Input:
         ;  MSGIEN - the ien (file #778) of the message that is to be processed
         ;Output:
         ;  Function returns 1 on success, 0 on failure
         ;  PURGE (optional) a date/time to purge the message
         ;  ERROR (pass by reference, optional) an error message
+        ;
         N MSG,HDR,ACTION,MCODE,HLMSGIEN
+        ;
         S ERROR=""
         I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
         I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0
         M HDR=MSG("HDR")
         I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE")
         I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" Q 0
         ;If this message references an earlier message, get the action specified by the original message
         I $G(ACTION)="",$G(MSG("ACK TO IEN")) S ACTION=$P($G(^HLB(+MSG("ACK TO IEN"),0)),"^",10,11) I $P(ACTION,"^",2)="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0
         D:$G(PURGE)
         .K:MSG("STATUS","PURGE") ^HLB("AD","IN",MSG("STATUS","PURGE"),MSGIEN)
         .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
         .S ^HLB("AD","IN",PURGE,MSGIEN)=""
         .I $G(MSG("ACK TO IEN")),$D(^HLB(MSG("ACK TO IEN"),0)) K ^HLB("AD","OUT",MSG("STATUS","PURGE"),MSG("ACK TO IEN")) S $P(^HLB(MSG("ACK TO IEN"),0),"^",9)=PURGE,^HLB("AD","OUT",PURGE,MSG("ACK TO IEN"))=""
         S HLMSGIEN=MSGIEN
         S $P(^HLB(MSGIEN,0),"^",19)=1
         S MCODE="D "_ACTION
         X MCODE
         Q 1
+HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;03/13/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,133,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+BATCHACK(HLMSTATE,PARMS,ACK,ERROR) ;Starts a batch message that is the response to a batch message. Individual acks are placed in the batch by calling $$ADDACK.
+ ;$$SENDACK^HLOAPI2 must be called when the batch of acks is complete. The return destination is determined automatically from the original message.
+ ;
+ ;Input:
+ ;  HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message
+ ;  PARMS (optional, pass by reference) These subscripts may be defined:
+ ;    "ACCEPT ACK RESPONSE")=<tag^routine> to call when the commit ack is received (optional)
+ ;    "ACCEPT ACK TYPE") = <AL,NE> (optional, defaults to AL)
+ ;    "COUNTRY") - a 3 character country code from the HL7 standard table (optional)
+ ;     "ENCODING CHARACTERS" - the 4 HL7 encoding characters (optional,defaults to "^~\&"
+ ;    "FAILURE RESPONSE" (optional) the <tag>^<routine> that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received.
+ ;     "FIELD SEPARATOR" - the field separator (optional, defaults to "|")
+ ;     "QUEUE" (optional) An application can name a private queue (a string under 20 characters, namespaced). The default is the name of the queue of the original message
+ ;     "SECURITY" - security information to include in the header segment, SEQ 8 (optional)
+ ;    "VERSION" - the HL7 Version ID (optional, defaults to 2.4)
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  PARMS - left undefined upon completion
+ ;  ACK (pass by reference, required) the batch acknowledgment message being built.
+ ;  ERROR (pass by reference) error message
+ N I,TOLINK,SUCCESS
+ S SUCCESS=0
+ ;
+ D
+ .N PORT
+ .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGMENT IS NOT IDENTIFIED" Q
+ .;if the return link can not be determined, the HL Logical Link file has a problem
+ .S TOLINK=$$ACKLINK^HLOAPI2(.HLMSTATE)
+ .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q
+ .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2)
+ .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK)
+ .;
+ .I $$NEWBATCH^HLOAPI(.PARMS,.ACK)  ;can't fail!
+ .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE")))
+ .S ACK("STATUS","PORT")=PORT
+ .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY"))
+ .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION"))
+ .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
+ .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
+ .S ACK("HDR","APP ACK TYPE")="NE"
+ .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL")
+ .S ACK("ACK TO")=$G(HLMSTATE("HDR","BATCH CONTROL ID"))
+ .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
+ .S ACK("ACK TO","BODY")=$G(HLMSTATE("BODY"))
+ .S ACK("STATUS","LINK NAME")=TOLINK
+ .S ACK("LINE COUNT")=0
+ .S SUCCESS=1
+ K PARMS
+ Q SUCCESS
+ ;
+ADDACK(ACK,PARMS,ERROR) ;This API adds an application acknowledgment to a batch
+ ;of acknowledgments that was started by calling $$BATCHACK.
+ ;The Default behavior is to return a general application ack.
+ ;The application may optionally specify the message
+ ;type and event and/or call $$ADDSEG^HLOAPI to add segments.
+ ;A generic MSA segment (components 1-3) will be added automatically
+ ;if the application doesn't call $$ADDSEG^HLOAPI to add an MSA segment
+ ;as the FIRST segment following the MSH segment.
+ ;$$SENDACK^HLOAPI2 must be called when the batch is complete.
+ ;
+ ;Input:
+ ;  ACK (pass by reference,required) the batch of acks that is being built
+ ;  PARMS (pass by reference) These subscripts may be defined:
+ ;    "ACK CODE" (required) MSA1[ {AA,AE,AR}
+ ;    "ERROR MESSAGE" (optional) MSA3, should be used only if AE or AR
+ ;    "EVENT" - 3 character event type (optional, defaults to the event code of the original message)
+ ;    "MESSAGE CONTROL ID" (required) this is the message control id of the original individual message within the batch which is being acknowledged
+ ;    "MESSAGE STRUCTURE" (optional)
+ ;    "MESSAGE TYPE" (optional, defaults to ACK)
+ ;    "SECURITY" (optional) security information to include in the header segment SEQ 8
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  ACK (pass by reference, required) The batch, updated with another ack
+ ;  PARMS  - left undefined when this function returns
+ ;  ERROR (pass by reference) error msg
+ ;
+ N SUB,SUCCESS
+ S SUCCESS=0
+ D
+ .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q
+ .;
+ .I $G(PARMS("MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q
+ .S SUB=""
+ .F  S SUB=$O(^HLB("AE",PARMS("MESSAGE CONTROL ID"),SUB)) Q:SUB=""  I $P(SUB,"^")=ACK("ACK TO","IEN"),$P(SUB,"^",2) S PARMS("ACK TO","IEN")=SUB Q
+ .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK")
+ .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK"
+ .S PARMS("EVENT")=$G(PARMS("EVENT"))
+ .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3)
+ .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID")
+ .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
+ .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR)
+ .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE"))
+ .S SUCCESS=1
+ K PARMS
+ Q SUCCESS
+ ;
+RESEND(MSGIEN,ERROR) ;
+ ;This message will re-transmit an out-going message. It copies a copy the message, reusing all the original parameters. Then the message is requeued.
+ ;
+ ;Input:
+ ;  MSGIEN - the ien (file #778) of the message that is to be sent
+ ;Output:
+ ;  Function returns the ien of the message in file 778 on success, 0 on failure
+ ;  ERROR (pass by reference, optional)an error message
+ ;
+ N MSG,SUB,HDR
+ I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
+ I MSG("DIRECTION")'="OUT" S ERROR="MESSAGE IS NOT OUTGOING" Q 0
+ I MSG("STATUS","LINK NAME")="" S ERROR="LINK NOT DEFINED" Q 0
+ F SUB="ID","IEN","DT/TM","ACK BY","STATUS" S MSG(SUB)=""
+ F SUB="PURGE" K MSG("STATUS",SUB)
+ D GETSYS^HLOAPI(.MSG)
+ I $$SAVEMSG^HLOF778(.MSG) D OUTQUE^HLOQUE(MSG("STATUS","LINK NAME"),$G(MSG("STATUS","PORT")),MSG("STATUS","QUEUE"),MSG("IEN")) Q +MSG("IEN")
+ Q 0
+ ;
+SETPURGE(MSGIEN,TIME) ;
+ ;Resets the purge date/time.
+ ;Input:
+ ;   MSGIEN (required) ien of the message, file #778
+ ;   TIME (optional) dt/time to set the purge time to, defaults to NOW
+ ;Output:
+ ;   Function returns 1 on success, 0 on failure
+ N NODE,OLDTIME,HLDIR
+ Q:'$G(MSGIEN) 0
+ S NODE=$G(^HLB(MSGIEN,0))
+ Q:NODE="" 0
+ S OLDTIME=$P(NODE,"^",9)
+ S:'$G(TIME) TIME=$$NOW^XLFDT
+ S HLDIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
+ K:OLDTIME ^HLB("AD",HLDIR,OLDTIME,MSGIEN)
+ S $P(^HLB(MSGIEN,0),"^",9)=TIME
+ S ^HLB("AD",HLDIR,TIME,MSGIEN)=""
+ Q 1
+ ;
+REPROC(MSGIEN,ERROR) ;
+ ;This message will re-process an incoming message by placing it on an incoming queue. If successful the message will be purged.
+ ;
+ ;Input:
+ ;  MSGIEN - the ien (file #778) of the message that is to be processed
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  ERROR (pass by reference, optional) an error message
+ ;
+ N MSG,HDR,ACTION,QUEUE,FROM
+ ;
+ I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
+ I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0
+ M HDR=MSG("HDR")
+ I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE")
+ I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED"
+ ;If this message references an earlier message, get the action specified by the original message
+ I ACTION="",$G(MSG("ACK TO"))]"" D
+ .N NODE,IEN
+ .S IEN=$O(^HLB("B",$P(MSG("ACK TO"),"-"),0))
+ .S:IEN NODE=$G(^HLB(IEN,0))
+ .I ($P(NODE,"^",11)]"") S ACTION=$P(NODE,"^",10,11),QUEUE=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")
+ I ACTION="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0
+ S FROM=$S(MSG("HDR","SENDING FACILITY",2)]"":MSG("HDR","SENDING FACILITY",2),1:MSG("HDR","SENDING FACILITY",1))
+ D INQUE^HLOQUE(FROM,QUEUE,MSGIEN,ACTION,1)
+ Q 1
+ ;
+PROCNOW(MSGIEN,PURGE,ERROR) ;
+ ;This message will re-process an incoming message immediately.
+ ;
+ ;Input:
+ ;  MSGIEN - the ien (file #778) of the message that is to be processed
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  PURGE (optional) a date/time to purge the message
+ ;  ERROR (pass by reference, optional) an error message
+ ;
+ N MSG,HDR,ACTION,MCODE,HLMSGIEN
+ ;
+ S ERROR=""
+ I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0
+ I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0
+ M HDR=MSG("HDR")
+ I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE")
+ I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" Q 0
+ ;If this message references an earlier message, get the action specified by the original message
+ I $G(ACTION)="",$G(MSG("ACK TO IEN")) S ACTION=$P($G(^HLB(+MSG("ACK TO IEN"),0)),"^",10,11) I $P(ACTION,"^",2)="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0
+ D:$G(PURGE)
+ .K:MSG("STATUS","PURGE") ^HLB("AD","IN",MSG("STATUS","PURGE"),MSGIEN)
+ .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
+ .S ^HLB("AD","IN",PURGE,MSGIEN)=""
+ .I $G(MSG("ACK TO IEN")),$D(^HLB(MSG("ACK TO IEN"),0)) K ^HLB("AD","OUT",MSG("STATUS","PURGE"),MSG("ACK TO IEN")) S $P(^HLB(MSG("ACK TO IEN"),0),"^",9)=PURGE,^HLB("AD","OUT",PURGE,MSG("ACK TO IEN"))=""
+ S HLMSGIEN=MSGIEN
+ S $P(^HLB(MSGIEN,0),"^",19)=1
+ S MCODE="D "_ACTION
+ X MCODE
+ Q 1

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m

-              r613
+              r623
+HLOAPP  ;ALB/CJM-HL7 -Application Registry ;07/09/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,132,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+GETIEN(NAME)    ;given the application name, it finds the ien.  Returns 0 on failure
+        Q:'$L($G(NAME)) 0
+        Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0))
+        ;
+ACTION(HEADER,ACTION,QUEUE)     ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
+        ;
+        ;Input:
+        ;  HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION"
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure
+        ;  ACTION (pass by reference) <tag>^<rtn>
+        ;  QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT"
+        ;
+        N IEN
+        S (ACTION,QUEUE)=""
+        S IEN=$$GETIEN(HEADER("RECEIVING APPLICATION"))
+        Q:'$G(IEN) 0
+        I $G(HEADER("SEGMENT TYPE"))="BHS" D
+        .S NODE=$G(^HLD(779.2,IEN,0))
+        .I $P(NODE,"^",5)]"" D
+        ..S ACTION=$P(NODE,"^",4,5)
+        .E  I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
+        .I $P(NODE,"^",8)]"" D
+        ..S QUEUE=$P(NODE,"^",8)
+        .E  I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+        E  I HEADER("SEGMENT TYPE")="MSH" D
+        .I HEADER("MESSAGE TYPE")'="",HEADER("EVENT")'="" D
+        ..N SUBIEN,NODE
+        ..;did the application specify an action for the particular version of this message?
+        ..I HEADER("VERSION")'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0))
+        ..;if not, look on the "C" index
+        ..S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0))
+        ..;
+        ..I SUBIEN D
+        ...S NODE=$G(^HLD(779.2,IEN,1,SUBIEN,0))
+        ...I $P(NODE,"^",5)]"" S ACTION=$P(NODE,"^",4,5)
+        ...I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+        ..I ACTION="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
+        ..I QUEUE="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+        I QUEUE="" S QUEUE="DEFAULT"
+        I ACTION="" Q 0
+        Q 1
+        ;
+RTRNLNK(APPNAME)        ;
+        ;given the name of a receiving application, this returns the return
+        ;link for application acks if one is provided.  Otherwise, return
+        ;acks are routed based on the information provide in the message hdr
+        ;
+        Q:(APPNAME="") ""
+        N IEN
+        S IEN=$$GETIEN(APPNAME)
+        Q:IEN $P($G(^HLD(779.2,IEN,0)),"^",2)
+        Q ""
+        ;
+RTRNPORT(APPNAME)       ;
+        ;Given the name of the sending application, IF the application has its
+        ;own listener, its port # is returned.  Application acks should be
+        ;returned using that port
+        Q:(APPNAME="") ""
+        N IEN,LINK
+        S IEN=$$GETIEN(APPNAME)
+        Q:'IEN ""
+        S LINK=$P($G(^HLD(779.2,IEN,0)),"^",9)
+        Q:'LINK ""
+        Q $$PORT^HLOTLNK(LINK)
+        ;
+ACTIVE(APP,MSGTYPE,EVENT,VERSION)       ;
+        ;Returns 1 if the message's INACTIVE flag has NOT been set.
+        ;
+        ;Input:
+        ;  APP (required) the name of the sending application
+        ;  MSGTYPE (required) 3 character HL7 message type
+        ;  EVENT (required) 3 character HL7 event
+        ;  VERSION (optional) HL7 version ID as it appears in the message header
+        ;Output:
+        ;  Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE.  It returns 0 otherwise.
+        ;
+        N IEN,ACTIVE,SUBIEN
+        S ACTIVE=1
+        S IEN=$$GETIEN($G(APP))
+        Q:'$G(IEN) ACTIVE
+        Q:$G(MSGTYPE)="" ACTIVE
+        Q:$G(EVENT)="" ACTIVE
+        ;did the application specify an action for the particular version of this message?
+        I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0))
+        ;if not, look on the "C" index
+        S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0))
+        ;
+        S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
+        Q ACTIVE
+        ;
+EXCEPT(APPNAME) ;
+        ;returns the exception handler (tag^routine) that should be invoked
+        ;when an applicaiton's messages are being sequenced and an app ack
+        ;is not timely received
+        ;
+        N IEN,RTN
+        S IEN=$$GETIEN($G(APPNAME))
+        I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11)
+        I $L($G(RTN))>1 Q RTN
+        Q "DEFAULT^HLOAPP"
+        ;
+DEFAULT ;default exception handler if the app doesn't specify one
+        S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))=""
+        Q
+        ;
+TIMEOUT(APPNAME)        ;
+        N IEN,TIME
+        S IEN=$$GETIEN($G(APPNAME))
+        I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12)
+        Q:'$G(TIME) 10
+        Q TIME
+HLOAPP ;ALB/CJM-HL7 -Application Registry ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132**;Oct 13, 1995;Build 6
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+GETIEN(NAME) ;given the application name, it finds the ien.  Returns 0 on failure
+ Q:'$L($G(NAME)) 0
+ N IEN,SUB
+ S SUB=$E(NAME,1,60)
+ S IEN=0
+ F  S IEN=$O(^HLD(779.2,"B",SUB,IEN)) Q:'IEN  Q:$P($G(^HLD(779.2,IEN,0)),"^")=NAME
+ Q +IEN
+ ;
+ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
+ ;
+ ;Input:
+ ;  HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION"
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  ACTION (pass by reference) <tag>^<rtn>
+ ;  QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT"
+ ;
+ N IEN
+ S (ACTION,QUEUE)=""
+ S IEN=$$GETIEN(HEADER("RECEIVING APPLICATION"))
+ Q:'$G(IEN) 0
+ I $G(HEADER("SEGMENT TYPE"))="BHS" D
+ .S NODE=$G(^HLD(779.2,IEN,0))
+ .I $P(NODE,"^",5)]"" D
+ ..S ACTION=$P(NODE,"^",4,5)
+ .E  I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
+ .I $P(NODE,"^",8)]"" D
+ ..S QUEUE=$P(NODE,"^",8)
+ .E  I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+ E  I HEADER("SEGMENT TYPE")="MSH" D
+ .I HEADER("MESSAGE TYPE")'="",HEADER("EVENT")'="" D
+ ..N SUBIEN,NODE
+ ..;did the application specify an action for the particular version of this message?
+ ..I HEADER("VERSION")'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0))
+ ..;if not, look on the "C" index
+ ..S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0))
+ ..;
+ ..I SUBIEN D
+ ...S NODE=$G(^HLD(779.2,IEN,1,SUBIEN,0))
+ ...I $P(NODE,"^",5)]"" S ACTION=$P(NODE,"^",4,5)
+ ...I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+ ..I ACTION="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
+ ..I QUEUE="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
+ I QUEUE="" S QUEUE="DEFAULT"
+ I ACTION="" Q 0
+ Q 1
+ ;
+RTRNLNK(APPNAME) ;
+ ;given the name of a receiving application, this returns the return
+ ;link for application acks if one is provided.  Otherwise, return
+ ;acks are routed based on the information provide in the message hdr
+ ;
+ Q:(APPNAME="") ""
+ N IEN
+ S IEN=$$GETIEN(APPNAME)
+ Q:IEN $P($G(^HLD(779.2,IEN,0)),"^",2)
+ Q ""
+ ;
+RTRNPORT(APPNAME) ;
+ ;Given the name of the sending application, IF the application has its
+ ;own listener, its port # is returned.  Application acks should be
+ ;returned using that port
+ Q:(APPNAME="") ""
+ N IEN,LINK
+ S IEN=$$GETIEN(APPNAME)
+ Q:'IEN ""
+ S LINK=$P($G(^HLD(779.2,IEN,0)),"^",9)
+ Q:'LINK ""
+ Q $$PORT^HLOTLNK(LINK)
+ ;
+ACTIVE(APP,MSGTYPE,EVENT,VERSION) ;
+ ;Returns 1 if the message's INACTIVE flag has NOT been set.
+ ;
+ ;Input:
+ ;  APP (required) the name of the sending application
+ ;  MSGTYPE (required) 3 character HL7 message type
+ ;  EVENT (required) 3 character HL7 event
+ ;  VERSION (optional) HL7 version ID as it appears in the message header
+ ;Output:
+ ;  Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE.  It returns 0 otherwise.
+ ;
+ N IEN,ACTIVE,SUBIEN
+ S ACTIVE=1
+ S IEN=$$GETIEN($G(APP))
+ Q:'$G(IEN) ACTIVE
+ Q:$G(MSGTYPE)="" ACTIVE
+ Q:$G(EVENT)="" ACTIVE
+ ;did the application specify an action for the particular version of this message?
+ I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0))
+ ;if not, look on the "C" index
+ S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0))
+ ;
+ S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
+ Q ACTIVE

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m

-              r613
+              r623
+HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;08/15/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;GET WORK function for the process running under the Process Manager
+GETWORK(QUE)    ;
+        ;Input:
+        ;  QUE - (pass by reference) These subscripts are used:
+        ;    ("LINK")  - <link name>_":"_<port> last obtained
+        ;    ("QUEUE") - name of the queue last obtained
+        ;Output:
+        ;  Function returns 1 if success, 0 if no more work
+        ;  QUE -  updated to identify next queue of messages to process.
+        ;    ("LINK") - <link name>_":"_<port>
+        ;    ("QUEUE") - the named queue on the link
+        ;    ("DOWN") - =1 means that the last OPEN attempt failed
+        ;
+        N LINK,QUEUE
+        S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE"))
+        I (LINK]""),(QUEUE]"") D
+        .L -^HLB("QUEUE","OUT",LINK,QUEUE)
+        .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q
+        .F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0  Q:$T
+        I (LINK]""),(QUEUE="") D
+        .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
+        ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
+        ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
+        I LINK="" D
+        .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
+        ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
+        ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
+        S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN"))
+        Q:$L(QUEUE) 1
+        D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
+        Q 0
+        ;
+FAILING(LINK)   ;
+        ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise
+        ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up
+        ;
+        N LASTTIME,SET
+        S LINK("DOWN")=0
+        S LASTTIME=$G(^HLB("QUEUE","OUT",LINK))
+        S SET=$S(LASTTIME]"":1,1:0)
+        I SET D
+        .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1
+        I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1
+        Q SET
+        ;
+LINKDOWN(HLCSTATE)      ;
+        D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
+        I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D
+        .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT")
+        .S ^HLB("QUEUE","OUT",TO)=$H
+        .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H
+        Q
+        ;
+ERROR   ;error trap
+        S $ETRAP="Q:$QUIT """" Q"
+        N HOUR
+        S HOUR=$E($$NOW^XLFDT,1,10)
+        S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+        D END
+        D LINKDOWN(.HLCSTATE)
+        ;
+        I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q
+        ;while debugging quit on all errors - this will return the process to the Process Manager error trap
+        I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
+        ;
+        ;don't log some common errors
+        I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+        .;
+        E  D
+        .;but do log all the others
+        .D ^%ZTER
+        ;
+        ;a lot of errors of the same type may indicate an endless loop
+        ;return to the Process Manager error trap
+        I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+        ;
+        ;resume execution of the process manager executing the client
+        D UNWIND^%ZTER
+        Q
+        ;
+DOWORK(QUEUE)   ;sends the messages on the queue
+        N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT"
+        N MSGIEN,DEQUE,SUCCESS,MSGCOUNT
+        S DEQUE=0
+        S SUCCESS=1
+        ;
+        I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q
+        ;
+        S (MSGCOUNT,MSGIEN)=0
+        F  S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN  D  Q:'SUCCESS  Q:MSGCOUNT>1000
+        .N UPDATE
+        .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1
+        .S SUCCESS=0
+        .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1
+        .Q:('SUCCESS)!('$D(UPDATE))
+        .D DEQUE(.UPDATE)
+        .S MSGCOUNT=MSGCOUNT+1
+        .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
+        .;
+        .;if the queue was on the down list, and not since shutdown, mark it as up, since a message has been successfully transmitted across it
+        .I $G(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK")),'$$IFSHUT^HLOTLNK(QUEUE("LINK")) S QUEUE("DOWN")=0,^HLB("QUEUE","OUT",QUEUE("LINK"))="" K ^HLTMP("FAILING LINKS",QUEUE("LINK"))
+        ;
+END     D DEQUE()
+        D SAVECNTS^HLOSTAT(.HLCSTATE)
+        Q
+CNNCTD(LINK)    ;
+        ;Connected to LINK?  HLCSTATE must be defined, LINK=<link name>:<port>
+        ;
+        I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1
+        Q 0
+        ;
+DEQUE(UPDATE)   ;
+        I $D(UPDATE) S DEQUE=DEQUE+1,DEQUE(+UPDATE)=$P(UPDATE,"^",2,99) S:$G(UPDATE("MSA"))]"" DEQUE(+UPDATE,"MSA")=UPDATE("MSA") S:$G(UPDATE("ACTION"))]"" DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION")
+        I '$D(UPDATE)!(DEQUE>15) D
+        .N MSGIEN S MSGIEN=0
+        .F  S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN  D
+        ..N NODE,TIME
+        ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN)
+        ..S TIME=$P(DEQUE(MSGIEN),"^")
+        ..Q:'TIME
+        ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99)
+        ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE
+        ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA")
+        ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION")
+        .K DEQUE S DEQUE=0
+        Q
+        ;
+TRANSMIT(HLCSTATE,MSGIEN,UPDATE)        ;
+        ;Transmits a single message and if a commit ack was requested reads it.  Updates file 778 with the result.  Queues for the infiler the application accept action if one was requested.
+        ;Input:
+        ;   HLCSTATE (pass by reference)
+        ;   MSGIEN - ien, file 778, of message to be transmitted
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure
+        ;  UPDATE - (pass by reference) to contain updates needed for message
+        ;
+        N HLMSTATE,MSA,HDR,SUCCESS
+        ;
+        S SUCCESS=0
+        S HLCSTATE("ATTEMPT")=0
+        ;
+        ;start saving updates needed after the message is transmitted
+        S UPDATE=MSGIEN
+        Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1  ;returns 1 so the message will be removed from the queue
+        I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1  ;the message was already transmitted
+        ;
+        S UPDATE=UPDATE_"^"_$$NOW^XLFDT
+RETRY   D
+        .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1
+        .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED")
+        .;
+        .;try to send the message
+        .;
+        .;
+        .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
+        .;does the message need an accept ack?
+        .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D
+        ..N FS
+        ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA)
+        ..;does the MSA refer to the correct control id?
+        ..S FS=$E(HDR(1),4)
+        ..Q:$P(MSA,FS,3)'=HLMSTATE("ID")
+        ..N ACKID,ACKCODE
+        ..S ACKCODE=$P(MSA,FS,2)
+        ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6))
+        ..S $P(UPDATE,"^",5)=1
+        ..S UPDATE("MSA")=ACKID_"^"_MSA
+        ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=2
+        ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
+        ..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
+        ..;
+        ..;if it's from a sequence queue, timestamp the queue
+        ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
+        ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
+        ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
+        ...I ACKCODE="CA" S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($P(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))) L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
+        ...;if the message wasn't accepted, need to notify without waiting
+        ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2)
+        ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
+        ..;
+        ..;does the app need notification of accept ack?
+        ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
+        ..;
+        ..S SUCCESS=1
+        .E  D  ;accept ack wasn't requested
+        ..S SUCCESS=1
+        ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1)
+        ;
+        I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY
+        I SUCCESS D
+        .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
+        .;if this is an ack to a message need to purge the original message, so store its ien with the purge date
+        .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN")
+        I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE)
+        Q SUCCESS
+HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;GET WORK function for the process running under the Process Manager
+GETWORK(QUE) ;
+ ;Input:
+ ;  QUE - (pass by reference) These subscripts are used:
+ ;    ("LINK")  - <link name>_":"_<port> last obtained
+ ;    ("QUEUE") - name of the queue last obtained
+ ;Output:
+ ;  Function returns 1 if success, 0 if no more work
+ ;  QUE -  updated to identify next queue of messages to process.
+ ;    ("LINK") - <link name>_":"_<port>
+ ;    ("QUEUE") - the named queue on the link
+ ;    ("DOWN") - =1 means that the last OPEN attempt failed
+ ;
+ N LINK,QUEUE
+ S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE"))
+ I (LINK]""),(QUEUE]"") D
+ .L -^HLB("QUEUE","OUT",LINK,QUEUE)
+ .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q
+ .F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0  Q:$T
+ I (LINK]""),(QUEUE="") D
+ .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
+ ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
+ ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
+ I LINK="" D
+ .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
+ ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
+ ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
+ S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN"))
+ Q:$L(QUEUE) 1
+ D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
+ Q 0
+ ;
+FAILING(LINK) ;
+ ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise
+ ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up
+ ;
+ N LASTTIME,SET
+ S LINK("DOWN")=0
+ S LASTTIME=$G(^HLB("QUEUE","OUT",LINK))
+ S SET=$S(LASTTIME]"":1,1:0)
+ I SET D
+ .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1
+ I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1
+ Q SET
+ ;
+LINKDOWN(HLCSTATE) ;
+ D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
+ I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D
+ .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT")
+ .S ^HLB("QUEUE","OUT",TO)=$H
+ .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H
+ Q
+ ;
+ERROR ;error trap
+ S $ETRAP="Q:$QUIT """" Q"
+ N HOUR
+ S HOUR=$E($$NOW^XLFDT,1,10)
+ S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+ D END
+ D LINKDOWN(.HLCSTATE)
+ ;
+ I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q
+ ;while debugging quit on all errors - this will return the process to the Process Manager error trap
+ I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
+ ;
+ ;don't log some common errors
+ I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+ .;
+ E  D
+ .;but do log all the others
+ .D ^%ZTER
+ ;
+ ;a lot of errors of the same type may indicate an endless loop
+ ;return to the Process Manager error trap
+ I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+ ;
+ ;resume execution of the process manager executing the client
+ D UNWIND^%ZTER
+ Q
+ ;
+DOWORK(QUEUE) ;sends the messages on the queue
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT"
+ N MSGIEN,DEQUE,SUCCESS,MSGCOUNT
+ S DEQUE=0
+ S SUCCESS=1
+ ;
+ I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q
+ ;
+ S (MSGCOUNT,MSGIEN)=0
+ F  S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN  D  Q:'SUCCESS  Q:MSGCOUNT>1000
+ .N UPDATE
+ .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1
+ .S SUCCESS=0
+ .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1
+ .Q:('SUCCESS)!('$D(UPDATE))
+ .D DEQUE(.UPDATE)
+ .S MSGCOUNT=MSGCOUNT+1
+ .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
+ .;
+ .;if the queue was on the down list, and not since shutdown, mark it as up, since a message has been successfully transmitted across it
+ .I $G(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK")),'$$IFSHUT^HLOTLNK(QUEUE("LINK")) S QUEUE("DOWN")=0,^HLB("QUEUE","OUT",QUEUE("LINK"))="" K ^HLTMP("FAILING LINKS",QUEUE("LINK"))
+ ;
+END D DEQUE()
+ D SAVECNTS^HLOSTAT(.HLCSTATE)
+ Q
+CNNCTD(LINK) ;
+ ;Connected to LINK?  HLCSTATE must be defined, LINK=<link name>:<port>
+ ;
+ I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1
+ Q 0
+ ;
+DEQUE(UPDATE) ;
+ I $D(UPDATE) S DEQUE=DEQUE+1,DEQUE(+UPDATE)=$P(UPDATE,"^",2,99) S:$G(UPDATE("MSA"))]"" DEQUE(+UPDATE,"MSA")=UPDATE("MSA") S:$G(UPDATE("ACTION"))]"" DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION")
+ I '$D(UPDATE)!(DEQUE>15) D
+ .N MSGIEN S MSGIEN=0
+ .F  S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN  D
+ ..N NODE,TIME
+ ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN)
+ ..S TIME=$P(DEQUE(MSGIEN),"^")
+ ..Q:'TIME
+ ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99)
+ ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE
+ ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA")
+ ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION")
+ .K DEQUE S DEQUE=0
+ Q
+ ;
+TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ;
+ ;Transmits a single message and if a commit ack was requested reads it.  Updates file 778 with the result.  Queues for the infiler the application accept action if one was requested.
+ ;Input:
+ ;   HLCSTATE (pass by reference)
+ ;   MSGIEN - ien, file 778, of message to be transmitted
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  UPDATE - (pass by reference) to contain updates needed for message
+ ;
+ N HLMSTATE,MSA,HDR,SUCCESS
+ ;
+ S SUCCESS=0
+ S HLCSTATE("ATTEMPT")=0
+ ;
+ ;start saving updates needed after the message is transmitted
+ S UPDATE=MSGIEN
+ Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1  ;returns 1 so the message will be removed from the queue
+ I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1  ;the message was already transmitted
+ ;
+ S UPDATE=UPDATE_"^"_$$NOW^XLFDT
+RETRY D
+ .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1
+ .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED")
+ .;
+ .;try to send the message
+ .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
+ .;does the message need an accept ack?
+ .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D
+ ..N FS
+ ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA)
+ ..;does the MSA refer to the correct control id?
+ ..S FS=$E(HDR(1),4)
+ ..Q:$P(MSA,FS,3)'=HLMSTATE("ID")
+ ..N ACKID,ACKCODE
+ ..S ACKCODE=$P(MSA,FS,2)
+ ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6))
+ ..S $P(UPDATE,"^",5)=1
+ ..S UPDATE("MSA")=ACKID_"^"_MSA
+ ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2
+ ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
+ ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
+ ..;
+ ..;did the app request notification of accept ack?
+ ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
+ ..S SUCCESS=1
+ .E  D  ;accept ack wasn't requested
+ ..S SUCCESS=1
+ ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1)
+ ;
+ I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY
+ I SUCCESS D
+ .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
+ .;if this is an ack to a message need to purge the original message, so store its ien with the purge date
+ .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN")
+ I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE)
+ Q SUCCESS

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m

-              r613
+              r623
 HLOCLNT1        ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;
 WRITEMSG(HLCSTATE,HLMSTATE)     ;
         ;Description:  This function uses the services offered by the transport layer to send a message over an open communication channel.
+        ;
         ;Input:
         ;  HLCSTATE (pass by reference, required) Defines the LLP & its state
         ;  HLMSTATE (pass by reference, required) The message
         ;Output:
         ;  Function returns 1 on success, 0 on failure
+        ;
         N SEG,QUIT,HDR
         S QUIT=0
         Q:'$G(HLMSTATE("IEN")) 0
         S HDR(1)=HLMSTATE("HDR",1),HDR(2)=HLMSTATE("HDR",2)
         Q:'$$WRITEHDR^HLOT(.HLCSTATE,.HDR) 0
         I HLMSTATE("BATCH") D
         .N LAST S LAST=0
         .S HLMSTATE("BATCH","CURRENT MESSAGE")=0
         .F  Q:'$$NEXTMSG^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
         ..S LAST=HLMSTATE("BATCH","CURRENT MESSAGE")
         ..I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q
         ..F  Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
         ...I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q
         .K SEG S SEG(1)="BTS"_HLMSTATE("HDR","FIELD SEPARATOR")_LAST
         .S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1
         E  D
         .F  Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
         ..S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1
         S:'$$ENDMSG^HLOT(.HLCSTATE) QUIT=1
         Q 'QUIT
+        ;
 READACK(HLCSTATE,HDR,MSA)       ;
         ;Description:  This function uses the services offered by the transport layer to read an accept ack.
+        ;
         ;Input:
         ;  HLCSTATE (pass by reference, required) Defines the communication channel and its state.
         ;Output:
         ;  Function returns 1 on success, 0 on failure
         ;  HDR (pass by reference) the message header:
         ;   HDR(1) is components 1-6
         ;   HDR(2) is components 7-end
         ;  MSA (pass by reference) the MSA segment as an unsubscripted variable
+        ;
         N SEG
         K HDR,MSA,MAX,I
         S MAX=HLCSTATE("SYSTEM","MAXSTRING")-40 ;MAX is the maximum that can be safely stored on a node, leaving room for the other fields stored with MSA seg
         Q:'$$READHDR^HLOT(.HLCSTATE,.HDR) 0
         F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
         .I $E($E(SEG(1),1,3)_$E($G(SEG(2)),1,3),1,3)="MSA" D
         ..S MSA=""
         ..F I=1:1 Q:'$D(SEG(I))  S MSA=MSA_$S((MAX-$L(MSA))<1:"",1:$E(SEG(I),1,MAX))
         I $D(MSA),HLCSTATE("MESSAGE ENDED") D  Q 1
         .D SPLITHDR^HLOSRVR1(.HDR)
         .S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1
         Q 0
+        ;
 CONNECT(LINK,PORT,TIMEOUT,HLCSTATE)     ;
         ;sets up HLCSTATE() and opens a client connection
         ;Input:
         ;  LINK - name of the link to connect to
         ;  PORT (optional) port # to connect to, defaults to that specified by the link
         ;  TIMEOUT (optional) specifies the open timeout in seconds, defaults to 30
         ;Output:
         ;   HLCSTATE - array to hold the connection state
+        ;
         I $G(HLCSTATE("CONNECTED")) D  Q:HLCSTATE("CONNECTED")
         .I $G(HLCSTATE("LINK","NAME"))]"",($G(HLCSTATE("LINK","NAME"))'=LINK) D CLOSE^HLOT(.HLCSTATE) Q
         .I $G(HLCSTATE("LINK","NAME"))]"",$G(PORT),($G(HLCSTATE("LINK","PORT"))'=PORT) D CLOSE^HLOT(.HLCSTATE) Q
         .I (HLCSTATE("SYSTEM","OS")="CACHE") D  Q
         ..U HLCSTATE("DEVICE") S HLCSTATE("CONNECTED")=($ZA\8192#2)
         ..I 'HLCSTATE("CONNECTED") D CLOSE^HLOT(.HLCSTATE)
         .;D CLOSE^HLOT(.HLCSTATE)
         K HLCSTATE
         N ARY,NODE
         I '$$GETLINK^HLOTLNK(LINK,.ARY) S HLCSTATE("LINK","NAME")=LINK,HLCSTATE("LINK","PORT")=$G(PORT) D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
         M HLCSTATE("LINK")=ARY
         I HLCSTATE("LINK","SHUTDOWN") S HLCSTATE("CONNECTED")=0 D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
         ;overlay the port if supplied from the queue
         S:$G(PORT) HLCSTATE("LINK","PORT")=PORT
         S HLCSTATE("READ TIMEOUT")=20
         S HLCSTATE("OPEN TIMEOUT")=$S($G(TIMEOUT):TIMEOUT,1:30)
         S HLCSTATE("COUNTS")=0
         S HLCSTATE("READ")="" ;where the reads are stored
+        ;
         ;HLCSTATE("BUFFER",<seg>,<line>) serves as a write buffer so that a lot can be written all at once
         S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of BYTES in buffer
         S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
+        ;
         S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
         S NODE=^%ZOSF("OS")
         S HLCSTATE("SERVER")=0
         S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
         I HLCSTATE("SYSTEM","OS")="" D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
+        D
         .N SYS
         .D SYSPARMS^HLOSITE(.SYS)
         .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
         .S HLCSTATE("SYSTEM","MAXSTRING")=SYS("MAXSTRING")
         .S HLCSTATE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE")
         .S HLCSTATE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE")
         I HLCSTATE("LINK","LLP")="TCP" D
         .S HLCSTATE("OPEN")="OPEN^HLOTCP"
         E  ;no other LLP implemented
         D OPEN^HLOT(.HLCSTATE)
+        ;
         ;mark the failure time for the link so other processes know not to try for a while
         I 'HLCSTATE("CONNECTED") D LINKDOWN^HLOCLNT(.HLCSTATE)
         Q HLCSTATE("CONNECTED")
+        ;
 BADMSGS(WORK)   ;
         ;finds messages that won't transmit after 8 hours of trying and takes them off the outgoing queue
         N LINK
         S LINK=""
         F  S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK=""  D
         .N TIME,QUE,COUNT
         .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME=""
         .Q:$$HDIFF^XLFDT($H,TIME,2)<28800  ;8 hours
         .Q:'$$IFOPEN^HLOUSR1(LINK)
         .L +^HLB("QUEUE","OUT",LINK):0
         .S QUE=""
         .F  S QUE=$O(^HLB("QUEUE","OUT",LINK,QUE)) Q:QUE=""  D
         ..N MSG S MSG=0
         ..S MSG=$O(^HLB("QUEUE","OUT",LINK,QUE,MSG))
         ..Q:'MSG
         ..S COUNT=$G(^HLB(MSG,"TRIES"))
         ..I COUNT>20 D
         ...N NODE0,NODE1,NODE2,TIME,RAPP,SAPP,FS,CS,ACTION,MTYPE,EVENT
         ...S NODE0=$G(^HLB(MSG,0))
         ...Q:'$P(NODE0,"^",2)
         ...S TIME=$$NOW^XLFDT
         ...S NODE1=$G(^HLB(MSG,1))
         ...S NODE2=$G(^HLB(MSG,2))
         ...S FS=$E(NODE1,4)
         ...Q:FS=""
         ...S CS=$E(NODE1,5)
         ...Q:CS=""
         ...S SAPP=$P(NODE1,FS,3)
         ...S:SAPP="" SAPP="UNKNOWN"
         ...S RAPP=$P(NODE1,FS,5)
         ...S MTYPE=$P($P(NODE2,FS,4),CS)
         ...S EVENT=$P($P(NODE2,FS,4),CS,2)
         ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS"
         ...S $P(^HLB(MSG,0),"^",20)="TF"
         ...S ^HLB("ERRORS",RAPP,TIME,MSG)=""
         ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT)
         ...S ACTION=$P(NODE0,"^",14,15)
         ...I ACTION'="^",ACTION]"" D INQUE^HLOQUE(LINK,QUE,MSG,ACTION,1)
         ...D DEQUE^HLOQUE(LINK,QUE,"OUT",MSG)
         .L -^HLB("QUEUE","OUT",LINK)
+        Q
+HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;
+WRITEMSG(HLCSTATE,HLMSTATE) ;
+ ;Description:  This function uses the services offered by the transport layer to send a message over an open communication channel.
+ ;
+ ;Input:
+ ;  HLCSTATE (pass by reference, required) Defines the LLP & its state
+ ;  HLMSTATE (pass by reference, required) The message
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;
+ N SEG,QUIT,HDR
+ S QUIT=0
+ Q:'$G(HLMSTATE("IEN")) 0
+ S HDR(1)=HLMSTATE("HDR",1),HDR(2)=HLMSTATE("HDR",2)
+ Q:'$$WRITEHDR^HLOT(.HLCSTATE,.HDR) 0
+ I HLMSTATE("BATCH") D
+ .N LAST S LAST=0
+ .S HLMSTATE("BATCH","CURRENT MESSAGE")=0
+ .F  Q:'$$NEXTMSG^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
+ ..S LAST=HLMSTATE("BATCH","CURRENT MESSAGE")
+ ..I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q
+ ..F  Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
+ ...I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q
+ .K SEG S SEG(1)="BTS"_HLMSTATE("HDR","FIELD SEPARATOR")_LAST
+ .S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1
+ E  D
+ .F  Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG)  D  Q:QUIT
+ ..S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1
+ S:'$$ENDMSG^HLOT(.HLCSTATE) QUIT=1
+ Q 'QUIT
+ ;
+READACK(HLCSTATE,HDR,MSA) ;
+ ;Description:  This function uses the services offered by the transport layer to read an accept ack.
+ ;
+ ;Input:
+ ;  HLCSTATE (pass by reference, required) Defines the communication channel and its state.
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  HDR (pass by reference) the message header:
+ ;   HDR(1) is components 1-6
+ ;   HDR(2) is components 7-end
+ ;  MSA (pass by reference) the MSA segment as an unsubscripted variable
+ ;
+ N SEG
+ K HDR,MSA,MAX,I
+ S MAX=HLCSTATE("SYSTEM","MAXSTRING")-40 ;MAX is the maximum that can be safely stored on a node, leaving room for the other fields stored with MSA seg
+ Q:'$$READHDR^HLOT(.HLCSTATE,.HDR) 0
+ F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
+ .I $E($E(SEG(1),1,3)_$E($G(SEG(2)),1,3),1,3)="MSA" D
+ ..S MSA=""
+ ..F I=1:1 Q:'$D(SEG(I))  S MSA=MSA_$S((MAX-$L(MSA))<1:"",1:$E(SEG(I),1,MAX))
+ I $D(MSA),HLCSTATE("MESSAGE ENDED") D  Q 1
+ .D SPLITHDR^HLOSRVR1(.HDR)
+ .S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1
+ Q 0
+ ;
+CONNECT(LINK,PORT,TIMEOUT,HLCSTATE) ;
+ ;sets up HLCSTATE() and opens a client connection
+ ;Input:
+ ;  LINK - name of the link to connect to
+ ;  PORT (optional) port # to connect to, defaults to that specified by the link
+ ;  TIMEOUT (optional) specifies the open timeout in seconds, defaults to 30
+ ;Output:
+ ;   HLCSTATE - array to hold the connection state
+ ;
+ I $G(HLCSTATE("CONNECTED")) D  Q:HLCSTATE("CONNECTED")
+ .I $G(HLCSTATE("LINK","NAME"))]"",($G(HLCSTATE("LINK","NAME"))'=LINK) D CLOSE^HLOT(.HLCSTATE) Q
+ .I $G(HLCSTATE("LINK","NAME"))]"",$G(PORT),($G(HLCSTATE("LINK","PORT"))'=PORT) D CLOSE^HLOT(.HLCSTATE) Q
+ .I (HLCSTATE("SYSTEM","OS")="CACHE") D  Q
+ ..U HLCSTATE("DEVICE") S HLCSTATE("CONNECTED")=($ZA\8192#2)
+ ..I 'HLCSTATE("CONNECTED") D CLOSE^HLOT(.HLCSTATE)
+ .;D CLOSE^HLOT(.HLCSTATE)
+ K HLCSTATE
+ N ARY,NODE
+ I '$$GETLINK^HLOTLNK(LINK,.ARY) S HLCSTATE("LINK","NAME")=LINK,HLCSTATE("LINK","PORT")=$G(PORT) D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
+ M HLCSTATE("LINK")=ARY
+ I HLCSTATE("LINK","SHUTDOWN") S HLCSTATE("CONNECTED")=0 D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
+ ;overlay the port if supplied from the queue
+ S:$G(PORT) HLCSTATE("LINK","PORT")=PORT
+ S HLCSTATE("READ TIMEOUT")=20
+ S HLCSTATE("OPEN TIMEOUT")=$S($G(TIMEOUT):TIMEOUT,1:30)
+ S HLCSTATE("COUNTS")=0
+ S HLCSTATE("READ")="" ;where the reads are stored
+ ;
+ ;HLCSTATE("BUFFER",<seg>,<line>) serves as a write buffer so that a lot can be written all at once
+ S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of BYTES in buffer
+ S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
+ ;
+ S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
+ S NODE=^%ZOSF("OS")
+ S HLCSTATE("SERVER")=0
+ S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
+ I HLCSTATE("SYSTEM","OS")="" D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0
+ D
+ .N SYS
+ .D SYSPARMS^HLOSITE(.SYS)
+ .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
+ .S HLCSTATE("SYSTEM","MAXSTRING")=SYS("MAXSTRING")
+ .S HLCSTATE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE")
+ .S HLCSTATE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE")
+ I HLCSTATE("LINK","LLP")="TCP" D
+ .S HLCSTATE("OPEN")="OPEN^HLOTCP"
+ E  ;no other LLP implemented
+ D OPEN^HLOT(.HLCSTATE)
+ ;
+ ;mark the failure time for the link so other processes know not to try for a while
+ I 'HLCSTATE("CONNECTED") D LINKDOWN^HLOCLNT(.HLCSTATE)
+ Q HLCSTATE("CONNECTED")
+ ;
+BADMSGS(WORK) ;
+ ;finds messages that won't transmit after 8 hours of trying and takes them off the outgoing queue
+ N LINK
+ S LINK=""
+ F  S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK=""  D
+ .N TIME,QUE,COUNT
+ .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME=""
+ .Q:$$HDIFF^XLFDT($H,TIME,2)<28800  ;8 hours
+ .Q:'$$IFOPEN^HLOUSR1(LINK)
+ .L +^HLB("QUEUE","OUT",LINK):0
+ .S QUE=""
+ .F  S QUE=$O(^HLB("QUEUE","OUT",LINK,QUE)) Q:QUE=""  D
+ ..N MSG S MSG=0
+ ..S MSG=$O(^HLB("QUEUE","OUT",LINK,QUE,MSG))
+ ..Q:'MSG
+ ..S COUNT=$G(^HLB(MSG,"TRIES"))
+ ..I COUNT>20 D
+ ...N NODE0,NODE1,NODE2,TIME,RAPP,SAPP,FS,CS,ACTION,MTYPE,EVENT
+ ...S NODE0=$G(^HLB(MSG,0))
+ ...Q:'$P(NODE0,"^",2)
+ ...S TIME=$$NOW^XLFDT
+ ...S NODE1=$G(^HLB(MSG,1))
+ ...S NODE2=$G(^HLB(MSG,2))
+ ...S FS=$E(NODE1,4)
+ ...Q:FS=""
+ ...S CS=$E(NODE1,5)
+ ...Q:CS=""
+ ...S SAPP=$P(NODE1,FS,3)
+ ...S:SAPP="" SAPP="UNKNOWN"
+ ...S RAPP=$P(NODE1,FS,5)
+ ...S MTYPE=$P($P(NODE2,FS,4),CS)
+ ...S EVENT=$P($P(NODE2,FS,4),CS,2)
+ ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS"
+ ...S $P(^HLB(MSG,0),"^",20)="TF"
+ ...S ^HLB("ERRORS","TF",SAPP,TIME,MSG)=""
+ ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT)
+ ...S ACTION=$P(NODE0,"^",14,15)
+ ...I ACTION'="^",ACTION]"" D INQUE^HLOQUE(LINK,QUE,MSG,ACTION,1)
+ ...D DEQUE^HLOQUE(LINK,QUE,"OUT",MSG)
+ .L -^HLB("QUEUE","OUT",LINK)
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m

-              r613
+              r623
+HLOCLNT2        ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+GETWORK(WORK)   ;
+        ;
+        N OLD,DOLLARJ,SUCCESS,NOW
+        S SUCCESS=0
+        S NOW=$$NOW^XLFDT
+        S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
+        F  S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ=""  D  Q:SUCCESS
+        .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
+        .Q:'$T
+        .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
+        .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
+        .S SUCCESS=1
+        ;
+        I OLD'="",'SUCCESS F  S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ=""  Q:DOLLARJ>OLD  D  Q:SUCCESS
+        .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
+        .Q:'$T
+        .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
+        .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
+        .S SUCCESS=1
+        S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
+        Q $S($L(WORK("DOLLARJ")):1,1:0)
+        ;
+DOWORK(WORK)    ;
+        ;
+        N DOLLARJ,TIME,IEN,PARMS,SYSTEM
+        S TIME=""
+        S DOLLARJ=WORK("DOLLARJ")
+        D SYSPARMS^HLOSITE(.SYSTEM)
+        F  S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME)) Q:TIME=""  Q:$$FMDIFF^XLFDT(WORK("NOW"),TIME,2)<2  D
+        .S IEN=0
+        .F  S IEN=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) Q:'IEN  D
+        ..N NODE
+        ..S NODE=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN))
+        ..S PARMS("LINK")=$P(NODE,"^")
+        ..S PARMS("QUEUE")=$P(NODE,"^",2)
+        ..S PARMS("STATUS")=$P(NODE,"^",3)
+        ..S PARMS("PURGE TYPE")=$P(NODE,"^",4)
+        ..S PARMS("ACK TO IEN")=+$P($P(NODE,"^",4),"-",2)
+        ..S PARMS("ACCEPT ACK")=$P(NODE,"^",5)
+        ..S PARMS("RECEIVING APP")=$P(NODE,"^",6)
+        ..S:PARMS("RECEIVING APP")="" PARMS("RECEIVING APP")="UNKNOWN RECEIVING APPLICATION"
+        ..S PARMS("MSA")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"MSA"))
+        ..S PARMS("ACTION")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"ACTION"))
+        ..D UPDATE(IEN,TIME,.PARMS)
+        ..K ^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)
+        L -^HLTMP("CLIENT UPDATES",DOLLARJ)
+        Q
+        ;
+UPDATE(MSGIEN,TIME,PARMS)       ;
+        S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS")
+        I PARMS("STATUS")="ER" D
+        .S ^HLB("ERRORS",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
+        .D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
+        S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK")
+        S $P(^HLB(MSGIEN,0),"^",16)=TIME
+        S:PARMS("MSA")]"" ^HLB(MSGIEN,4)=TIME_"^"_PARMS("MSA")
+        I PARMS("PURGE TYPE"),PARMS("ACTION")="" D
+        .;don't set purge if going on the infiler - let infiler do it
+        .N PTIME
+        .S:(PARMS("PURGE TYPE")=2) PTIME=$$FMADD^XLFDT(TIME,SYSTEM("ERROR PURGE")) ;error purge is in days
+        .S:(PARMS("PURGE TYPE")'=2) PTIME=$$FMADD^XLFDT(TIME,,SYSTEM("NORMAL PURGE")) ;normal purge is in hours
+        .S $P(^HLB(MSGIEN,0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,MSGIEN)=""
+        .I PARMS("ACK TO IEN"),$D(^HLB(PARMS("ACK TO IEN"),0)) S $P(^HLB(PARMS("ACK TO IEN"),0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,PARMS("ACK TO IEN"))=""
+        D:PARMS("ACTION")]""
+        .N PURGE
+        .S PURGE=$S(PARMS("PURGE TYPE"):1,1:0)
+        .S:PARMS("ACK TO IEN") PURGE("ACKTOIEN")=PARMS("ACK TO IEN")
+        .D INQUE^HLOQUE(PARMS("LINK"),PARMS("QUEUE"),MSGIEN,PARMS("ACTION"),.PURGE)
+        Q
+        ;
+GETMSG(IEN,MSG) ;
+        ;
+        ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below.
+        ;Input:
+        ;  IEN - the ien of the message in file 778
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure
+        ;  MSG (pass by reference, required) These are the subscripts returned:
+        ;    "ACCEPT ACK RESPONSE" - if the sending app requested notification of the accept ack, this is the routine to perform
+        ;    "ACKTOIEN" - if this is an app ack to a message not in a batch, this is the ien of the original message
+        ;    "BATCH"  = 1 if this is a batch message, 0  if not
+        ;    "CURRENT MESSAGE" - defined only for batch messages -  a counterused during building and parsing messages to indicate the current message.  It will be set to 0 initially.
+        ;    "BODY" - ptr to file 778 which contains the body of the message.
+        ;    "LINE COUNT" -  a counter used during writing of the
+        ;     messages to indicate the current line. For
+        ;     batch messages where each message within the batch is stored
+        ;     separately, this field indicates the position within the current
+        ;     individual message
+        ;    "HDR" at these lower subscripts:
+        ;       1    - components 1-6
+        ;       2    - components 7-end
+        ;       "ACCEPT ACK TYPE" = "AL" or "NE"
+        ;       "APP ACK TYPE" = "AL" or "NE"
+        ;       "MESSAGE CONTROL ID" - defined if NOT batch
+        ;       "BATCH CONTROL ID" - defined if batch
+        ;
+        ;    "ID" - message id from the header
+        ;    "IEN" - ien, file 778
+        ;    "STATUS","SEQUENCE QUEUE")=name of the sequence queue (optional)
+        ;
+        K MSG
+        Q:'$G(IEN) 0
+        N NODE,FS,CS,REP,SUBCOMP,ESCAPE
+        S MSG("IEN")=IEN
+        S NODE=$G(^HLB(IEN,0))
+        S MSG("BODY")=$P(NODE,"^",2)
+        S MSG("ID")=$P(NODE,"^")
+        Q:'MSG("BODY") 0
+        S MSG("STATUS","ACCEPTED")=$P(NODE,"^",17)
+        S MSG("DT/TM")=$P(NODE,"^",16)
+        S MSG("STATUS","QUEUE")=$P(NODE,"^",6)
+        I MSG("STATUS","QUEUE")="" S MSG("STATUS","QUEUE")="DEFAULT"
+        S MSG("ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13)
+        I MSG("ACCEPT ACK RESPONSE")="^" S MSG("ACCEPT ACK RESPONSE")=""
+        ;
+        S MSG("BATCH")=+$P($G(^HLA(MSG("BODY"),0)),"^",2)
+        I MSG("BATCH") D
+        .S MSG("BATCH","CURRENT MESSAGE")=0
+        E  D
+        .N ACKTO
+        .S ACKTO=$P(NODE,"^",3)
+        .I ACKTO]"" S ACKTO=$$ACKTOIEN^HLOMSG1(MSG("ID"),ACKTO)
+        .I ACKTO,+ACKTO=ACKTO S MSG("ACK TO IEN")=ACKTO
+        S MSG("LINE COUNT")=0
+        S MSG("HDR",1)=$G(^HLB(IEN,1))
+        S MSG("HDR",2)=$G(^HLB(IEN,2))
+        S FS=$E(MSG("HDR",1),4)
+        S CS=$E(MSG("HDR",1),5)
+        S REP=$E(MSG("HDR",1),6)
+        S ESCAPE=$E(MSG("HDR",1),7)
+        S SUBCOMP=$E(MSG("HDR",1),8)
+        S MSG("HDR","FIELD SEPARATOR")=FS
+        S MSG("HDR","SENDING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+        S MSG("HDR","RECEIVING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+        I 'MSG("BATCH") D
+        .S MSG("HDR","MESSAGE TYPE")=$P($P(MSG("HDR",2),FS,4),CS)
+        .S MSG("HDR","EVENT")=$P($P(MSG("HDR",2),FS,4),CS,2)
+        .S MSG("HDR","ACCEPT ACK TYPE")=$E($P(MSG("HDR",2),FS,10),1,2)
+        .S MSG("HDR","APP ACK TYPE")=$E($P(MSG("HDR",2),FS,11),1,2)
+        .S MSG("HDR","MESSAGE CONTROL ID")=MSG("ID")
+        E  D
+        .S MSG("HDR","BATCH CONTROL ID")=MSG("ID")
+        .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2)
+        .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2)
+        S MSG("STATUS","SEQUENCE QUEUE")=$P($G(^HLB(IEN,5)),"^")
+        Q 1
+        ;
+GETMTYPE(MSGIEN)        ;returns <message type>~<event> OR "BATCH"
+        Q:'$G(MSGIEN) "UNKNOWN"
+        N FS,CS,HDR1,HDR2
+        S HDR1=$G(^HLB(IEN,1))
+        I $E(HDR1,1,3)="BHS" Q "BATCH"
+        S HDR2=$G(^HLB(IEN,2))
+        S FS=$E(HDR1,4)
+        S CS=$E(HDR1,5)
+        Q $P($P(HDR2,FS,4),CS)_"~"_$P($P(HDR2,FS,4),CS,2)
+        ;
+GETEVENT(MSGIEN)        ; returns event if not a batch message
+        Q:'$G(MSGIEN) ""
+        N FS,CS,HDR1,HDR2
+        S HDR1=$G(^HLB(MSGIEN,1))
+        I $E(HDR1,1,3)="BHS" Q ""
+        S HDR2=$G(^HLB(MSGIEN,2))
+        S FS=$E(HDR1,4)
+        S CS=$E(HDR1,5)
+        Q $P($P(HDR2,FS,4),CS,2)
+        ;
+GETSAP(MSGIEN)  ;
+        ;
+        ;
+        Q:'$G(MSGIEN) "UNKNOWN"
+        N FS,CS,HDR1,REP,ESCAPE,SUBCOMP
+        S HDR1=$G(^HLB(MSGIEN,1))
+        S FS=$E(HDR1,4)
+        S CS=$E(HDR1,5)
+        S REP=$E(HDR1,6)
+        S ESCAPE=$E(HDR1,7)
+        S SUBCOMP=$E(HDR1,8)
+        Q $$DESCAPE^HLOPRS1($P($P(HDR1,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+GETWORK(WORK) ;
+ ;
+ N OLD,DOLLARJ,SUCCESS,NOW
+ S SUCCESS=0
+ S NOW=$$NOW^XLFDT
+ S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
+ F  S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ=""  D  Q:SUCCESS
+ .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
+ .Q:'$T
+ .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
+ .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
+ .S SUCCESS=1
+ ;
+ I OLD'="",'SUCCESS F  S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ=""  Q:DOLLARJ>OLD  D  Q:SUCCESS
+ .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
+ .Q:'$T
+ .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
+ .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
+ .S SUCCESS=1
+ S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
+ Q $S($L(WORK("DOLLARJ")):1,1:0)
+ ;
+DOWORK(WORK) ;
+ ;
+ N DOLLARJ,TIME,IEN,PARMS,SYSTEM
+ S TIME=""
+ S DOLLARJ=WORK("DOLLARJ")
+ D SYSPARMS^HLOSITE(.SYSTEM)
+ F  S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME)) Q:TIME=""  Q:$$FMDIFF^XLFDT(WORK("NOW"),TIME,2)<2  D
+ .S IEN=0
+ .F  S IEN=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) Q:'IEN  D
+ ..N NODE
+ ..S NODE=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN))
+ ..S PARMS("LINK")=$P(NODE,"^")
+ ..S PARMS("QUEUE")=$P(NODE,"^",2)
+ ..S PARMS("STATUS")=$P(NODE,"^",3)
+ ..S PARMS("PURGE TYPE")=$P(NODE,"^",4)
+ ..S PARMS("ACK TO IEN")=+$P($P(NODE,"^",4),"-",2)
+ ..S PARMS("ACCEPT ACK")=$P(NODE,"^",5)
+ ..S PARMS("RECEIVING APP")=$P(NODE,"^",6)
+ ..S:PARMS("RECEIVING APP")="" PARMS("RECEIVING APP")="UNKNOWN RECEIVING APPLICATION"
+ ..S PARMS("MSA")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"MSA"))
+ ..S PARMS("ACTION")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"ACTION"))
+ ..D UPDATE(IEN,TIME,.PARMS)
+ ..K ^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)
+ L -^HLTMP("CLIENT UPDATES",DOLLARJ)
+ Q
+ ;
+UPDATE(MSGIEN,TIME,PARMS) ;
+ S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS")
+ S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)=""
+ S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
+ I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
+ S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK")
+ S $P(^HLB(MSGIEN,0),"^",16)=TIME
+ S:PARMS("MSA")]"" ^HLB(MSGIEN,4)=TIME_"^"_PARMS("MSA")
+ I PARMS("PURGE TYPE"),PARMS("ACTION")="" D
+ .;don't set purge if going on the infiler - let infiler do it
+ .N PTIME
+ .S:(PARMS("PURGE TYPE")=2) PTIME=$$FMADD^XLFDT(TIME,SYSTEM("ERROR PURGE")) ;error purge is in days
+ .S:(PARMS("PURGE TYPE")'=2) PTIME=$$FMADD^XLFDT(TIME,,SYSTEM("NORMAL PURGE")) ;normal purge is in hours
+ .S $P(^HLB(MSGIEN,0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,MSGIEN)=""
+ .I PARMS("ACK TO IEN"),$D(^HLB(PARMS("ACK TO IEN"),0)) S $P(^HLB(PARMS("ACK TO IEN"),0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,PARMS("ACK TO IEN"))=""
+ D:PARMS("ACTION")]""
+ .N PURGE
+ .S PURGE=$S(PARMS("PURGE TYPE"):1,1:0)
+ .S:PARMS("ACK TO IEN") PURGE("ACKTOIEN")=PARMS("ACK TO IEN")
+ .D INQUE^HLOQUE(PARMS("LINK"),PARMS("QUEUE"),MSGIEN,PARMS("ACTION"),.PURGE)
+ Q
+ ;
+GETMSG(IEN,MSG) ;
+ ;
+ ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below.
+ ;Input:
+ ;  IEN - the ien of the message in file 778
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  MSG (pass by reference, required) These are the subscripts returned:
+ ;    "ACCEPT ACK RESPONSE" - if the sending app requested notification of the accept ack, this is the routine to perform
+ ;    "ACKTOIEN" - if this is an app ack to a message not in a batch, this is the ien of the original message
+ ;    "BATCH"  = 1 if this is a batch message, 0  if not
+ ;    "CURRENT MESSAGE" - defined only for batch messages -  a counterused during building and parsing messages to indicate the current message.  It will be set to 0 initially.
+ ;    "BODY" - ptr to file 778 which contains the body of the message.
+ ;    "LINE COUNT" -  a counter used during writing of the
+ ;     messages to indicate the current line. For
+ ;     batch messages where each message within the batch is stored
+ ;     separately, this field indicates the position within the current
+ ;     individual message
+ ;    "HDR" at these lower subscripts:
+ ;       1    - components 1-6
+ ;       2    - components 7-end
+ ;       "ACCEPT ACK TYPE" = "AL" or "NE"
+ ;       "APP ACK TYPE" = "AL" or "NE"
+ ;       "MESSAGE CONTROL ID" - defined if NOT batch
+ ;       "BATCH CONTROL ID" - defined if batch
+ ;
+ ;    "ID" - message id from the header
+ ;    "IEN" - ien, file 778
+ ;
+ K MSG
+ Q:'$G(IEN) 0
+ N NODE,FS,CS,REP,SUBCOMP,ESCAPE
+ S MSG("IEN")=IEN
+ S NODE=$G(^HLB(IEN,0))
+ S MSG("BODY")=$P(NODE,"^",2)
+ S MSG("ID")=$P(NODE,"^")
+ Q:'MSG("BODY") 0
+ S MSG("STATUS","ACCEPTED")=$P(NODE,"^",17)
+ S MSG("DT/TM")=$P(NODE,"^",16)
+ S MSG("STATUS","QUEUE")=$P(NODE,"^",6)
+ I MSG("STATUS","QUEUE")="" S MSG("STATUS","QUEUE")="DEFAULT"
+ S MSG("ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13)
+ I MSG("ACCEPT ACK RESPONSE")="^" S MSG("ACCEPT ACK RESPONSE")=""
+ ;
+ S MSG("BATCH")=+$P($G(^HLA(MSG("BODY"),0)),"^",2)
+ I MSG("BATCH") D
+ .S MSG("BATCH","CURRENT MESSAGE")=0
+ E  D
+ .N ACKTO
+ .S ACKTO=$P(NODE,"^",3)
+ .I ACKTO]"" S ACKTO=$$ACKTOIEN^HLOMSG1(MSG("ID"),ACKTO)
+ .I ACKTO,+ACKTO=ACKTO S MSG("ACK TO IEN")=ACKTO
+ S MSG("LINE COUNT")=0
+ S MSG("HDR",1)=$G(^HLB(IEN,1))
+ S MSG("HDR",2)=$G(^HLB(IEN,2))
+ S FS=$E(MSG("HDR",1),4)
+ S CS=$E(MSG("HDR",1),5)
+ S REP=$E(MSG("HDR",1),6)
+ S ESCAPE=$E(MSG("HDR",1),7)
+ S SUBCOMP=$E(MSG("HDR",1),8)
+ S MSG("HDR","FIELD SEPARATOR")=FS
+ S MSG("HDR","SENDING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+ S MSG("HDR","RECEIVING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+ I 'MSG("BATCH") D
+ .S MSG("HDR","MESSAGE TYPE")=$P($P(MSG("HDR",2),FS,4),CS)
+ .S MSG("HDR","EVENT")=$P($P(MSG("HDR",2),FS,4),CS,2)
+ .S MSG("HDR","ACCEPT ACK TYPE")=$E($P(MSG("HDR",2),FS,10),1,2)
+ .S MSG("HDR","APP ACK TYPE")=$E($P(MSG("HDR",2),FS,11),1,2)
+ .S MSG("HDR","MESSAGE CONTROL ID")=MSG("ID")
+ E  D
+ .S MSG("HDR","BATCH CONTROL ID")=MSG("ID")
+ .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2)
+ .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2)
+ Q 1
+ ;
+GETMTYPE(MSGIEN) ;returns <message type>~<event> OR "BATCH"
+ Q:'$G(MSGIEN) "UNKNOWN"
+ N FS,CS,HDR1,HDR2
+ S HDR1=$G(^HLB(IEN,1))
+ I $E(HDR1,1,3)="BHS" Q "BATCH"
+ S HDR2=$G(^HLB(IEN,2))
+ S FS=$E(HDR1,4)
+ S CS=$E(HDR1,5)
+ Q $P($P(HDR2,FS,4),CS)_"~"_$P($P(HDR2,FS,4),CS,2)
+ ;
+GETEVENT(MSGIEN) ; returns event if not a batch message
+ Q:'$G(MSGIEN) ""
+ N FS,CS,HDR1,HDR2
+ S HDR1=$G(^HLB(MSGIEN,1))
+ I $E(HDR1,1,3)="BHS" Q ""
+ S HDR2=$G(^HLB(MSGIEN,2))
+ S FS=$E(HDR1,4)
+ S CS=$E(HDR1,5)
+ Q $P($P(HDR2,FS,4),CS,2)
+ ;
+GETSAP(MSGIEN) ;
+ ;
+ ;
+ Q:'$G(MSGIEN) "UNKNOWN"
+ N FS,CS,HDR1,REP,ESCAPE,SUBCOMP
+ S HDR1=$G(^HLB(MSGIEN,1))
+ S FS=$E(HDR1,4)
+ S CS=$E(HDR1,5)
+ S REP=$E(HDR1,6)
+ S ESCAPE=$E(HDR1,7)
+ S SUBCOMP=$E(HDR1,8)
+ Q $$DESCAPE^HLOPRS1($P($P(HDR1,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m

-              r613
+              r623
 HLOCLNT3        ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
 DOWORK(WORK)    ;
+        ;
         N CUTOFF,MSGIEN,QUIT,NOW,SYSTEM
         S NOW=$$NOW^XLFDT
         S QUIT=0
         D SYSPARMS^HLOSITE(.SYSTEM)
         S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,24*SYSTEM("ERROR PURGE"))
+        ;
         ;7 day wait for an application ack is more than reasonable
         S CUTOFF=$$FMADD^XLFDT(NOW,-3)
+        ;
         S MSGIEN=+$G(^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK"))
         F  S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN  Q:MSGIEN>99999999999  D  Q:QUIT
         .N MSG,HDR
         .Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG)
         .Q:'MSG("DT/TM")
         .Q:'MSG("BODY")
         .I MSG("DT/TM")>CUTOFF S:MSG("DT/TM CREATED")>CUTOFF QUIT=1,MSGIEN=MSGIEN-1 Q
         .Q:MSG("STATUS")'=""
         .Q:MSG("DIRECTION")'="OUT"
         .Q:MSG("BATCH")
         .Q:MSG("STATUS","APP ACK'D")
         .;Q:MSG("STATUS","APP ACK RESPONSE")=""
         .;message has been in a non-complete status for a longtime, pending an application ack - set status to error and schedule for purging
         .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
         .S ^HLB("AD","OUT",PURGE,MSGIEN)=""
         .S $P(^HLB(MSGIEN,0),"^",20)="ER"
         .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT"
         .M HDR=MSG("HDR")
         .Q:'$$PARSEHDR^HLOPRS(.HDR)
         .S ^HLB("ERRORS",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
         .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT")))
         S:MSGIEN>99999999999 MSGIEN=0
         S ^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")=MSGIEN
+        Q
+HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+DOWORK(WORK) ;
+ ;
+ N CUTOFF,MSGIEN,QUIT,NOW,SYSTEM
+ S NOW=$$NOW^XLFDT
+ S QUIT=0
+ D SYSPARMS^HLOSITE(.SYSTEM)
+ S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,24*SYSTEM("ERROR PURGE"))
+ ;
+ ;7 day wait for an application ack is more than reasonable
+ S CUTOFF=$$FMADD^XLFDT(NOW,-3)
+ ;
+ S MSGIEN=+$G(^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK"))
+ F  S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN  Q:MSGIEN>99999999999  D  Q:QUIT
+ .N MSG,HDR
+ .Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG)
+ .Q:'MSG("DT/TM")
+ .Q:'MSG("BODY")
+ .I MSG("DT/TM")>CUTOFF S:MSG("DT/TM CREATED")>CUTOFF QUIT=1,MSGIEN=MSGIEN-1 Q
+ .Q:MSG("STATUS")'=""
+ .Q:MSG("DIRECTION")'="OUT"
+ .Q:MSG("BATCH")
+ .Q:MSG("STATUS","APP ACK'D")
+ .;Q:MSG("STATUS","APP ACK RESPONSE")=""
+ .;message has been in a non-complete status for a longtime, pending an application ack - set status to error and schedule for purging
+ .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
+ .S ^HLB("AD","OUT",PURGE,MSGIEN)=""
+ .S $P(^HLB(MSGIEN,0),"^",20)="AE"
+ .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT"
+ .M HDR=MSG("HDR")
+ .Q:'$$PARSEHDR^HLOPRS(.HDR)
+ .S ^HLB("ERRORS","AE",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
+ .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT")))
+ S:MSGIEN>99999999999 MSGIEN=0
+ S ^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")=MSGIEN
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m

-              r613
+              r623
+HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;07/24/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;**Program Description**
+        ;  This program takes a current HL7 1.6 message and converts
+        ;  it to use the new HL Optimized code if it follows the standard
+        ;  1.6 methodology of protocols.
+        ;
+        ;  **If the VistA HL7 Protocol does not exist, calls to HL Optimized
+        ;  will have to be coded separately and this program cannot be used**
+        Q
+        ;
+EN(HLOPRTCL,ARYTYP,HLP,HLL,RESULT)      ;Entry Point
+        ;  Input Parameters
+        ;   HLOPRTCL = Protocol IEN or Protocol Name
+        ;   ARYTYP = The array where HL7 message resides
+        ;   HLP = Additional HL7 message parameters (optional, pass by reference)
+        ;        These optional subscripts to HLP are supported for input:
+        ;             "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
+        ;             "CONTPTR"
+        ;             "SECURITY"
+        ;             "SEQUENCE QUEUE" - queue used to maintain the order of the messages via application acks.  If used, the application MUST specify that both an accept ack and application ack be returned.
+        ;
+        ;   HLL  (optional, pass by reference) Additional message recipients being dynamically added
+        ;
+        ;  Output
+        ;    RESULT (pass-by-reference)=<subscriber protocol ien>^<link ien>^<message id>^<0 if sucess, error code if failure>^<optional error message>
+        ;             If the message was sent to more than 1 destination,
+        ;             the addtional mssage ids returned as RESULT(1), RESULT(2), etc.
+        ;    ZTSTOP = Stop processing flag (used by HDR)
+        ;    Function returns 1 on success, else returns an error message
+        ;
+        NEW HLORESL,HLMSTATE,APPARMS,WHOTO,ERROR,WHO
+        S ZTSTOP=0,HLORESL=1,RESULT=""
+        ;
+        ;  Get IEN of protocol if name is passed
+        I '$L(HLOPRTCL) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+        I ('HLOPRTCL)!(HLOPRTCL'=+HLOPRTCL) S HLOPRTCL=+$O(^ORD(101,"B",HLOPRTCL,0))
+        I 'HLOPRTCL S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+        I '$D(^ORD(101,HLOPRTCL)) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+        ;
+        ;  If the VistA HL7 Protocol exists, call the Conversion Utility
+        ;  to set up the APPARMS, WHOTO arrays from protocol logical link,
+        ;   and the optional HLL and HLP arrays
+        D APAR^HLOCVU(HLOPRTCL,.APPARMS,.WHO,.WHOTO,.HLP,.HLL)
+        ;
+        ; If special HLP parameters are defined, convert them
+        I $D(HLP) D
+        . I $G(HLP("SECURITY"))'="" S APPARMS("SECURITY")=HLP("SECURITY")
+        . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR")
+        . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE")
+        . I $G(HLP("SEQUENCE QUEUE"))'="" S APPARMS("SEQUENCE QUEUE")=HLP("SEQUENCE QUEUE")
+        . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE")
+        ;
+        ;  Create HL Optimized message
+        I '$$NEWMSG^HLOAPI(.APPARMS,.HLMSTATE,.ERROR) S HLORESL="^99^"_ERROR,ZTSTOP=1,RESULT="^^"_HLORESL Q HLORESL
+        I $E(ARYTYP,1)="G" S HLOMESG="^TMP(""HLS"",$J)"
+        I $E(ARYTYP,1)="L" S HLOMESG="HLA(""HLS"")"
+        ;
+        ;  Move the existing message from array into HL Optimized
+        D MOVEMSG^HLOAPI(.HLMSTATE,HLOMESG)
+        ;
+        ;  Send message via HL Optimized
+        I $D(WHOTO) D
+        .N COUNT
+        .I '$$SENDMANY^HLOAPI1(.HLMSTATE,.APPARMS,.WHOTO) D
+        ..S HLORESL="^99^Unable to send message",ZTSTOP=1
+        .I $G(WHOTO(1,"IEN")) D
+        ..S RESULT=WHO(1)_"^"_$P($G(^HLB(WHOTO(1,"IEN"),0)),"^")_"^"_$S($G(WHOTO(1,"QUEUED")):0,1:1)_"^"_$G(WHOTO(1,"ERROR"))
+        .E  D
+        ..S RESULT=WH0(1)_"^^1^"_$G(WHOTO(1,"ERROR"))
+        ..S HLORESL="^99^"_$G(WHOTO(1,"ERROR")),ZTSTOP=1
+        .S COUNT=1
+        .F  S COUNT=$O(WHOTO(COUNT)) Q:'COUNT  D
+        ..I $G(WHOTO(COUNT,"IEN")) D
+        ...S RESULT(COUNT-1)=WHO(COUNT)_"^"_$P($G(^HLB(WHOTO(COUNT,"IEN"),0)),"^")_"^"_$S($G(WHOTO(COUNT,"QUEUED")):0,1:1)_"^"_$G(WHOTO(COUNT,"ERROR"))
+        ..E  D
+        ...S RESULT(COUNT-1)=WH0(COUNT)_"^^1^"_$G(WHOTO(COUNT,"ERROR"))
+        ;
+        E  S HLORESL="^99^Unable to send message",ZTSTOP=1,RESULT="^^"_HLORESL
+        Q HLORESL
+HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;**Program Description**
+ ;  This program takes a current HL7 1.6 message and converts
+ ;  it to use the new HL Optimized code if it follows the standard
+ ;  1.6 methodology of protocols.
+ ;
+ ;  **If the VistA HL7 Protocol does not exist, calls to HL Optimized
+ ;  will have to be coded separately and this program cannot be used**
+ Q
+ ;
+EN(HLOPRTCL,ARYTYP,HLP,HLL,RESULT) ;Entry Point
+ ;  Input Parameters
+ ;   HLOPRTCL = Protocol IEN or Protocol Name
+ ;   ARYTYP = The array where HL7 message resides
+ ;   HLP = Additional HL7 message parameters (optional, pass by reference)
+ ;        These optional subscripts to HLL are supported for input:
+ ;             "SECURITY"
+ ;              "CONTPTR"
+ ;              "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
+ ;
+ ;   HLL  (optional, pass by reference) Additional message recipients being dynamically added
+ ;
+ ;  Output
+ ;    RESULT (pass-by-reference)=<subscriber protocol ien>^<link ien>^<message id>^<0 if sucess, error code if failure>^<optional error message>
+ ;             If the message was sent to more than 1 destination,
+ ;             the addtional mssage ids returned as RESULT(1), RESULT(2), etc.
+ ;    ZTSTOP = Stop processing flag (used by HDR)
+ ;    Function returns 1 on success, else returns an error message
+ ;
+ NEW HLORESL,HLMSTATE,APPARMS,WHOTO,ERROR,WHO
+ S ZTSTOP=0,HLORESL=1,RESULT=""
+ ;
+ ;  Get IEN of protocol if name is passed
+ I '$L(HLOPRTCL) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+ I ('HLOPRTCL)!(HLOPRTCL'=+HLOPRTCL) S HLOPRTCL=+$O(^ORD(101,"B",HLOPRTCL,0))
+ I 'HLOPRTCL S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+ I '$D(^ORD(101,HLOPRTCL)) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL
+ ;
+ ;  If the VistA HL7 Protocol exists, call the Conversion Utility
+ ;  to set up the APPARMS, WHOTO arrays from protocol logical link,
+ ;   and the optional HLL and HLP arrays
+ D APAR^HLOCVU(HLOPRTCL,.APPARMS,.WHO,.WHOTO,.HLP,.HLL)
+ ;
+ ; If special HLP parameters are defined, convert them
+ I $D(HLP) D
+ . I $G(HLP("SECURITY"))'="" S APPARMS("SECURITY")=HLP("SECURITY")
+ . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR")
+ . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE")
+ . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE")
+ ;
+ ;  Create HL Optimized message
+ I '$$NEWMSG^HLOAPI(.APPARMS,.HLMSTATE,.ERROR) S HLORESL="^99^"_ERROR,ZTSTOP=1,RESULT="^^"_HLORESL Q HLORESL
+ I $E(ARYTYP,1)="G" S HLOMESG="^TMP(""HLS"",$J)"
+ I $E(ARYTYP,1)="L" S HLOMESG="HLA(""HLS"")"
+ ;
+ ;  Move the existing message from array into HL Optimized
+ D MOVEMSG^HLOAPI(.HLMSTATE,HLOMESG)
+ ;
+ ;  Send message via HL Optimized
+ I $D(WHOTO) D
+ .N COUNT
+ .I '$$SENDMANY^HLOAPI1(.HLMSTATE,.APPARMS,.WHOTO) D
+ ..S HLORESL="^99^Unable to send message",ZTSTOP=1
+ .I $G(WHOTO(1,"IEN")) D
+ ..S RESULT=WHO(1)_"^"_$P($G(^HLB(WHOTO(1,"IEN"),0)),"^")_"^"_$S($G(WHOTO(1,"QUEUED")):0,1:1)_"^"_$G(WHOTO(1,"ERROR"))
+ .E  D
+ ..S RESULT=WH0(1)_"^^1^"_$G(WHOTO(1,"ERROR"))
+ ..S HLORESL="^99^"_$G(WHOTO(1,"ERROR")),ZTSTOP=1
+ .S COUNT=1
+ .F  S COUNT=$O(WHOTO(COUNT)) Q:'COUNT  D
+ ..I $G(WHOTO(COUNT,"IEN")) D
+ ...S RESULT(COUNT-1)=WHO(COUNT)_"^"_$P($G(^HLB(WHOTO(COUNT,"IEN"),0)),"^")_"^"_$S($G(WHOTO(COUNT,"QUEUED")):0,1:1)_"^"_$G(WHOTO(COUNT,"ERROR"))
+ ..E  D
+ ...S RESULT(COUNT-1)=WH0(COUNT)_"^^1^"_$G(WHOTO(COUNT,"ERROR"))
+ ;
+ E  S HLORESL="^99^Unable to send message",ZTSTOP=1,RESULT="^^"_HLORESL
+ Q HLORESL

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m

-              r613
+              r623
 HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;
 SAVEMSG(HLMSTATE)       ;
         ;If a record has not yet been created in file 778, then it will be created. Will file any segments into 777 not yet stored.  For batch messages, will store the MSH segments in 778 as the individual messages are stored in 777.
         ;Input:
         ;  HLMSTATE (pass by reference) - contains information about the message
         ;    These subscripts must be defined:
         ;  ("BATCH")=1 if batch, 0 otherwise
         ;  ("BATCH","BTS")=BTS segment if end of batch reached
         ;  ("BODY")=ien file 777 if stored
         ;  ("DIRECTION")=<"IN" or "OUT">
         ;  ("IEN")=ien,file 778 if stored
         ;  ("UNSTORED LINES") - count of lines to be stored.  The lines are at the a lower subscript level <msg>,<segment>,<line>=<line to be stored>
         ;  ("UNSTORED MSH") For batch messages, set to 1 if there are MSH in cache. Cached MSH at ("UNSTORED MSH",<subfile ien>,<1 & 2>)
+        ;
         ;Output:
         ;  Function - returns the ien of the msg (file 778)
         ;  HLMSTATE
         ;   ("BODY") - set to ien, file 777 if newly created
         ;   ("IEN") - set to ien, file 778 if newly created
         ;   ("UNSTORED LINES")-set to 0 as this function will store them
         ;   ("UNSTORED MSH")- set to 0 as this function will store it
+        ;
+        ;
         I '$D(HLMSTATE("DT/TM")) S HLMSTATE("DT/TM")=$S(HLMSTATE("DIRECTION")="IN":$$NOW^XLFDT,1:"")
+        ;
         ;insure that 777 entry created & all segments stored
         I ('HLMSTATE("BODY"))!($G(HLMSTATE("UNSTORED LINES")))!($L($G(HLMSTATE("BATCH","BTS")))),'$$SAVEMSG^HLOF777(.HLMSTATE) Q 0
+        ;
         ;insure 778 entry created
         I 'HLMSTATE("IEN") Q:'$$NEW^HLOF778A(.HLMSTATE) 0
+        ;
         ;for batch messages, store MSH segments in 778
         I HLMSTATE("BATCH") D
         .N IEN S IEN=HLMSTATE("IEN")
         .;
         .;incoming messages cache the MSH segments in memory
         .I HLMSTATE("DIRECTION")="IN",HLMSTATE("UNSTORED MSH") D
         ..N ORDER S ORDER=0
         ..F  S ORDER=$O(HLMSTATE("UNSTORED MSH",ORDER)) Q:'ORDER  D
         ...N FS,MSGID
         ...S FS=$E(HLMSTATE("UNSTORED MSH",ORDER,1),4)
         ...S MSGID=$P(HLMSTATE("UNSTORED MSH",ORDER,2),FS,5)
         ...S ^HLB(IEN,3,ORDER,0)=ORDER_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",ORDER))
         ...S ^HLB(IEN,3,ORDER,1)=HLMSTATE("UNSTORED MSH",ORDER,1)
         ...S ^HLB(IEN,3,ORDER,2)=HLMSTATE("UNSTORED MSH",ORDER,2)
         ...S ^HLB(IEN,3,"B",ORDER,ORDER)=""
         ...I MSGID]"" S ^HLB("AE",MSGID,IEN_"^"_ORDER)="" ;whole file index for individual message id
         ..K HLMSTATE("UNSTORED MSH") S HLMSTATE("UNSTORED MSH")=0
         .;
         .;
         .I HLMSTATE("DIRECTION")="OUT" D
         ..;must build the MSH segments!
         ..N HDR,FS,MSG,CS
         ..S FS=HLMSTATE("HDR","FIELD SEPARATOR")
         ..S CS=$E(HLMSTATE("HDR","ENCODING CHARACTERS"),1)
         ..S HLMSTATE("HDR","MESSAGE TYPE")="   "
         ..S HLMSTATE("HDR","EVENT")="   "
         ..D BUILDHDR^HLOPBLD1(.HLMSTATE,"MSH",.HDR)
         ..S HLMSTATE("BATCH","CURRENT MESSAGE")=$O(^HLB(HLMSTATE("IEN"),3,"B",";"),-1)
         ..F  Q:'$$NEXTMSG(.HLMSTATE,.MSG)  D
         ...N MSGID,CUR
         ...S CUR=HLMSTATE("BATCH","CURRENT MESSAGE")
         ...S MSGID=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_CUR
         ...S $P(HDR(2),FS,4)=MSG("MESSAGE TYPE")_CS_MSG("EVENT")
         ...S $P(HDR(2),FS,5)=MSGID
         ...S ^HLB(IEN,3,CUR,0)=CUR_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",CUR))
         ...S ^HLB(IEN,3,CUR,1)=HDR(1)
         ...S ^HLB(IEN,3,CUR,2)=HDR(2)
         ...S ^HLB(IEN,3,"B",CUR,CUR)=""
         ...S ^HLB("AE",MSGID,IEN_"^"_CUR)="" ;whole file index for individual message id
         ..;
         .;if the messages are application acks, then update the original message
         .N SUBIEN S SUBIEN=0
         .F  S SUBIEN=$O(HLMSTATE("BATCH","ACK TO",SUBIEN)) Q:'SUBIEN  I $G(HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN"))]"" D
         ..N ACKTO
         ..M ACKTO=HLMSTATE("BATCH","ACK TO",SUBIEN)
         ..;
         ..;for outgoing msgs, we just created the msgid, for incoming msgs we already had it
         ..S:HLMSTATE("DIRECTION")="OUT" ACKTO("ACK BY")=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_SUBIEN
         ..;
         ..D ACKTO(.HLMSTATE,.ACKTO)
         .K HLMSTATE("BATCH","ACK TO")
+        ;
         ;if the msg is an app ack, update the original if not done already
         I $G(HLMSTATE("ACK TO","IEN"))]"",'$G(HLMSTATE("ACK TO","DONE")) D
         .N ACKTO
         .M ACKTO=HLMSTATE("ACK TO")
         .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
         .D ACKTO(.HLMSTATE,.ACKTO)
         .S HLMSTATE("ACK TO","DONE")=1 ;so the update isn't done again
+        ;
         Q HLMSTATE("IEN")
+        ;
 NEXTMSG(HLMSTATE,MSG)   ;
         ;Traverses file 777 to return the next message in the batch - as
         ;indicated by HLMSTATE("BATCH","CURRENT MESSAGE")  Set to 0 to start,
         ;returns 0 when there are no more messages
+        ;
         ;Input:  HLMSTATE (pass by reference,required)
         ;Output:
         ;  HLMSTATE
         ;     ("BATCH","CURRENT MESSAGE")
         ;  MSG -pass by reference:
         ;     ("EVENT")
         ;     ("MESSAGE TYPE")
+        ;
+        ;
         N SUBIEN,NODE
         K MSG
         Q:'$G(HLMSTATE("BODY")) 0
         S SUBIEN=$O(^HLA(HLMSTATE("BODY"),2,HLMSTATE("BATCH","CURRENT MESSAGE")))
         Q:'SUBIEN 0
         S NODE=$G(^HLA(HLMSTATE("BODY"),2,SUBIEN,0))
         S MSG("MESSAGE TYPE")=$P(NODE,"^",2)
         S MSG("EVENT")=$P(NODE,"^",3)
         S HLMSTATE("BATCH","CURRENT MESSAGE")=SUBIEN
         Q SUBIEN
+        ;
 ACKTO(HLMSTATE,ACKTO)   ;if this is an application ack, update the original message - but do not overlay if already valued
         ;ACKTO = (msgid of msg being ack'd)
         ;        uses these subscripts ("IEN"=ien^subien),("ACK BY"=msgid of acking msg),("STATUS"=status for the initial msg determined by the ack)
+        ;
         N STATUS,IEN,SUBIEN,NODE,SKIP
         S SKIP=0
         S STATUS=$G(ACKTO("STATUS"))
         S IEN=+ACKTO("IEN"),SUBIEN=$P(ACKTO("IEN"),"^",2)
         S NODE=$G(^HLB(IEN,0))
         I 'SUBIEN D
         .;ack is to a message NOT in a batch
         .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=ACKTO("ACK BY") S SKIP=1 Q
         .I STATUS="" S STATUS="SU"
         .S $P(NODE,"^",7)=ACKTO("ACK BY")
         .S $P(NODE,"^",20)=STATUS
         .S $P(NODE,"^",21)=$G(ACKTO("ERROR TEXT"))
         .S ^HLB(IEN,0)=NODE
         E  D
         .;ack is to a message that IS in a batch
         .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY"))
         .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS
         I (STATUS="ER"),'SKIP D
         .N APP
         .S APP=HLMSTATE("HDR","RECEIVING APPLICATION")
         .I APP="" S APP="UNKNOWN"
         .S ^HLB("ERRORS",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
         .;don't count the error - the app ack was already counted as an error.
         .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+        Q
+HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;
+SAVEMSG(HLMSTATE) ;
+ ;If a record has not yet been created in file 778, then it will be created. Will file any segments into 777 not yet stored.  For batch messages, will store the MSH segments in 778 as the individual messages are stored in 777.
+ ;Input:
+ ;  HLMSTATE (pass by reference) - contains information about the message
+ ;    These subscripts must be defined:
+ ;  ("BATCH")=1 if batch, 0 otherwise
+ ;  ("BATCH","BTS")=BTS segment if end of batch reached
+ ;  ("BODY")=ien file 777 if stored
+ ;  ("DIRECTION")=<"IN" or "OUT">
+ ;  ("IEN")=ien,file 778 if stored
+ ;  ("UNSTORED LINES") - count of lines to be stored.  The lines are at the a lower subscript level <msg>,<segment>,<line>=<line to be stored>
+ ;  ("UNSTORED MSH") For batch messages, set to 1 if there are MSH in cache. Cached MSH at ("UNSTORED MSH",<subfile ien>,<1 & 2>)
+ ;
+ ;Output:
+ ;  Function - returns the ien of the msg (file 778)
+ ;  HLMSTATE
+ ;   ("BODY") - set to ien, file 777 if newly created
+ ;   ("IEN") - set to ien, file 778 if newly created
+ ;   ("UNSTORED LINES")-set to 0 as this function will store them
+ ;   ("UNSTORED MSH")- set to 0 as this function will store it
+ ;
+ ;
+ I '$D(HLMSTATE("DT/TM")) S HLMSTATE("DT/TM")=$S(HLMSTATE("DIRECTION")="IN":$$NOW^XLFDT,1:"")
+ ;
+ ;insure that 777 entry created & all segments stored
+ I ('HLMSTATE("BODY"))!($G(HLMSTATE("UNSTORED LINES")))!($L($G(HLMSTATE("BATCH","BTS")))),'$$SAVEMSG^HLOF777(.HLMSTATE) Q 0
+ ;
+ ;insure 778 entry created
+ I 'HLMSTATE("IEN") Q:'$$NEW^HLOF778A(.HLMSTATE) 0
+ ;
+ ;for batch messages, store MSH segments in 778
+ I HLMSTATE("BATCH") D
+ .N IEN S IEN=HLMSTATE("IEN")
+ .;
+ .;incoming messages cache the MSH segments in memory
+ .I HLMSTATE("DIRECTION")="IN",HLMSTATE("UNSTORED MSH") D
+ ..N ORDER S ORDER=0
+ ..F  S ORDER=$O(HLMSTATE("UNSTORED MSH",ORDER)) Q:'ORDER  D
+ ...N FS,MSGID
+ ...S FS=$E(HLMSTATE("UNSTORED MSH",ORDER,1),4)
+ ...S MSGID=$P(HLMSTATE("UNSTORED MSH",ORDER,2),FS,5)
+ ...S ^HLB(IEN,3,ORDER,0)=ORDER_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",ORDER))
+ ...S ^HLB(IEN,3,ORDER,1)=HLMSTATE("UNSTORED MSH",ORDER,1)
+ ...S ^HLB(IEN,3,ORDER,2)=HLMSTATE("UNSTORED MSH",ORDER,2)
+ ...S ^HLB(IEN,3,"B",ORDER,ORDER)=""
+ ...I MSGID]"" S ^HLB("AE",MSGID,IEN_"^"_ORDER)="" ;whole file index for individual message id
+ ..K HLMSTATE("UNSTORED MSH") S HLMSTATE("UNSTORED MSH")=0
+ .;
+ .;
+ .I HLMSTATE("DIRECTION")="OUT" D
+ ..;must build the MSH segments!
+ ..N HDR,FS,MSG,CS
+ ..S FS=HLMSTATE("HDR","FIELD SEPARATOR")
+ ..S CS=$E(HLMSTATE("HDR","ENCODING CHARACTERS"),1)
+ ..S HLMSTATE("HDR","MESSAGE TYPE")="   "
+ ..S HLMSTATE("HDR","EVENT")="   "
+ ..D BUILDHDR^HLOPBLD1(.HLMSTATE,"MSH",.HDR)
+ ..S HLMSTATE("BATCH","CURRENT MESSAGE")=$O(^HLB(HLMSTATE("IEN"),3,"B",";"),-1)
+ ..F  Q:'$$NEXTMSG(.HLMSTATE,.MSG)  D
+ ...N MSGID,CUR
+ ...S CUR=HLMSTATE("BATCH","CURRENT MESSAGE")
+ ...S MSGID=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_CUR
+ ...S $P(HDR(2),FS,4)=MSG("MESSAGE TYPE")_CS_MSG("EVENT")
+ ...S $P(HDR(2),FS,5)=MSGID
+ ...S ^HLB(IEN,3,CUR,0)=CUR_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",CUR))
+ ...S ^HLB(IEN,3,CUR,1)=HDR(1)
+ ...S ^HLB(IEN,3,CUR,2)=HDR(2)
+ ...S ^HLB(IEN,3,"B",CUR,CUR)=""
+ ...S ^HLB("AE",MSGID,IEN_"^"_CUR)="" ;whole file index for individual message id
+ ..;
+ .;if the messages are application acks, then update the original message
+ .N SUBIEN S SUBIEN=0
+ .F  S SUBIEN=$O(HLMSTATE("BATCH","ACK TO",SUBIEN)) Q:'SUBIEN  I $G(HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN"))]"" D
+ ..N ACKTO
+ ..M ACKTO=HLMSTATE("BATCH","ACK TO",SUBIEN)
+ ..;
+ ..;for outgoing msgs, we just created the msgid, for incoming msgs we already had it
+ ..S:HLMSTATE("DIRECTION")="OUT" ACKTO("ACK BY")=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_SUBIEN
+ ..;
+ ..D ACKTO(.HLMSTATE,.ACKTO)
+ .K HLMSTATE("BATCH","ACK TO")
+ ;
+ ;if the msg is an app ack, update the original if not done already
+ I $G(HLMSTATE("ACK TO","IEN"))]"",'$G(HLMSTATE("ACK TO","DONE")) D
+ .N ACKTO
+ .M ACKTO=HLMSTATE("ACK TO")
+ .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+ .D ACKTO(.HLMSTATE,.ACKTO)
+ .S HLMSTATE("ACK TO","DONE")=1 ;so the update isn't done again
+ ;
+ Q HLMSTATE("IEN")
+ ;
+NEXTMSG(HLMSTATE,MSG) ;
+ ;Traverses file 777 to return the next message in the batch - as
+ ;indicated by HLMSTATE("BATCH","CURRENT MESSAGE")  Set to 0 to start,
+ ;returns 0 when there are no more messages
+ ;
+ ;Input:  HLMSTATE (pass by reference,required)
+ ;Output:
+ ;  HLMSTATE
+ ;     ("BATCH","CURRENT MESSAGE")
+ ;  MSG -pass by reference:
+ ;     ("EVENT")
+ ;     ("MESSAGE TYPE")
+ ;
+ ;
+ N SUBIEN,NODE
+ K MSG
+ Q:'$G(HLMSTATE("BODY")) 0
+ S SUBIEN=$O(^HLA(HLMSTATE("BODY"),2,HLMSTATE("BATCH","CURRENT MESSAGE")))
+ Q:'SUBIEN 0
+ S NODE=$G(^HLA(HLMSTATE("BODY"),2,SUBIEN,0))
+ S MSG("MESSAGE TYPE")=$P(NODE,"^",2)
+ S MSG("EVENT")=$P(NODE,"^",3)
+ S HLMSTATE("BATCH","CURRENT MESSAGE")=SUBIEN
+ Q SUBIEN
+ ;
+ACKTO(HLMSTATE,ACKTO) ;if this is an application ack, update the original message - but do not overlay if already valued
+ ;ACKTO = (msgid of msg being ack'd)
+ ;        uses these subscripts ("IEN"=ien^subien),("ACK BY"=msgid of acking msg),("STATUS"=status for the initial msg determined by the ack)
+ ;
+ N STATUS,IEN,SUBIEN,NODE,SKIP
+ S SKIP=0
+ S STATUS=$G(ACKTO("STATUS"))
+ S IEN=+ACKTO("IEN"),SUBIEN=$P(ACKTO("IEN"),"^",2)
+ S NODE=$G(^HLB(IEN,0))
+ I 'SUBIEN D
+ .;ack is to a message NOT in a batch
+ .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=ACKTO("ACK BY") S SKIP=1 Q
+ .I STATUS="" S STATUS="SU"
+ .S $P(NODE,"^",7)=ACKTO("ACK BY")
+ .S $P(NODE,"^",20)=STATUS
+ .S $P(NODE,"^",21)=$G(ACKTO("ERROR TEXT"))
+ .S ^HLB(IEN,0)=NODE
+ E  D
+ .;ack is to a message that IS in a batch
+ .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY"))
+ .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS
+ I (STATUS="AE"),'SKIP D
+ .N APP
+ .S APP=HLMSTATE("HDR","SENDING APPLICATION")
+ .I APP="" S APP="UNKNOWN"
+ .S ^HLB("ERRORS","AE",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
+ .;don't count the error - the app ack was already counted as an error.
+ .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m

-              r613
+              r623
+HLOF778A        ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ;
+NEW(HLMSTATE)   ;
+        ;This function creates a new entry in file 778.
+        ;Input:
+        ;   HLMSTATE (required, pass by reference) These subscripts are expected:
+        ;
+        ;Output - the function returns the ien of the newly created record
+        ;
+        N IEN,NODE,ID,STAT
+        S STAT="HLMSTATE(""STATUS"")"
+        S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP)
+        Q:'IEN 0
+        S HLMSTATE("IEN")=IEN
+        ;
+        D  ;build the message header
+        .N HDR
+        .;for incoming messages the header segment should already exist
+        .;for outgoing messages must build the header segment
+        .I HLMSTATE("DIRECTION")="OUT" D  Q
+        ..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO")
+        ..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR)
+        ..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2)
+        ;
+        K ^HLB(IEN)
+        S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+        S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^"
+        S $P(NODE,"^",5)=$G(@STAT@("LINK NAME"))
+        S $P(NODE,"^",6)=$G(@STAT@("QUEUE"))
+        S $P(NODE,"^",8)=$G(@STAT@("PORT"))
+        S $P(NODE,"^",20)=$G(@STAT)
+        S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT"))
+        S $P(NODE,"^",16)=HLMSTATE("DT/TM")
+        ;
+        I HLMSTATE("DIRECTION")="OUT" D
+        .S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^")
+        .S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2)
+        .S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^")
+        .S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2)
+        .S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^")
+        .S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2)
+        .;
+        .;for outgoing set these x-refs now, for incoming msgs set them later
+        .S ^HLB("B",ID,IEN)=""
+        .S ^HLB("C",HLMSTATE("BODY"),IEN)=""
+        .I ($G(@STAT)="ER") D
+        ..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
+        ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+        .;
+        .;save some space for the ack
+        .S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^                                                                 "
+        I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))=""
+        S ^HLB(IEN,0)=NODE
+        ;
+        ;store the message header
+        S ^HLB(IEN,1)=HLMSTATE("HDR",1)
+        S ^HLB(IEN,2)=HLMSTATE("HDR",2)
+        ;
+        ;if the msg is an app ack, update the original msg
+        I $G(HLMSTATE("ACK TO","IEN"))]"" D
+        .N ACKTO
+        .M ACKTO=HLMSTATE("ACK TO")
+        .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+        .D ACKTO^HLOF778(.HLMSTATE,.ACKTO)
+        .S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again
+        ;
+        ;The "SEARCH" x-ref will be created asynchronously
+        S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
+        ;
+        ;sequence q?
+        I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
+        ;
+        Q IEN
+        ;
+NEWIEN(DIR,TCP) ;
+        ;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record.
+        ;Inputs:
+        ;  DIR = "IN" or "OUT" (required)
+        ;  TCP = 1,0 (optional)
+        ;Output - the function returns the next available ien. Several counters are used:
+        ;
+        ;   <"OUT","TCP">
+        ;   <"OUT","NOT TCP">
+        ;   <"IN","TCP">
+        ;   <"IN","NOT TCP">
+        ;
+        N IEN,COUNTER,INC
+        I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000)
+        I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000)
+        S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP")))
+AGAIN   ;
+        S IEN=$$INC^HLOSITE(COUNTER,1)
+        I IEN>100000000000 D
+        .L +@COUNTER:200
+        .I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1
+        .L -@COUNTER
+        I IEN>100000000000 G AGAIN
+        Q (IEN+INC)
+        ;
+TCP()   ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined
+        N IEN,TCP
+        S TCP=1
+        S IEN=$G(HLMSTATE("STATUS","LINK IEN"))
+        I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0
+        Q TCP
+        ;
+GETWORK(WORK)   ; Used by the Process Manager.
+        ;Are there any messages that need the "SEARCH" x-ref set?
+        ;Inputs:
+        ;  WORK (required, pass-by-reference)
+        ;    ("DOLLARJ")
+        ;    ("NOW") (required by the process manager, pass-by-reference)
+        ;
+        L +^HLTMP("PENDING SEARCH X-REF"):0
+        Q:'$T 0
+        N OLD,DOLLARJ,SUCCESS,NOW
+        S SUCCESS=0
+        S NOW=$$SEC^XLFDT($H)
+        S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
+        F  S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ=""  D  Q:SUCCESS
+        .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+        .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1
+        ;
+        I OLD'="",'SUCCESS F  S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ=""  Q:DOLLARJ>OLD  D  Q:SUCCESS
+        .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+        .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1
+        S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
+        Q:WORK("DOLLARJ")]"" 1
+        L -^HLTMP("PENDING SEARCH X-REF")
+        Q 0
+        ;
+DOWORK(WORK)    ;Used by the Process Manager
+        ;Sets the "SEARCH" x-ref, running 100 seconds behind when the message record was created.
+        ;
+        N MSGIEN,TIME
+        S TIME=0
+        F  S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME  Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<100)  D
+        .S MSGIEN=0
+        .F  S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN  D
+        ..N MSG
+        ..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D
+        ...Q:'MSG("DT/TM CREATED")
+        ...I MSG("BATCH") D
+        ....N HDR
+        ....F  Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR)  S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG)
+        ...E  D
+        ....D SET(.MSG)
+        ..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)
+        L -^HLTMP("PENDING SEARCH X-REF")
+        Q
+        ;
+SET(MSG)        ;
+        ;sets the ^HLB("SEARCH") x-ref
+        ;
+        N APP,FS,CS,IEN
+        I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
+        S FS=$E(MSG("HDR",1),4)
+        Q:FS=""
+        S CS=$E(MSG("HDR",1),5)
+        S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS))
+        I APP="" S APP="UNKNOWN"
+        I MSG("BATCH") D
+        .N VALUE
+        .S VALUE=$P(MSG("HDR",2),FS,4)
+        .S MSG("MESSAGE TYPE")=$P(VALUE,CS)
+        .S MSG("EVENT")=$P(VALUE,CS,2)
+        S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="<none>"
+        S:MSG("EVENT")="" MSG("EVENT")="<none>"
+        S IEN=MSG("IEN")
+        I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE")
+        S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)=""
+        Q
+HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;
+NEW(HLMSTATE) ;
+ ;This function creates a new entry in file 778.
+ ;Input:
+ ;   HLMSTATE (required, pass by reference) These subscripts are expected:
+ ;
+ ;Output - the function returns the ien of the newly created record
+ ;
+ N IEN,NODE,ID,STAT
+ S STAT="HLMSTATE(""STATUS"")"
+ S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP)
+ Q:'IEN 0
+ S HLMSTATE("IEN")=IEN
+ ;
+ D  ;build the message header
+ .N HDR
+ .;for incoming messages the header segment should already exist
+ .;for outgoing messages must build the header segment
+ .I HLMSTATE("DIRECTION")="OUT" D  Q
+ ..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO")
+ ..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR)
+ ..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2)
+ ;
+ K ^HLB(IEN)
+ S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+ S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^"
+ S $P(NODE,"^",5)=$G(@STAT@("LINK NAME"))
+ S $P(NODE,"^",6)=$G(@STAT@("QUEUE"))
+ S $P(NODE,"^",8)=$G(@STAT@("PORT"))
+ S $P(NODE,"^",20)=$G(@STAT)
+ S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT"))
+ S $P(NODE,"^",16)=HLMSTATE("DT/TM")
+ ;
+ I HLMSTATE("DIRECTION")="OUT" D
+ .S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^")
+ .S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2)
+ .S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^")
+ .S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2)
+ .S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^")
+ .S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2)
+ .;
+ .;for outgoing set these x-refs now, for incoming msgs set them later
+ .S ^HLB("B",ID,IEN)=""
+ .S ^HLB("C",HLMSTATE("BODY"),IEN)=""
+ .I ($G(@STAT)="SE") D
+ ..S ^HLB("ERRORS","SE",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
+ ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+ .;
+ .;save some space for the ack
+ .S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^                                                                 "
+ I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))=""
+ S ^HLB(IEN,0)=NODE
+ ;
+ ;store the message header
+ S ^HLB(IEN,1)=HLMSTATE("HDR",1)
+ S ^HLB(IEN,2)=HLMSTATE("HDR",2)
+ ;
+ ;if the msg is an app ack, update the original msg
+ I $G(HLMSTATE("ACK TO","IEN"))]"" D
+ .N ACKTO
+ .M ACKTO=HLMSTATE("ACK TO")
+ .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+ .D ACKTO^HLOF778(.HLMSTATE,.ACKTO)
+ .S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again
+ ;
+ ;The "SEARCH" x-ref will be created asynchronously
+ S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
+ ;
+ Q IEN
+ ;
+NEWIEN(DIR,TCP) ;
+ ;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record.
+ ;Inputs:
+ ;  DIR = "IN" or "OUT" (required)
+ ;  TCP = 1,0 (optional)
+ ;Output - the function returns the next available ien. Several counters are used:
+ ;
+ ;   <"OUT","TCP">
+ ;   <"OUT","NOT TCP">
+ ;   <"IN","TCP">
+ ;   <"IN","NOT TCP">
+ ;
+ N IEN,COUNTER,INC
+ I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000)
+ I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000)
+ S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP")))
+AGAIN ;
+ S IEN=$$INC^HLOSITE(COUNTER,1)
+ I IEN>100000000000 D
+ .L +@COUNTER:200
+ .I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1
+ .L -@COUNTER
+ I IEN>100000000000 G AGAIN
+ Q (IEN+INC)
+ ;
+TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined
+ N IEN,TCP
+ S TCP=1
+ S IEN=$G(HLMSTATE("STATUS","LINK IEN"))
+ I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0
+ Q TCP
+ ;
+GETWORK(WORK) ; Used by the Process Manager.
+ ;Are there any messages that need the "SEARCH" x-ref set?
+ ;Inputs:
+ ;  WORK (required, pass-by-reference)
+ ;    ("DOLLARJ")
+ ;    ("NOW") (required by the process manager, pass-by-reference)
+ ;
+ L +^HLTMP("PENDING SEARCH X-REF"):0
+ Q:'$T 0
+ N OLD,DOLLARJ,SUCCESS,NOW
+ S SUCCESS=0
+ S NOW=$$SEC^XLFDT($H)
+ S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
+ F  S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ=""  D  Q:SUCCESS
+ .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+ .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1
+ ;
+ I OLD'="",'SUCCESS F  S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ=""  Q:DOLLARJ>OLD  D  Q:SUCCESS
+ .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+ .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1
+ S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
+ Q:WORK("DOLLARJ")]"" 1
+ L -^HLTMP("PENDING SEARCH X-REF")
+ Q 0
+ ;
+DOWORK(WORK) ;Used by the Process Manager
+ ;Sets the "SEARCH" x-ref, running 100 seconds behind when the message record was created.
+ ;
+ N MSGIEN,TIME
+ S TIME=0
+ F  S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME  Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<100)  D
+ .S MSGIEN=0
+ .F  S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN  D
+ ..N MSG
+ ..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D
+ ...Q:'MSG("DT/TM CREATED")
+ ...I MSG("BATCH") D
+ ....N HDR
+ ....F  Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR)  S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG)
+ ...E  D
+ ....D SET(.MSG)
+ ..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)
+ L -^HLTMP("PENDING SEARCH X-REF")
+ Q
+ ;
+SET(MSG) ;
+ ;sets the ^HLB("SEARCH") x-ref
+ ;
+ N APP,FS,CS,IEN
+ I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
+ S FS=$E(MSG("HDR",1),4)
+ Q:FS=""
+ S CS=$E(MSG("HDR",1),5)
+ S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS))
+ I APP="" S APP="UNKNOWN"
+ I MSG("BATCH") D
+ .N VALUE
+ .S VALUE=$P(MSG("HDR",2),FS,4)
+ .S MSG("MESSAGE TYPE")=$P(VALUE,CS)
+ .S MSG("EVENT")=$P(VALUE,CS,2)
+ S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="<none>"
+ S:MSG("EVENT")="" MSG("EVENT")="<none>"
+ S IEN=MSG("IEN")
+ I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE")
+ S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)=""
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m

-              r613
+              r623
 HLOFILER        ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
         ;GET WORK function for the process running under the Process Manager
 GETWORK(QUE)    ;
         ;Input:
         ;  QUE - (pass by reference) These subscripts are used:
         ;    ("FROM") - sending facility last obtained
         ;    ("QUEUE") - name of the queue last obtained
         ;Output:
         ;  Function returns 1 if success, 0 if no more work
         ;  QUE-  updated to identify next queu of messages to process.
+        ;
         N FROM,QUEUE
         I '$D(QUE("SYSTEM")) D
         .N SYS
         .D SYSPARMS^HLOSITE(.SYS)
         .S QUE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE")
         .S QUE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE")
         S FROM=$G(QUE("FROM")),QUEUE=$G(QUE("QUEUE"))
         I ($G(FROM)]""),($G(QUEUE)]"") D
         .L -^HLB("QUEUE","IN",FROM,QUEUE)
         .F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0  Q:$T
         I ($G(FROM)]""),($G(QUEUE)="") D
         .F  S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM=""  D  Q:($G(QUEUE)]"")
         ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T
         I FROM="" D
         .F  S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM=""  D  Q:($G(QUEUE)]"")
         ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T
         S QUE("FROM")=FROM,QUE("QUEUE")=QUEUE
         Q:(QUEUE]"") 1
         Q 0
+        ;
 DOWORK(QUEUE)   ;sends the messages on the queue
         N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOFILER"
+        ;
         N MSGIEN,DEQUE,QUE
         M QUE=QUEUE
         S DEQUE=0
         S MSGIEN=0
+        ;
         F  S MSGIEN=$O(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN  D  M QUEUE=QUE
         .N MCODE,ACTION,QUE,PURGE,ACKTOIEN,NODE
         .N $ETRAP,$ESTACK S $ETRAP="G ERROR2^HLOFILER"
         .S NODE=$G(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN))
         .S ACTION=$P(NODE,"^",1,2)
         .S PURGE=$P(NODE,"^",3)
         .S ACKTOIEN=$P(NODE,"^",4)
         .D DEQUE(MSGIEN,PURGE,ACKTOIEN)
         .I ACTION]"" D
         ..N HLMSGIEN,MCODE,DEQUE,DUZ
         ..N $ETRAP,$ESTACK S $ETRAP="G ERROR3^HLOFILER"
         ..S HLMSGIEN=MSGIEN
         ..S MCODE="D "_ACTION
         ..N MSGIEN,X
         ..D DUZ^XUP(.5)
         ..X MCODE
         ..;kill the apps variables
         ..D
         ...N ZTSK
         ...D KILL^XUSCLEAN
+        ;
 ENDWORK ;where the execution resumes upon an error
         D DEQUE()
+        Q
+        ;
 DEQUE(MSGIEN,PURGE,ACKTOIEN)    ;
         ;Dequeues the message.  Also sets up the purge dt/tm and the completion status.
         S:$G(MSGIEN) DEQUE=$G(DEQUE)+1,DEQUE(MSGIEN)=PURGE_"^"_ACKTOIEN
         I '$G(MSGIEN)!($G(DEQUE)>25) S MSGIEN=0 D
         .F  S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN  D
         ..N NODE,PURGE,ACKTOIEN
         ..S NODE=DEQUE(MSGIEN)
         ..S PURGE=$P(NODE,"^"),ACKTOIEN=$P(NODE,"^",2)
         ..D DEQUE^HLOQUE(QUEUE("FROM"),QUEUE("QUEUE"),"IN",MSGIEN)
         ..S NODE=$G(^HLB(MSGIEN,0))
         ..Q:NODE=""
         ..S $P(NODE,"^",19)=1 ;sets the flag to show that the app handoff was done
         ..D:PURGE
         ...N STATUS
         ...S STATUS=$P(NODE,"^",20)
         ...S:STATUS="" $P(NODE,"^",20)="SU",STATUS="SU"
         ...S $P(NODE,"^",9)=$$FMADD^XLFDT($$NOW^XLFDT,,$S(PURGE=2:24*QUEUE("SYSTEM","ERROR PURGE"),$D(^HLB(MSGIEN,3,1,0)):24*QUEUE("SYSTEM","ERROR PURGE"),1:QUEUE("SYSTEM","NORMAL PURGE")))
         ...S ^HLB("AD",$S($E($P(NODE,"^",4))="I":"IN",1:"OUT"),$P(NODE,"^",9),MSGIEN)=""
         ...I ACKTOIEN,$D(^HLB(ACKTOIEN,0)) S $P(^HLB(ACKTOIEN,0),"^",9)=$P(NODE,"^",9),^HLB("AD",$S($E($P(NODE,"^",4))="I":"OUT",1:"IN"),$P(NODE,"^",9),ACKTOIEN)=""
         ..S ^HLB(MSGIEN,0)=NODE
         .K DEQUE S DEQUE=0
+        Q
+        ;
 ERROR   ;error trap
         S $ETRAP="Q:$QUIT """" Q"
         N HOUR
         S HOUR=$E($$NOW^XLFDT,1,10)
         S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+        ;
         D DEQUE()
+        ;
         ;a lot of errors of the same type may indicate an endless loop
         ;return to the Process Manager error trap
         I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+        ;
         ;while debugging quit on all errors - returns to the Process Manager error trap
         I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
         I $ECODE["EDITED" Q:$QUIT "" Q
+        ;
         D ^%ZTER
         D UNWIND^%ZTER
         Q:$QUIT ""
+        Q
+        ;
 ERROR2  ;
         S $ETRAP="Q:$QUIT """" Q"
+        ;
         D DEQUE()
+        ;
         ;may need to change the status to Error
+        D
         .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW
         .S NOW=$$NOW^XLFDT
         .S NODE=$G(^HLB(MSGIEN,0))
         .Q:NODE=""
         .Q:$P(NODE,"^",20)="ER"
         .S $P(NODE,"^",20)="ER",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
         .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
         .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)
         .S $P(NODE,"^",9)=$$FMADD^XLFDT(NOW,,24*QUEUE("SYSTEM","ERROR PURGE"))
         .S ^HLB(MSGIEN,0)=NODE
         .S ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)=""
         .S HDR=$G(^HLB(MSGIEN,1))
         .S FS=$E(HDR,4)
         .Q:FS=""
         .S CS=$E(HDR,5)
         .S REP=$E(HDR,6)
         .S ESCAPE=$E(HDR,7)
         .S SUBCOMP=$E(HDR,8)
         .S RAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE)
         .I RAPP="" S RAPP="UNKNOWN"
         .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
         .S ^HLB("ERRORS",RAPP,NOW,MSGIEN)=""
         .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN")
+        ;
         ;kill the apps variables
+        D
         .N ZTSK,MSGIEN,QUEUE
         .D KILL^XUSCLEAN
+        ;
         ;release all the locks the app may have set, except Taskman lock
         L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1
         L:'$D(ZTSK)
         ;reset HLO's lock
         L +^HLTMP("HL7 RUNNING PROCESSES",$J):0
         ;return to processing the next message on the queue
         S $ECODE=""
+        ;
         Q:$QUIT ""
+        Q
 ERROR3  ;error trap for application context
         S $ETRAP="Q:$QUIT """" Q"
         D ^%ZTER
         S $ECODE=",UAPPLICATION ERROR,"
+        ;
         ;drop to the ERROR2 error handler
         Q:$QUIT ""
+        Q
+HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;03/28/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;GET WORK function for the process running under the Process Manager
+GETWORK(QUE) ;
+ ;Input:
+ ;  QUE - (pass by reference) These subscripts are used:
+ ;    ("FROM") - sending facility last obtained
+ ;    ("QUEUE") - name of the queue last obtained
+ ;Output:
+ ;  Function returns 1 if success, 0 if no more work
+ ;  QUE-  updated to identify next queu of messages to process.
+ ;
+ N FROM,QUEUE
+ I '$D(QUE("SYSTEM")) D
+ .N SYS
+ .D SYSPARMS^HLOSITE(.SYS)
+ .S QUE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE")
+ .S QUE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE")
+ S FROM=$G(QUE("FROM")),QUEUE=$G(QUE("QUEUE"))
+ I ($G(FROM)]""),($G(QUEUE)]"") D
+ .L -^HLB("QUEUE","IN",FROM,QUEUE)
+ .F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0  Q:$T
+ I ($G(FROM)]""),($G(QUEUE)="") D
+ .F  S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM=""  D  Q:($G(QUEUE)]"")
+ ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T
+ I FROM="" D
+ .F  S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM=""  D  Q:($G(QUEUE)]"")
+ ..S QUEUE="" F  S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="")  I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T
+ S QUE("FROM")=FROM,QUE("QUEUE")=QUEUE
+ Q:(QUEUE]"") 1
+ Q 0
+ ;
+DOWORK(QUEUE) ;sends the messages on the queue
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOFILER"
+ ;
+ N MSGIEN,DEQUE,QUE
+ M QUE=QUEUE
+ S DEQUE=0
+ S MSGIEN=0
+ ;
+ F  S MSGIEN=$O(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN  D  M QUEUE=QUE
+ .N MCODE,ACTION,QUE,PURGE,ACKTOIEN,NODE
+ .N $ETRAP,$ESTACK S $ETRAP="G ERROR2^HLOFILER"
+ .S NODE=$G(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN))
+ .S ACTION=$P(NODE,"^",1,2)
+ .S PURGE=$P(NODE,"^",3)
+ .S ACKTOIEN=$P(NODE,"^",4)
+ .D DEQUE(MSGIEN,PURGE,ACKTOIEN)
+ .I ACTION]"" D
+ ..N HLMSGIEN,MCODE,DEQUE,DUZ
+ ..N $ETRAP,$ESTACK S $ETRAP="G ERROR3^HLOFILER"
+ ..S HLMSGIEN=MSGIEN
+ ..S MCODE="D "_ACTION
+ ..N MSGIEN,X
+ ..D DUZ^XUP(.5)
+ ..X MCODE
+ ..;kill the apps variables
+ ..D
+ ...N ZTSK
+ ...D KILL^XUSCLEAN
+ ;
+ENDWORK ;where the execution resumes upon an error
+ D DEQUE()
+ Q
+ ;
+DEQUE(MSGIEN,PURGE,ACKTOIEN) ;
+ ;Dequeues the message.  Also sets up the purge dt/tm and the completion status.
+ S:$G(MSGIEN) DEQUE=$G(DEQUE)+1,DEQUE(MSGIEN)=PURGE_"^"_ACKTOIEN
+ I '$G(MSGIEN)!($G(DEQUE)>25) S MSGIEN=0 D
+ .F  S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN  D
+ ..N NODE,PURGE,ACKTOIEN
+ ..S NODE=DEQUE(MSGIEN)
+ ..S PURGE=$P(NODE,"^"),ACKTOIEN=$P(NODE,"^",2)
+ ..D DEQUE^HLOQUE(QUEUE("FROM"),QUEUE("QUEUE"),"IN",MSGIEN)
+ ..S NODE=$G(^HLB(MSGIEN,0))
+ ..Q:NODE=""
+ ..S $P(NODE,"^",19)=1 ;sets the flag to show that the app handoff was done
+ ..D:PURGE
+ ...N STATUS
+ ...S STATUS=$P(NODE,"^",20)
+ ...S:STATUS="" $P(NODE,"^",20)="SU",STATUS="SU"
+ ...S $P(NODE,"^",9)=$$FMADD^XLFDT($$NOW^XLFDT,,$S(PURGE=2:24*QUEUE("SYSTEM","ERROR PURGE"),$D(^HLB(MSGIEN,3,1,0)):24*QUEUE("SYSTEM","ERROR PURGE"),1:QUEUE("SYSTEM","NORMAL PURGE")))
+ ...S ^HLB("AD",$S($E($P(NODE,"^",4))="I":"IN",1:"OUT"),$P(NODE,"^",9),MSGIEN)=""
+ ...I ACKTOIEN,$D(^HLB(ACKTOIEN,0)) S $P(^HLB(ACKTOIEN,0),"^",9)=$P(NODE,"^",9),^HLB("AD",$S($E($P(NODE,"^",4))="I":"OUT",1:"IN"),$P(NODE,"^",9),ACKTOIEN)=""
+ ..S ^HLB(MSGIEN,0)=NODE
+ .K DEQUE S DEQUE=0
+ Q
+ ;
+ERROR ;error trap
+ S $ETRAP="Q:$QUIT """" Q"
+ N HOUR
+ S HOUR=$E($$NOW^XLFDT,1,10)
+ S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+ ;
+ D DEQUE()
+ ;
+ ;a lot of errors of the same type may indicate an endless loop
+ ;return to the Process Manager error trap
+ I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+ ;
+ ;while debugging quit on all errors - returns to the Process Manager error trap
+ I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
+ I $ECODE["EDITED" Q:$QUIT "" Q
+ ;
+ D ^%ZTER
+ D UNWIND^%ZTER
+ Q:$QUIT ""
+ Q
+ ;
+ERROR2 ;
+ S $ETRAP="Q:$QUIT """" Q"
+ ;
+ D DEQUE()
+ ;
+ ;may need to change the status to Application Error
+ D
+ .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW
+ .S NOW=$$NOW^XLFDT
+ .S NODE=$G(^HLB(MSGIEN,0))
+ .Q:NODE=""
+ .Q:$P(NODE,"^",20)="AE"
+ .S $P(NODE,"^",20)="AE",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
+ .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
+ .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)
+ .S $P(NODE,"^",9)=$$FMADD^XLFDT(NOW,,24*QUEUE("SYSTEM","ERROR PURGE"))
+ .S ^HLB(MSGIEN,0)=NODE
+ .S ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)=""
+ .S HDR=$G(^HLB(MSGIEN,1))
+ .S FS=$E(HDR,4)
+ .Q:FS=""
+ .S CS=$E(HDR,5)
+ .S REP=$E(HDR,6)
+ .S ESCAPE=$E(HDR,7)
+ .S SUBCOMP=$E(HDR,8)
+ .S RAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+ .I RAPP="" S RAPP="UNKNOWN"
+ .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
+ .S ^HLB("ERRORS","AE",RAPP,NOW,MSGIEN)=""
+ .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN")
+ ;
+ ;kill the apps variables
+ D
+ .N ZTSK,MSGIEN,QUEUE
+ .D KILL^XUSCLEAN
+ ;
+ ;release all the locks the app may have set, except Taskman lock
+ L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1
+ L:'$D(ZTSK)
+ ;reset HLO's lock
+ L +^HLTMP("HL7 RUNNING PROCESSES",$J):0
+ ;return to processing the next message on the queue
+ S $ECODE=""
+ ;
+ Q:$QUIT ""
+ Q
+ERROR3 ;error trap for application context
+ S $ETRAP="Q:$QUIT """" Q"
+ D ^%ZTER
+ S $ECODE=",UAPPLICATION ERROR,"
+ ;
+ ;drop to the ERROR2 error handler
+ Q:$QUIT ""
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m

-              r613
+              r623
+HLOMSG  ;ALB/CJM-HL7 - APIs for files 777/778 ;07/25/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+GETMSG(IEN,MSG) ;
+        ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below.
+        ;Input:
+        ;  IEN - the ien of the message in file 778
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure
+        ;  MSG (pass by reference, required) These are the subscripts returned:
+        ;
+        ;   "ACK BY" - msg id of msg that acknowledges this one
+        ;   "ACK BY IEN" - msg IEN of msg that acknowledges this one.  If the message is in the batch, the value is <ien>^<subien>
+        ;   "ACK TO" - msg id of msg that this msg acknowledges
+        ;   "ACK TO IEN" - msg IEN of msg that this msg acknowledges. If the message is in a batch, the value is <ien>^<subien>
+        ;  "BATCH"  = 1 if this is a batch message, 0  if not
+        ;     "CURRENT MESSAGE" - defined only for batch messages -  a counter used during building and parsing messages to indicate the current message.  It will be set to 0 initially.
+        ;  "BODY" - ptr to file 778 which contains the body of the message.
+        ;  "DIRECTION" - "IN" if incoming, "OUT" if outgoing
+        ;  "DT/TM" - date/time the message was sent or received
+        ;  "DT/TM CREATED" - date/time the record was created (.01 field, file #777)
+        ;  "LINE COUNT" -  a counter used during building and parsing of
+        ;     messages to indicate the current line within the message. For
+        ;     batch messages where each message within the batch is stored
+        ;     separately, this field indicates the position within the current
+        ;     individual message
+        ;  "HDR" - the header segment, NOT parsed, as HDR(1) and HDR(2)
+        ;  "ID" - Message Control ID for an individual message, Batch Control ID for a batch message
+        ;  "IEN" - ien, file 778
+        ;  "EVENT" - HL7 event, only defined if NOT batch
+        ;  "MESSAGE TYPE" - HL7 message type, only defined if NOT batch
+        ;  "STATUS" - the completion status
+        ;
+        ;     These are lower level subscripts of "STATUS":
+        ;     "ACCEPT ACK RESPONSE" - the application's <tag>^<rtn> to Xecute when the accept ack is received
+        ;     "ACCEPT ACK'D" - 1 if an accept ack was sent or received in response to this message
+        ;     "APP ACK RESPONSE" - the application's <tag>^<rtn> to Xecute when app ack is received
+        ;     "APP ACK'D" - 1 if an application ack was sent or received in response to this message
+        ;     "ERROR TEXT" - if in error status, a description of the error
+        ;     "LINK NAME" the link the message was transmitted through
+        ;     "PORT" - remote port over which the message was transmitted
+        ;     "PURGE" - scheduled purge dt/tm
+        ;     "QUEUE" - the queue that the message was placed on
+        ;     "SEQUENCE QUEUE" - the sequence queue (optional)
+        ;
+        K MSG
+        Q:'$G(IEN) 0
+        N NODE
+        S MSG("IEN")=IEN
+        S NODE=$G(^HLB(IEN,0))
+        S MSG("ID")=$P(NODE,"^")
+        S MSG("BODY")=$P(NODE,"^",2)
+        S MSG("DIRECTION")=$S($E($P(NODE,"^",4))="O":"OUT",$E($P(NODE,"^",4))="I":"IN",1:"")
+        S MSG("ACK TO")=$P(NODE,"^",3)
+        S MSG("ACK BY")=$P(NODE,"^",7)
+        I MSG("ACK TO")]"" S MSG("ACK TO IEN")=$$ACKTOIEN^HLOMSG1($P(NODE,"^"),MSG("ACK TO"))
+        I MSG("ACK BY")]"" S MSG("ACK BY IEN")=$$ACKBYIEN^HLOMSG1($P(NODE,"^"),MSG("ACK BY"))
+        S MSG("DT/TM")=$P(NODE,"^",16)
+        S MSG("STATUS")=$P(NODE,"^",20)
+        ;
+        D
+        .N NODE4
+        .S NODE4=$G(^HLB(IEN,4))
+        .S MSG("STATUS","QUEUE")=$P(NODE,"^",6)
+        .S MSG("STATUS","LINK NAME")=$P(NODE,"^",5)
+        .S MSG("STATUS","PORT")=$P(NODE,"^",8)
+        .S MSG("STATUS","PURGE")=$P(NODE,"^",9)
+        .S MSG("STATUS","ERROR TEXT")=$P(NODE,"^",21)
+        .S MSG("STATUS","APP ACK RESPONSE")=$P(NODE,"^",10,11)
+        .I MSG("STATUS","APP ACK RESPONSE")="^" S MSG("STATUS","APP ACK RESPONSE")=""
+        .S MSG("STATUS","ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13)
+        .I MSG("STATUS","ACCEPT ACK RESPONSE")="^" S MSG("STATUS","ACCEPT ACK RESPONSE")=""
+        .S MSG("STATUS","ACCEPT ACK'D")=$P(NODE,"^",17)
+        .S MSG("STATUS","APP ACK'D")=$P(NODE,"^",18)
+        .S MSG("STATUS")=$P(NODE,"^",20)
+        .S MSG("STATUS","APP HANDOFF")=$P(NODE,"^",19)
+        .S MSG("STATUS","ACCEPT ACK DT/TM")=$P(NODE4,"^")
+        .S MSG("STATUS","ACCEPT ACK ID")=$P(NODE4,"^",2)
+        .S MSG("STATUS","ACCEPT ACK MSA")=$P(NODE4,"^",3,99)
+        ;
+        S MSG("LINE COUNT")=0
+        S MSG("HDR",1)=$G(^HLB(IEN,1))
+        S MSG("HDR",2)=$G(^HLB(IEN,2))
+        I 'MSG("BODY") D  Q 0
+        .S MSG("DT/TM CREATED")=""
+        .S MSG("BATCH")=""
+        .S MSG("MESSAGE TYPE")=""
+        .S MSG("EVENT")=""
+        ;
+        S NODE=$G(^HLA(MSG("BODY"),0))
+        S MSG("DT/TM CREATED")=+NODE
+        S MSG("BATCH")=+$P(NODE,"^",2)
+        I MSG("BATCH") S MSG("BATCH","CURRENT MESSAGE")=0
+        I 'MSG("BATCH") D
+        .S MSG("MESSAGE TYPE")=$P(NODE,"^",3)
+        .S MSG("EVENT")=$P(NODE,"^",4)
+        I MSG("DIRECTION")="OUT" D
+        .N NODE5
+        .S NODE5=$G(^HLB(IEN,5))
+        .S MSG("STATUS","SEQUENCE QUEUE")=$P(NODE5,"^")
+        .S MSG("STATUS","MOVED TO OUT QUEUE")=$P(NODE5,"^",2)
+        .S MSG("STATUS","SEQUENCE EXCEPTION RAISED")=$P(NODE5,"^",3)
+        Q 1
+        ;
+HLNEXT(MSG,SEG) ;
+        ;Description:  Returns the next segment as a set of lines stored in SEG.
+        ;Input:
+        ;  MSG (pass by reference, required)
+        ;Output:
+        ;  Function returns 1 on success, 0 on failure (no more segments)
+        ;  SEG (pass by reference, required)
+        ;
+        K SEG
+        Q:MSG("LINE COUNT")=-1 0
+        I 'MSG("BATCH") D
+        .N I,J,NODE,START
+        .S START=0
+        .S J=1,I=MSG("LINE COUNT")
+        .F  S I=$O(^HLA(MSG("BODY"),1,I)) Q:'I  S NODE=$G(^HLA(MSG("BODY"),1,I,0)) Q:(START&(NODE=""))  I NODE'="" S SEG(J)=NODE,J=J+1,START=1
+        .I 'I D
+        ..S MSG("LINE COUNT")=-1
+        .E  S MSG("LINE COUNT")=I
+        I MSG("BATCH") D
+        .N I,J,NODE,START
+        .S J=1,I=MSG("LINE COUNT"),START=0
+        .F  S I=$O(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I)) Q:'I  S NODE=$G(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I,0)) Q:(START&(NODE=""))  I NODE'="" S SEG(J)=NODE,J=J+1,START=1
+        .I 'I D
+        ..S MSG("LINE COUNT")=-1
+        .E  S MSG("LINE COUNT")=I
+        Q $S($D(SEG):1,1:0)
+        ;
+NEXTMSG(MSG,HDR)        ;
+        ;Advances to the next message in the batch
+        ;Input:
+        ;  MSG (pass by reference, required) - defined by $$GETMSG()
+        ;Output:
+        ;  Function returns 1 on success, 0 if no more messages
+        ;  MSG - updated with current position in the message
+        ;  HDR (pass by reference, required) returns the header as an array of lines
+        ;
+        ;
+        K HDR
+        S MSG("LINE COUNT")=0
+        N SUBIEN,I
+        ;
+        ;if completed parsing, don't start over
+        I MSG("BATCH","CURRENT MESSAGE")=-1 Q 0
+        ;
+        S I=$O(^HLB(MSG("IEN"),3,"B",MSG("BATCH","CURRENT MESSAGE")))
+        I 'I S MSG("BATCH","CURRENT MESSAGE")=-1 Q 0
+        S MSG("BATCH","CURRENT MESSAGE")=I
+        S SUBIEN=$O(^HLB(MSG("IEN"),3,"B",I,0))
+        S HDR(1)=$G(^HLB(MSG("IEN"),3,SUBIEN,1))
+        S HDR(2)=$G(^HLB(MSG("IEN"),3,SUBIEN,2))
+        Q $S($D(HDR):1,1:0)
+        ;
+ADDSEG(HLMSTATE,SEG)    ;Adds a segment to the message.
+        ;Input:
+        ;  HLMSTATE() - (pass by reference, required)
+        ;  SEG() - (pass by reference, required) The segment as lines SEG(<i>)
+        ;
+        ;Output:
+        ;   HLMSTATE()
+        ;
+        N I,J S I=0
+        S J=HLMSTATE("LINE COUNT")
+        ;
+        ;insure a blank line between segments
+        I J S J=J+1,HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=""
+        ;
+        S HLMSTATE("CURRENT SEGMENT")=HLMSTATE("CURRENT SEGMENT")+1
+        F  S I=$O(SEG(I)) Q:'I  D
+        .S J=J+1
+        .S HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=SEG(I),HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+$L(SEG(I))+50
+        .I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER") D
+        ..I HLMSTATE("DIRECTION")="IN",$$SAVEMSG^HLOF778(.HLMSTATE) Q
+        ..I HLMSTATE("DIRECTION")="OUT",$$SAVEMSG^HLOF777(.HLMSTATE)
+        ;
+        S HLMSTATE("LINE COUNT")=J
+        Q
+        ;
+ADDMSG(HLMSTATE,PARMS)  ;
+        ;For outgoing messages, adds a message in the batch. There is no MSH yet, just the message type and event.
+        ;Input:
+        ;  HLMSTATE() - (pass by reference, required)
+        ;  PARMS("EVENT")
+        ;  PARMS("MESSAGE TYPE")
+        ;
+        ;Output:
+        ;   HLMSTATE() - (pass by reference, required)
+        ;
+        N I
+        S I=HLMSTATE("BATCH","CURRENT MESSAGE")+1,HLMSTATE("BATCH","CURRENT MESSAGE")=I
+        S HLMSTATE("UNSTORED LINES",I)=PARMS("MESSAGE TYPE")_"^"_PARMS("EVENT")
+        M:$G(PARMS("ACK TO"))]"" HLMSTATE("BATCH","ACK TO",I)=PARMS("ACK TO")
+        S HLMSTATE("CURRENT SEGMENT")=0
+        S HLMSTATE("LINE COUNT")=0
+        S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+100
+        Q
+        ;
+ADDMSG2(HLMSTATE,MSH)   ;
+        ;For incoming messages adds a message to the batch. This differs from ADDMSG in that the MSH segment is passed in to be stored in file 778.
+        ;Input:
+        ;  HLMSTATE() - (pass by reference, required)
+        ;  MSH(<i>) - the MSH segment as a set of lines
+        ;
+        ;Output:
+        ;   HLMSTATE() - (pass by reference, required)
+        ;
+        N FS,CS,VALUE
+        S HLMSTATE("BATCH","CURRENT MESSAGE")=HLMSTATE("BATCH","CURRENT MESSAGE")+1
+        S FS=$E(MSH(1),4)
+        S CS=$E(MSH(1),5)
+        S VALUE=$P(MSH(2),FS,4)
+        S HLMSTATE("UNSTORED LINES",HLMSTATE("BATCH","CURRENT MESSAGE"))=$P(VALUE,CS)_"^"_$P(VALUE,CS,2)
+        S HLMSTATE("UNSTORED MSH")=1
+        M HLMSTATE("UNSTORED MSH",HLMSTATE("BATCH","CURRENT MESSAGE"))=MSH
+        S HLMSTATE("CURRENT SEGMENT")=0
+        S HLMSTATE("LINE COUNT")=0
+        S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+200
+        I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER"),$$SAVEMSG^HLOF778(.HLMSTATE) ;first stores stuff in 777, then headers in file 778
+        Q
+HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+GETMSG(IEN,MSG) ;
+ ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below.
+ ;Input:
+ ;  IEN - the ien of the message in file 778
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure
+ ;  MSG (pass by reference, required) These are the subscripts returned:
+ ;
+ ;   "ACK BY" - msg id of msg that acknowledges this one
+ ;   "ACK BY IEN" - msg IEN of msg that acknowledges this one.  If the message is in the batch, the value is <ien>^<subien>
+ ;   "ACK TO" - msg id of msg that this msg acknowledges
+ ;   "ACK TO IEN" - msg IEN of msg that this msg acknowledges. If the message is in a batch, the value is <ien>^<subien>
+ ;  "BATCH"  = 1 if this is a batch message, 0  if not
+ ;     "CURRENT MESSAGE" - defined only for batch messages -  a counter used during building and parsing messages to indicate the current message.  It will be set to 0 initially.
+ ;  "BODY" - ptr to file 778 which contains the body of the message.
+ ;  "DIRECTION" - "IN" if incoming, "OUT" if outgoing
+ ;  "DT/TM" - date/time the message was sent or received
+ ;  "DT/TM CREATED" - date/time the record was created (.01 field, file #777)
+ ;  "LINE COUNT" -  a counter used during building and parsing of
+ ;     messages to indicate the current line within the message. For
+ ;     batch messages where each message within the batch is stored
+ ;     separately, this field indicates the position within the current
+ ;     individual message
+ ;  "HDR" - the header segment, NOT parsed, as HDR(1) and HDR(2)
+ ;  "ID" - Message Control ID for an individual message, Batch Control ID for a batch message
+ ;  "IEN" - ien, file 778
+ ;  "EVENT" - HL7 event, only defined if NOT batch
+ ;  "MESSAGE TYPE" - HL7 message type, only defined if NOT batch
+ ;  "STATUS" - the completion status
+ ;
+ ;     These are lower level subscripts of "STATUS":
+ ;     "ACCEPT ACK RESPONSE" - the application's <tag>^<rtn> to Xecute when the accept ack is received
+ ;     "ACCEPT ACK'D" - 1 if an accept ack was sent or received in response to this message
+ ;     "APP ACK RESPONSE" - the application's <tag>^<rtn> to Xecute when app ack is received
+ ;     "APP ACK'D" - 1 if an application ack was sent or received in response to this message
+ ;     "ERROR TEXT" - if in error status, a description of the error
+ ;     "LINK NAME" the link the message was transmitted through
+ ;     "PORT" - remote port over which the message was transmitted
+ ;     "PURGE" - scheduled purge dt/tm
+ ;     "QUEUE" - the queue that the message was placed on
+ ;
+ K MSG
+ Q:'$G(IEN) 0
+ N NODE
+ S MSG("IEN")=IEN
+ S NODE=$G(^HLB(IEN,0))
+ S MSG("ID")=$P(NODE,"^")
+ S MSG("BODY")=$P(NODE,"^",2)
+ S MSG("DIRECTION")=$S($E($P(NODE,"^",4))="O":"OUT",$E($P(NODE,"^",4))="I":"IN",1:"")
+ S MSG("ACK TO")=$P(NODE,"^",3)
+ S MSG("ACK BY")=$P(NODE,"^",7)
+ I MSG("ACK TO")]"" S MSG("ACK TO IEN")=$$ACKTOIEN^HLOMSG1($P(NODE,"^"),MSG("ACK TO"))
+ I MSG("ACK BY")]"" S MSG("ACK BY IEN")=$$ACKBYIEN^HLOMSG1($P(NODE,"^"),MSG("ACK BY"))
+ S MSG("DT/TM")=$P(NODE,"^",16)
+ S MSG("STATUS")=$P(NODE,"^",20)
+ ;
+ D
+ .N NODE4
+ .S NODE4=$G(^HLB(IEN,4))
+ .S MSG("STATUS","QUEUE")=$P(NODE,"^",6)
+ .S MSG("STATUS","LINK NAME")=$P(NODE,"^",5)
+ .S MSG("STATUS","PORT")=$P(NODE,"^",8)
+ .S MSG("STATUS","PURGE")=$P(NODE,"^",9)
+ .S MSG("STATUS","ERROR TEXT")=$P(NODE,"^",21)
+ .S MSG("STATUS","APP ACK RESPONSE")=$P(NODE,"^",10,11)
+ .I MSG("STATUS","APP ACK RESPONSE")="^" S MSG("STATUS","APP ACK RESPONSE")=""
+ .S MSG("STATUS","ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13)
+ .I MSG("STATUS","ACCEPT ACK RESPONSE")="^" S MSG("STATUS","ACCEPT ACK RESPONSE")=""
+ .S MSG("STATUS","ACCEPT ACK'D")=$P(NODE,"^",17)
+ .S MSG("STATUS","APP ACK'D")=$P(NODE,"^",18)
+ .S MSG("STATUS")=$P(NODE,"^",20)
+ .S MSG("STATUS","APP HANDOFF")=$P(NODE,"^",19)
+ .S MSG("STATUS","ACCEPT ACK DT/TM")=$P(NODE4,"^")
+ .S MSG("STATUS","ACCEPT ACK ID")=$P(NODE4,"^",2)
+ .S MSG("STATUS","ACCEPT ACK MSA")=$P(NODE4,"^",3,99)
+ ;
+ S MSG("LINE COUNT")=0
+ S MSG("HDR",1)=$G(^HLB(IEN,1))
+ S MSG("HDR",2)=$G(^HLB(IEN,2))
+ I 'MSG("BODY") D  Q 0
+ .S MSG("DT/TM CREATED")=""
+ .S MSG("BATCH")=""
+ .S MSG("MESSAGE TYPE")=""
+ .S MSG("EVENT")=""
+ ;
+ S NODE=$G(^HLA(MSG("BODY"),0))
+ S MSG("DT/TM CREATED")=+NODE
+ S MSG("BATCH")=+$P(NODE,"^",2)
+ I MSG("BATCH") S MSG("BATCH","CURRENT MESSAGE")=0
+ I 'MSG("BATCH") D
+ .S MSG("MESSAGE TYPE")=$P(NODE,"^",3)
+ .S MSG("EVENT")=$P(NODE,"^",4)
+ Q 1
+ ;
+HLNEXT(MSG,SEG) ;
+ ;Description:  Returns the next segment as a set of lines stored in SEG.
+ ;Input:
+ ;  MSG (pass by reference, required)
+ ;Output:
+ ;  Function returns 1 on success, 0 on failure (no more segments)
+ ;  SEG (pass by reference, required)
+ ;
+ K SEG
+ Q:MSG("LINE COUNT")=-1 0
+ I 'MSG("BATCH") D
+ .N I,J,NODE,START
+ .S START=0
+ .S J=1,I=MSG("LINE COUNT")
+ .F  S I=$O(^HLA(MSG("BODY"),1,I)) Q:'I  S NODE=$G(^HLA(MSG("BODY"),1,I,0)) Q:(START&(NODE=""))  I NODE'="" S SEG(J)=NODE,J=J+1,START=1
+ .I 'I D
+ ..S MSG("LINE COUNT")=-1
+ .E  S MSG("LINE COUNT")=I
+ I MSG("BATCH") D
+ .N I,J,NODE,START
+ .S J=1,I=MSG("LINE COUNT"),START=0
+ .F  S I=$O(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I)) Q:'I  S NODE=$G(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I,0)) Q:(START&(NODE=""))  I NODE'="" S SEG(J)=NODE,J=J+1,START=1
+ .I 'I D
+ ..S MSG("LINE COUNT")=-1
+ .E  S MSG("LINE COUNT")=I
+ Q $S($D(SEG):1,1:0)
+ ;
+NEXTMSG(MSG,HDR) ;
+ ;Advances to the next message in the batch
+ ;Input:
+ ;  MSG (pass by reference, required) - defined by $$GETMSG()
+ ;Output:
+ ;  Function returns 1 on success, 0 if no more messages
+ ;  MSG - updated with current position in the message
+ ;  HDR (pass by reference, required) returns the header as an array of lines
+ ;
+ ;
+ K HDR
+ S MSG("LINE COUNT")=0
+ N SUBIEN,I
+ ;
+ ;if completed parsing, don't start over
+ I MSG("BATCH","CURRENT MESSAGE")=-1 Q 0
+ ;
+ S I=$O(^HLB(MSG("IEN"),3,"B",MSG("BATCH","CURRENT MESSAGE")))
+ I 'I S MSG("BATCH","CURRENT MESSAGE")=-1 Q 0
+ S MSG("BATCH","CURRENT MESSAGE")=I
+ S SUBIEN=$O(^HLB(MSG("IEN"),3,"B",I,0))
+ S HDR(1)=$G(^HLB(MSG("IEN"),3,SUBIEN,1))
+ S HDR(2)=$G(^HLB(MSG("IEN"),3,SUBIEN,2))
+ Q $S($D(HDR):1,1:0)
+ ;
+ADDSEG(HLMSTATE,SEG) ;Adds a segment to the message.
+ ;Input:
+ ;  HLMSTATE() - (pass by reference, required)
+ ;  SEG() - (pass by reference, required) The segment as lines SEG(<i>)
+ ;
+ ;Output:
+ ;   HLMSTATE()
+ ;
+ N I,J S I=0
+ S J=HLMSTATE("LINE COUNT")
+ ;
+ ;insure a blank line between segments
+ I J S J=J+1,HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=""
+ ;
+ S HLMSTATE("CURRENT SEGMENT")=HLMSTATE("CURRENT SEGMENT")+1
+ F  S I=$O(SEG(I)) Q:'I  D
+ .S J=J+1
+ .S HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=SEG(I),HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+$L(SEG(I))+50
+ .I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER") D
+ ..I HLMSTATE("DIRECTION")="IN",$$SAVEMSG^HLOF778(.HLMSTATE) Q
+ ..I HLMSTATE("DIRECTION")="OUT",$$SAVEMSG^HLOF777(.HLMSTATE)
+ ;
+ S HLMSTATE("LINE COUNT")=J
+ Q
+ ;
+ADDMSG(HLMSTATE,PARMS) ;
+ ;For outgoing messages, adds a message in the batch. There is no MSH yet, just the message type and event.
+ ;Input:
+ ;  HLMSTATE() - (pass by reference, required)
+ ;  PARMS("EVENT")
+ ;  PARMS("MESSAGE TYPE")
+ ;
+ ;Output:
+ ;   HLMSTATE() - (pass by reference, required)
+ ;
+ N I
+ S I=HLMSTATE("BATCH","CURRENT MESSAGE")+1,HLMSTATE("BATCH","CURRENT MESSAGE")=I
+ S HLMSTATE("UNSTORED LINES",I)=PARMS("MESSAGE TYPE")_"^"_PARMS("EVENT")
+ M:$G(PARMS("ACK TO"))]"" HLMSTATE("BATCH","ACK TO",I)=PARMS("ACK TO")
+ S HLMSTATE("CURRENT SEGMENT")=0
+ S HLMSTATE("LINE COUNT")=0
+ S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+100
+ Q
+ ;
+ADDMSG2(HLMSTATE,MSH) ;
+ ;For incoming messages adds a message to the batch. This differs from ADDMSG in that the MSH segment is passed in to be stored in file 778.
+ ;Input:
+ ;  HLMSTATE() - (pass by reference, required)
+ ;  MSH(<i>) - the MSH segment as a set of lines
+ ;
+ ;Output:
+ ;   HLMSTATE() - (pass by reference, required)
+ ;
+ N FS,CS,VALUE
+ S HLMSTATE("BATCH","CURRENT MESSAGE")=HLMSTATE("BATCH","CURRENT MESSAGE")+1
+ S FS=$E(MSH(1),4)
+ S CS=$E(MSH(1),5)
+ S VALUE=$P(MSH(2),FS,4)
+ S HLMSTATE("UNSTORED LINES",HLMSTATE("BATCH","CURRENT MESSAGE"))=$P(VALUE,CS)_"^"_$P(VALUE,CS,2)
+ S HLMSTATE("UNSTORED MSH")=1
+ M HLMSTATE("UNSTORED MSH",HLMSTATE("BATCH","CURRENT MESSAGE"))=MSH
+ S HLMSTATE("CURRENT SEGMENT")=0
+ S HLMSTATE("LINE COUNT")=0
+ S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+200
+ I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER"),$$SAVEMSG^HLOF778(.HLMSTATE) ;first stores stuff in 777, then headers in file 778
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m

-              r613
+              r623
+HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;07/20/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        N SYSTEM,DATA,VASITE,OLDSITE
+        D IDXLINKS
+        D SYSPARMS^HLOSITE(.SYSTEM)
+        S VASITE=$$SITE^VASITE
+        S OLDSITE=$G(^HLCS(869.3,1,0))
+        S DATA(.01)=SYSTEM("DOMAIN")
+        I DATA(.01)="" D
+        .I $P(OLDSITE,"^",2) S DATA(.01)="HL7."_$P($G(^DIC(4.2,$P(OLDSITE,"^",2),0)),"^")
+        I DATA(.01)="" D
+        .N INST,DOMAIN
+        .S INST=$P(VASITE,"^")
+        .Q:'INST
+        .S DOMAIN=$P($G(^DIC(4,INST,6)),"^")
+        .I DOMAIN S DOMAIN=$P($G(^DIC(4.2,DOMAIN,0)),"^") I DOMAIN'="" S DATA(.01)="HL7."_DOMAIN
+        I DATA(.01)="" D BMES^XPDUTL("Post-Install failed, system missing INSTITUTION or DOMAIN file entry") Q
+        S DATA(.02)=SYSTEM("STATION")
+        I DATA(.02)="",$P(OLDSITE,"^",4) S DATA(.02)=$P($G(^DIC(4,$P(OLDSITE,"^",4),99)),"^")
+        I DATA(.02)="" S DATA(.02)=$P(VASITE,"^",3)
+        S DATA(.03)=$P(OLDSITE,"^",3)
+        S DATA(.04)=SYSTEM("MAXSTRING")
+        S DATA(.05)=SYSTEM("HL7 BUFFER")
+        S DATA(.06)=SYSTEM("USER BUFFER")
+        S DATA(.07)=SYSTEM("NORMAL PURGE")
+        S DATA(.08)=SYSTEM("ERROR PURGE")
+        I $D(^HLD(779.1,1,0)) D
+        .N ERROR
+        .I '$$UPD^HLOASUB1(779.1,1,.DATA,.ERROR) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR))
+        E  D
+        .N ERROR
+        .I '$$ADD^HLOASUB1(779.1,,.DATA,.ERROR,1) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR))
+        Q
+IDXLINKS        ;
+        ;set the "AC" and "AD" indicies on the HL Logical Link file
+        N DIK
+        S DIK="^HLCS(870,"
+        S DIK(1)=".01^AC^AD^AD1^AD2"
+        D ENALL^DIK
+        Q
+        ;
+P134    ;
+        N DAILY,STARTUP,IEN,DATA
+        S DAILY=$O(^DIC(19,"B","HLO DAILY STARTUP",0))
+        I 'DAILY D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+        S STARTUP=$O(^DIC(19,"B","HLO SYSTEM STARTUP",0))
+        I 'STARTUP D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+        I STARTUP D
+        .S IEN=$O(^DIC(19.2,"B",STARTUP,0))
+        .S DATA(.01)=STARTUP
+        .S DATA(2)=""
+        .S DATA(6)=""
+        .S DATA(9)=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":"S",1:"")
+        .I IEN D
+        ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+        .E  D
+        ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+        I DAILY D
+        .S IEN=$O(^DIC(19.2,"B",DAILY,0))
+        .S DATA(.01)=DAILY
+        .S DATA(2)=$$NOW^XLFDT
+        .S DATA(6)="1D"
+        .S DATA(9)=""
+        .I IEN D
+        ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+        .E  D
+        ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+        Q
+        ;
+P136    ;post-install routine for HL*1.6*136
+        N ERROR,DIFROM,IEN
+        I $P($G(^HLD(779.1,1,0)),"^",3)="P" D
+        .D RESCH^XUTMOPT("HLO DAILY STARTUP",$$FMADD^XLFDT($$NOW^XLFDT,,1),,"1D","L",.ERROR)
+        .I $G(ERROR)<0 D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option! Please do so manually")
+        ;
+        S IEN=$O(^HLD(779.3,"B","PURGE OLD MESSAGES",0))
+        Q:'IEN
+        S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0"
+        Q
+        ;
+P137    ;
+        ;move the existing errros to the new structure
+        N TYPE
+        K ^TMP($J,"HLO ERRORS")
+        F TYPE="TF","SE","AE" D
+        .M ^TMP($J,"HLO ERRORS",TYPE)=^HLB("ERRORS",TYPE)
+        .M ^HLB("ERRORS")=^TMP($J,"HLO ERRORS",TYPE)
+        .K ^TMP($J,"HLO ERRORS",TYPE)
+        .K ^HLB("ERRORS",TYPE)
+        Q
+HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;05/03/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
+ ;
+ N SYSTEM,DATA,VASITE,OLDSITE
+ D IDXLINKS
+ D SYSPARMS^HLOSITE(.SYSTEM)
+ S VASITE=$$SITE^VASITE
+ S OLDSITE=$G(^HLCS(869.3,1,0))
+ S DATA(.01)=SYSTEM("DOMAIN")
+ I DATA(.01)="" D
+ .I $P(OLDSITE,"^",2) S DATA(.01)="HL7."_$P($G(^DIC(4.2,$P(OLDSITE,"^",2),0)),"^")
+ I DATA(.01)="" D
+ .N INST,DOMAIN
+ .S INST=$P(VASITE,"^")
+ .Q:'INST
+ .S DOMAIN=$P($G(^DIC(4,INST,6)),"^")
+ .I DOMAIN S DOMAIN=$P($G(^DIC(4.2,DOMAIN,0)),"^") I DOMAIN'="" S DATA(.01)="HL7."_DOMAIN
+ I DATA(.01)="" D BMES^XPDUTL("Post-Install failed, system missing INSTITUTION or DOMAIN file entry") Q
+ S DATA(.02)=SYSTEM("STATION")
+ I DATA(.02)="",$P(OLDSITE,"^",4) S DATA(.02)=$P($G(^DIC(4,$P(OLDSITE,"^",4),99)),"^")
+ I DATA(.02)="" S DATA(.02)=$P(VASITE,"^",3)
+ S DATA(.03)=$P(OLDSITE,"^",3)
+ S DATA(.04)=SYSTEM("MAXSTRING")
+ S DATA(.05)=SYSTEM("HL7 BUFFER")
+ S DATA(.06)=SYSTEM("USER BUFFER")
+ S DATA(.07)=SYSTEM("NORMAL PURGE")
+ S DATA(.08)=SYSTEM("ERROR PURGE")
+ I $D(^HLD(779.1,1,0)) D
+ .N ERROR
+ .I '$$UPD^HLOASUB1(779.1,1,.DATA,.ERROR) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR))
+ E  D
+ .N ERROR
+ .I '$$ADD^HLOASUB1(779.1,,.DATA,.ERROR,1) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR))
+ Q
+IDXLINKS ;
+ ;set the "AC" and "AD" indicies on the HL Logical Link file
+ N DIK
+ S DIK="^HLCS(870,"
+ S DIK(1)=".01^AC^AD^AD1^AD2"
+ D ENALL^DIK
+ Q
+ ;
+P134 ;
+ N DAILY,STARTUP,IEN,DATA
+ S DAILY=$O(^DIC(19,"B","HLO DAILY STARTUP",0))
+ I 'DAILY D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+ S STARTUP=$O(^DIC(19,"B","HLO SYSTEM STARTUP",0))
+ I 'STARTUP D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+ I STARTUP D
+ .S IEN=$O(^DIC(19.2,"B",STARTUP,0))
+ .S DATA(.01)=STARTUP
+ .S DATA(2)=""
+ .S DATA(6)=""
+ .S DATA(9)=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":"S",1:"")
+ .I IEN D
+ ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+ .E  D
+ ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!")
+ I DAILY D
+ .S IEN=$O(^DIC(19.2,"B",DAILY,0))
+ .S DATA(.01)=DAILY
+ .S DATA(2)=$$NOW^XLFDT
+ .S DATA(6)="1D"
+ .S DATA(9)=""
+ .I IEN D
+ ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+ .E  D
+ ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!")
+ Q
+ ;
+P136 ;post-install routine for HL*1.6*136
+ N ERROR,DIFROM,IEN
+ I $P($G(^HLD(779.1,1,0)),"^",3)="P" D
+ .D RESCH^XUTMOPT("HLO DAILY STARTUP",$$FMADD^XLFDT($$NOW^XLFDT,,1),,"1D","L",.ERROR)
+ .I $G(ERROR)<0 D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option! Please do so manually")
+ ;
+ S IEN=$O(^HLD(779.3,"B","PURGE OLD MESSAGES",0))
+ Q:'IEN
+ S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0"
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m

-              r613
+              r623
+HLOPURGE        ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;07/25/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+GETWORK(WORK)   ;
+        ;
+        N OK
+        S OK=0
+        I $G(WORK)]"" L -HLPURGE(WORK)
+        F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) S WORK("DONE",WORK)=1 L +HLPURGE(WORK):0 S OK=$T Q:OK
+        I 'OK K WORK("DONE") S WORK=""
+        Q OK
+        ;
+DOWORK(WORK)    ;
+        I WORK="OLD778" D OLD778
+        I WORK="OLD777" D OLD777
+        I (WORK="IN")!(WORK="OUT") D
+        .N TIME,NOW
+        .S NOW=$$NOW^XLFDT
+        .S TIME=0
+        .F  S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME=""  Q:TIME>NOW  D
+        ..N MSGIEN
+        ..S MSGIEN=0
+        ..F  S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN  D
+        ...K ^HLB("AD",WORK,TIME,MSGIEN)
+        ...D DELETE(MSGIEN)
+        L -HLPURGE(WORK)
+        Q
+OLD778  ;
+        N OLD,START,END,APP,TYPE,TODAY,PARMS
+        S TODAY=$$DT^XLFDT
+        S OLD=$$FMADD^XLFDT(TODAY,-45)
+        F START=0,100000000000,200000000000,300000000000 D
+        .S END=(START+100000000000)-1
+        .N MSGIEN,QUIT
+        .S QUIT=0
+        .S MSGIEN=START
+        .F  S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN  Q:(MSGIEN>END)  D  Q:QUIT
+        ..N WHEN,BODY,NODE
+        ..S NODE=$G(^HLB(MSGIEN,0))
+        ..S WHEN=$P(NODE,"^",16)
+        ..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q
+        ..I 'WHEN D
+        ...S BODY=$P(NODE,"^",2)
+        ...Q:'BODY
+        ...S WHEN=+$G(^HLA(BODY,0))
+        ...I WHEN,WHEN<OLD D  Q
+        ....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
+        ....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D
+        .....N FROM
+        .....S FROM=$P(NODE,"^",5)
+        .....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8)
+        .....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN))
+        .....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN)
+        ....D DELETE(MSGIEN) Q
+        ...;stop looking for old records?
+        ...I WHEN,WHEN>OLD S QUIT=1
+        ;
+        ;also kill old errors left lying around
+        D SYSPARMS^HLOSITE(.PARMS)
+        S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
+        S APP=""
+        F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D
+        .N TIME
+        .S TIME=0
+        .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",APP,TIME)
+        Q
+OLD777  ;
+        N OLD,TIME,TODAY
+        S TODAY=$$DT^XLFDT
+        S OLD=$$FMADD^XLFDT(TODAY,-45)
+        S TIME=0
+        F  S TIME=$O(^HLA("B",TIME)) Q:'TIME  Q:TIME>OLD  D
+        .N MSGIEN
+        .S MSGIEN=0
+        .F  S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN  D
+        ..N IEN778,STOP
+        ..S (STOP,IEN778)=0
+        ..F  S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778  D
+        ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q
+        ...D DELETE(IEN778,1)
+        ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
+        Q
+        ;
+DELETE(MSGIEN,FLAG)     ;
+        ;Input:
+        ;  MSGIEN - IEN, file 778
+        ;  FLAG - if $G(FLAG), will not delete the pointed to record in file 777
+        N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG
+        I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete
+        S (RAPP,SAPP)=""
+        D
+        .S FS=$E(MSG("HDR",1),4)
+        .Q:FS=""
+        .S CS=$E(MSG("HDR",1),5)
+        .S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
+        .I SAPP="" S SAPP="UNKNOWN"
+        .S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
+        .I RAPP="" S RAPP="UNKNOWN"
+        ;
+        I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
+        ;if an error status,take care of the "ERRORS" x-ref
+        I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
+        .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
+        .I MSG("STATUS")="ER" D
+        ..N SUB
+        ..S SUB=MSGIEN_"^"
+        ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
+        ..F  S SUB=$O(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
+        ;
+        ;kill the whole-file xrefs for the message ien within a batch
+        S SUBIEN=0
+        F  S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN  D
+        .N MSGID
+        .I FS]"" D
+        ..N VALUE,HDR2,MSGTYPE,EVENT
+        ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2))
+        ..S VALUE=$P(HDR2,FS,4)
+        ..S MSGTYPE=$P(VALUE,CS)
+        ..S EVENT=$P(VALUE,CS,2)
+        ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
+        .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
+        .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
+        ;
+        I MSG("DIRECTION")="IN" D
+        .Q:FS=""
+        .N VALUE,HDR
+        .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3)
+        .S VALUE=$P(MSG("HDR",1),FS,4)
+        .S HDR("SENDING FACILITY",1)=$P(VALUE,CS)
+        .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2)
+        .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3)
+        .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
+        K ^HLB(MSGIEN)
+        I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
+        K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN)
+        I MSG("DIRECTION")="IN" D
+        .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN)
+        .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY"))
+        I MSG("DIRECTION")="OUT" D
+        .K ^HLB("C",+MSG("BODY"),MSGIEN)
+        .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY"))
+        Q
+        ;
+KILL777(BODY)   ;
+        Q:'$G(BODY)
+        N TIME
+        S TIME=$P($G(^HLA(BODY,0)),"^")
+        K ^HLA(BODY)
+        K:(TIME]"") ^HLA("B",TIME,BODY)
+        Q
+        ;
+KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN)        ;
+        ;Kills the ^HLB("SEARCH") x-ref
+        ;
+        N APP
+        S:MSGTYPE="" MSGTYPE="<none>"
+        S:EVENT="" EVENT="<none>"
+        Q:'MSG("DT/TM CREATED")
+        I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
+        S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP)
+        Q:APP=""
+        K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
+        Q
+HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;04/30/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+GETWORK(WORK) ;
+ ;
+ N OK
+ S OK=0
+ I $G(WORK)]"" L -HLPURGE(WORK)
+ F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) S WORK("DONE",WORK)=1 L +HLPURGE(WORK):0 S OK=$T Q:OK
+ I 'OK K WORK("DONE") S WORK=""
+ Q OK
+ ;
+DOWORK(WORK) ;
+ I WORK="OLD778" D OLD778
+ I WORK="OLD777" D OLD777
+ I (WORK="IN")!(WORK="OUT") D
+ .N TIME,NOW
+ .S NOW=$$NOW^XLFDT
+ .S TIME=0
+ .F  S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME=""  Q:TIME>NOW  D
+ ..N MSGIEN
+ ..S MSGIEN=0
+ ..F  S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN  D
+ ...K ^HLB("AD",WORK,TIME,MSGIEN)
+ ...D DELETE(MSGIEN)
+ L -HLPURGE(WORK)
+ Q
+OLD778 ;
+ N OLD,START,END,APP,TYPE,TODAY
+ S TODAY=$$DT^XLFDT
+ S OLD=$$FMADD^XLFDT(TODAY,-45)
+ F START=0,100000000000,200000000000,300000000000 D
+ .S END=(START+100000000000)-1
+ .N MSGIEN,QUIT
+ .S QUIT=0
+ .S MSGIEN=START
+ .F  S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN  Q:(MSGIEN>END)  D  Q:QUIT
+ ..N WHEN,BODY,NODE
+ ..S NODE=$G(^HLB(MSGIEN,0))
+ ..S WHEN=$P(NODE,"^",16)
+ ..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q
+ ..I 'WHEN D
+ ...S BODY=$P(NODE,"^",2)
+ ...Q:'BODY
+ ...S WHEN=+$G(^HLA(BODY,0))
+ ...I WHEN,WHEN<OLD D  Q
+ ....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
+ ....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D
+ .....N FROM
+ .....S FROM=$P(NODE,"^",5)
+ .....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8)
+ .....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN))
+ .....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN)
+ ....D DELETE(MSGIEN) Q
+ ...;stop looking for old records?
+ ...I WHEN,WHEN>OLD S QUIT=1
+ ;
+ ;also kill old errors left lying around
+ F TYPE="TF","AE","SE" S APP="" F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D
+ .N TIME,PARMS
+ .D SYSPARMS^HLOSITE(.PARMS)
+ .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
+ .S TIME=0
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",TYPE,APP,TIME)
+ Q
+OLD777 ;
+ N OLD,TIME,TODAY
+ S TODAY=$$DT^XLFDT
+ S OLD=$$FMADD^XLFDT(TODAY,-45)
+ S TIME=0
+ F  S TIME=$O(^HLA("B",TIME)) Q:'TIME  Q:TIME>OLD  D
+ .N MSGIEN
+ .S MSGIEN=0
+ .F  S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN  D
+ ..N IEN778,STOP
+ ..S (STOP,IEN778)=0
+ ..F  S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778  D
+ ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q
+ ...D DELETE(IEN778,1)
+ ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
+ Q
+ ;
+DELETE(MSGIEN,FLAG) ;
+ ;Input:
+ ;  MSGIEN - IEN, file 778
+ ;  FLAG - if $G(FLAG), will not delete the pointed to record in file 777
+ N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG
+ I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete
+ S (RAPP,SAPP)=""
+ D
+ .S FS=$E(MSG("HDR",1),4)
+ .Q:FS=""
+ .S CS=$E(MSG("HDR",1),5)
+ .S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
+ .I SAPP="" S SAPP="UNKNOWN"
+ .S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
+ .I RAPP="" S RAPP="UNKNOWN"
+ ;
+ I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
+ ;if an error status,take care of the "ERRORS" x-ref
+ I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
+ .N APP
+ .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP)
+ .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN)
+ .I MSG("STATUS")="AE" D
+ ..N SUB
+ ..S SUB=MSGIEN_"^"
+ ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
+ ..F  S SUB=$O(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
+ ;
+ ;kill the whole-file xrefs for the message ien within a batch
+ S SUBIEN=0
+ F  S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN  D
+ .N MSGID
+ .I FS]"" D
+ ..N VALUE,HDR2,MSGTYPE,EVENT
+ ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2))
+ ..S VALUE=$P(HDR2,FS,4)
+ ..S MSGTYPE=$P(VALUE,CS)
+ ..S EVENT=$P(VALUE,CS,2)
+ ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
+ .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
+ .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
+ ;
+ I MSG("DIRECTION")="IN" D
+ .Q:FS=""
+ .N VALUE,HDR
+ .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3)
+ .S VALUE=$P(MSG("HDR",1),FS,4)
+ .S HDR("SENDING FACILITY",1)=$P(VALUE,CS)
+ .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2)
+ .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3)
+ .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
+ K ^HLB(MSGIEN)
+ I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
+ K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN)
+ I MSG("DIRECTION")="IN" D
+ .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN)
+ .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY"))
+ I MSG("DIRECTION")="OUT" D
+ .K ^HLB("C",+MSG("BODY"),MSGIEN)
+ .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY"))
+ Q
+ ;
+KILL777(BODY) ;
+ Q:'$G(BODY)
+ N TIME
+ S TIME=$P($G(^HLA(BODY,0)),"^")
+ K ^HLA(BODY)
+ K:(TIME]"") ^HLA("B",TIME,BODY)
+ Q
+ ;
+KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ;
+ ;Kills the ^HLB("SEARCH") x-ref
+ ;
+ N APP
+ S:MSGTYPE="" MSGTYPE="<none>"
+ S:EVENT="" EVENT="<none>"
+ Q:'MSG("DT/TM CREATED")
+ I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
+ S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP)
+ Q:APP=""
+ K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m

-              r613
+              r623
+HLOQUE  ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;07/31/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+INQUE(FROM,QNAME,IEN778,ACTION,PURGE)   ;
+        ;Will place the message=IEN778 on the IN queue, incoming
+        ;Input:
+        ;  FROM - sending facility from message header.
+        ;         For actions other than incoming messages, its the specified link.
+        ;  QNAME - queue named by the application
+        ;  IEN778 = ien of the message in file 778
+        ;  ACTION - <tag^routine> that should be executed for the application
+        ;  PURGE (optional) - PURGE=1 indicates that the purge dt/tm needs to be set by the infiler
+        ;     If PURGE("ACKTOIEN") is set, it indicates that the purge dt/tm of
+        ;     the original message to this application ack also needs to be set.
+        ;Output: none
+        ;
+        I $G(FROM)="" S FROM="UNKNOWN"
+        I '$L($G(QNAME)) S QNAME="DEFAULT"
+        S ^HLB("QUEUE","IN",FROM,QNAME,IEN778)=ACTION_"^"_$G(PURGE)_"^"_$G(PURGE("ACKTOIEN"))
+        I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","IN",FROM,QNAME)))
+        Q
+        ;
+OUTQUE(LINKNAME,PORT,QNAME,IEN778)      ;
+        ;Will place the message=IEN778 on the out-going queue
+        ;Input:
+        ;  LINKNAME = name of (.01) the logical link
+        ;  PORT (optional) the port to connect to
+        ;  QNAME - queue named by the application
+        ;  IEN778 = ien of the message in file 778
+        ;Output: none
+        ;
+        N SUB
+        S SUB=LINKNAME
+        I PORT S SUB=SUB_":"_PORT
+        I '$L($G(QNAME)) S QNAME="DEFAULT"
+        S ^HLB("QUEUE","OUT",SUB,QNAME,IEN778)=""
+        I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","OUT",SUB,QNAME)))
+        Q
+        ;
+DEQUE(FROMORTO,QNAME,DIR,IEN778)        ;
+        ;This routine will remove the message=IEN778 from its queue
+        ;Input:
+        ;  DIR = "IN" or "OUT", denoting the direction that the message is going in
+        ;  FROMORTO = for outgoing: the .01 field of the logical link
+        ;         for incoming: sending facility
+        ;  IEN778 = ien of the message in file 778
+        ;Output: none
+        ;
+        Q:(FROMORTO="")
+        I ($G(QNAME)="") S QNAME="DEFAULT"
+        D
+        .I $E(DIR)="I" S DIR="IN" Q
+        .I $E(DIR)="O" S DIR="OUT" Q
+        I DIR'="IN",DIR'="OUT" Q
+        Q:'$G(IEN778)
+        D:$D(^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778))
+        .K ^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778)
+        .;don't let the count become negative
+        .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)))
+        Q
+        ;
+STOPQUE(DIR,QUEUE)      ;
+        ;This API is used to set a stop flag on a named queue.
+        ;DIR=<"IN" or "OUT">
+        ;QUEUE - the name of the queue to be stopped
+        ;
+        Q:$G(DIR)=""
+        Q:$G(QUEUE)=""
+        S ^HLTMP("STOPPED QUEUES",DIR,QUEUE)=1
+        Q
+STARTQUE(DIR,QUEUE)     ;
+        ;This API is used to REMOVE the stop flag on a named queue.
+        ;DIR=<"IN" or "OUT">
+        ;QUEUE - the name of the queue to be stopped
+        ;
+        Q:$G(DIR)=""
+        Q:$G(QUEUE)=""
+        K ^HLTMP("STOPPED QUEUES",DIR,QUEUE)
+        Q
+STOPPED(DIR,QUEUE)      ;
+        ;This API is used to DETERMINE if the stop flag on a named queue is set.
+        ;Input:
+        ;  DIR=<"IN" or "OUT">
+        ;  QUEUE - the name of the queue to be checked
+        ;Output:
+        ;  Function returns 1 if the queue is stopped, 0 otherwise
+        Q:$G(DIR)="" 0
+        Q:$G(QUEUE)="" 0
+        I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1
+        Q 0
+        ;
+SQUE(SQUE,LINKNAME,PORT,QNAME,IEN778)   ;
+        ;Will place the message=IEN778 on the sequencing queue. This is always done in the context of the application calling an HLO API to send a message.
+        ;Input:
+        ;  SQUE - name of the sequencing queue
+        ;  LINKNAME = name of (.01) the logical link
+        ;  PORT (optional) the port to connect to
+        ;  QNAME (optional) outgoing queue
+        ;  IEN778 = ien of the message in file 778
+        ;Output: 1 if placed on the outgoing queue, 0 if placed on the sequence queue
+        ;
+        N NEXT,MOVED
+        S MOVED=0
+        ;
+        ;keep a count of messages pending on sequence queues for the HLO System Monitor
+        I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")))
+        ;
+        L +^HLB("QUEUE","SEQUENCE",SQUE):200
+        ;
+        S NEXT=+$G(^HLB("QUEUE","SEQUENCE",SQUE))
+        Q:NEXT=IEN778 0  ;already queued!
+        ;if the sequence queue is empty and not waiting on a message, then the message can be put directly on the outgoing queue, bypassing the sequence queue
+        I '$O(^HLB("QUEUE","SEQUENCE",SQUE,0)),'NEXT D
+        .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;to mean something moved to outgoing but not yet transmitted
+        .L -^HLB("QUEUE","SEQUENCE",SQUE)
+        .D OUTQUE(.LINKNAME,.PORT,.QNAME,IEN778)
+        .S MOVED=1
+        E  D
+        .;Put the message on the sequence queue.
+        .S ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)=""
+        .L -^HLB("QUEUE","SEQUENCE",SQUE)
+        Q MOVED
+        ;
+ADVANCE(SQUE,MSGIEN)    ;
+        ;Will move the specified sequencing queue to the next message.
+        ;Input:
+        ;  SQUE - name of the sequencing queue
+        ;  MSGIEN - the ien of the message upon which the sequence queue was waiting.  If it is NOT the correct ien, then the sequence queue will NOT be advance.
+        ;Output:
+        ;  Function - 1 if advanced, 0 if not
+        ;
+        N NODE,IEN778,LINKNAME,PORT,QNAME
+        Q:'$L($G(SQUE)) 0
+        Q:'$G(MSGIEN) 0
+        L +^HLB("QUEUE","SEQUENCE",SQUE):200
+        ;
+        ;do not advance if the queue wasn't pending the message=MSGIEN
+        I (MSGIEN'=$P($G(^HLB("QUEUE","SEQUENCE",SQUE)),"^")) L -^HLB("QUEUE","SEQUENCE",SQUE) Q 0
+        ;
+        I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
+        ;
+        S IEN778=0
+        ;look for the first message on the sequence que.  Make sure its valid, if not remove the invalid entry and keep looking.
+        F  S IEN778=$O(^HLB("QUEUE","SEQUENCE",SQUE,0)) Q:'IEN778  S NODE=$G(^HLB(IEN778,0)) Q:$L(NODE)  D
+        .;message does not exist! Remove from queue and try again.
+        .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)
+        .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
+        ;
+        ;IEN778 is the next pending msg on this sequence queue
+        I IEN778 D
+        .;
+        .;parse out info needed to move to outgoing queue
+        .S LINKNAME=$P(NODE,"^",5),PORT=$P(NODE,"^",8),QNAME=$P(NODE,"^",6)
+        .;
+        .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;indicates this sequence queue is now waiting for msg=IEN778 before advancing.  The second pieces is the timer, but will not be set until the message=IEN778 is actually transmitted.
+        .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) ;remove from sequence queue
+        .L -^HLB("QUEUE","SEQUENCE",SQUE)
+        .S $P(^HLB(IEN778,5),"^",2)=1
+        .D OUTQUE(.LINKNAME,$G(PORT),$G(QNAME),IEN778) ;move to outgoing queue
+        E  D
+        .K ^HLB("QUEUE","SEQUENCE",SQUE) ;this sequence queue is currently empty and not needed
+        .L -^HLB("QUEUE","SEQUENCE",SQUE)
+        Q 1
+        ;
+SEQCHK(WORK)    ;functions under the HLO Process Manager
+        ;check sequence queues for timeout
+        N QUE,NOW
+        S NOW=$$NOW^XLFDT
+        S QUE=""
+        F  S QUE=$O(^HLB("QUEUE","SEQUENCE",QUE)) Q:QUE=""  D
+        .N NODE,MSGIEN,ACTION,NODE
+        .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
+        .Q:'$P(NODE,"^",2)
+        .Q:$P(NODE,"^",2)>NOW
+        .Q:$P(NODE,"^",3)
+        .L +^HLB("QUEUE","SEQUENCE",QUE):2
+        .;don't report if a lock wasn't obtained
+        .Q:'$T
+        .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
+        .I '$P(NODE,"^",2) L -^HLB("QUEUE","SEQUENCE",QUE) Q
+        .I ($P(NODE,"^",2)>NOW) L -^HLB("QUEUE","SEQUENCE",QUE) Q
+        .I $P(NODE,"^",3) L -^HLB("QUEUE","SEQUENCE",QUE) Q  ;exception already raised
+        .S MSGIEN=$P(NODE,"^")
+        .I 'MSGIEN L -^HLB("QUEUE","SEQUENCE",QUE) Q
+        .S ACTION=$$EXCEPT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))
+        .S $P(^HLB(MSGIEN,5),"^",3)=1
+        .S $P(^HLB("QUEUE","SEQUENCE",QUE),"^",3)=1 ;indicates exception raised
+        .L -^HLB("QUEUE","SEQUENCE",QUE)
+        .D  ;call the application to take action
+        ..N HLMSGIEN,MCODE,DUZ,QUE,NOW
+        ..N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOQUE"
+        ..S HLMSGIEN=MSGIEN
+        ..S MCODE="D "_ACTION
+        ..N MSGIEN,X
+        ..D DUZ^XUP(.5)
+        ..X MCODE
+        ..;kill the apps variables
+        ..D
+        ...N ZTSK
+        ...D KILL^XUSCLEAN
+        Q
+ERROR   ;error trap for application context
+        S $ETRAP="D UNWIND^%ZTER"
+        D ^%ZTER
+        S $ECODE=",UAPPLICATION ERROR,"
+        ;
+        ;kill the apps variables
+        D
+        .N ZTSK,MSGIEN,QUEUE
+        .D KILL^XUSCLEAN
+        ;
+        ;release all the locks the app may have set, except Taskman lock
+        L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1
+        L:'$D(ZTSK)
+        ;reset HLO's lock
+        L +^HLTMP("HL7 RUNNING PROCESSES",$J):0
+        ;return to processing the next message on the queue
+        D UNWIND^%ZTER
+        Q
+HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;01/05/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+INQUE(FROM,QNAME,IEN778,ACTION,PURGE) ;
+ ;Will place the message=IEN778 on the IN queue, incoming
+ ;Input:
+ ;  FROM - sending facility from message header.
+ ;         For actions other than incoming messages, its the specified link.
+ ;  QNAME - queue named by the application
+ ;  IEN778 = ien of the message in file 778
+ ;  ACTION - <tag^routine> that should be executed for the application
+ ;  PURGE (optional) - PURGE=1 indicates that the purge dt/tm needs to be set by the infiler
+ ;     If PURGE("ACKTOIEN") is set, it indicates that the purge dt/tm of
+ ;     the original message to this application ack also needs to be set.
+ ;Output: none
+ ;
+ I $G(FROM)="" S FROM="UNKNOWN"
+ I '$L($G(QNAME)) S QNAME="DEFAULT"
+ S ^HLB("QUEUE","IN",FROM,QNAME,IEN778)=ACTION_"^"_$G(PURGE)_"^"_$G(PURGE("ACKTOIEN"))
+ I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","IN",FROM,QNAME)))
+ Q
+ ;
+OUTQUE(LINKNAME,PORT,QNAME,IEN778) ;
+ ;Will place the message=IEN778 on the out-going queue
+ ;Input:
+ ;  LINKNAME = name of (.01) the logical link
+ ;  PORT (optional) the port to connect to
+ ;  QNAME - queue named by the application
+ ;  IEN778 = ien of the message in file 778
+ ;Output: none
+ ;
+ N SUB
+ S SUB=LINKNAME
+ I PORT S SUB=SUB_":"_PORT
+ I '$L($G(QNAME)) S QNAME="DEFAULT"
+ S ^HLB("QUEUE","OUT",SUB,QNAME,IEN778)=""
+ I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","OUT",SUB,QNAME)))
+ Q
+ ;
+DEQUE(FROMORTO,QNAME,DIR,IEN778) ;
+ ;This routine will remove the message=IEN778 from its queue
+ ;Input:
+ ;  DIR = "IN" or "OUT", denoting the direction that the message is going in
+ ;  FROMORTO = for outgoing: the .01 field of the logical link
+ ;         for incoming: sending facility
+ ;  IEN778 = ien of the message in file 778
+ ;Output: none
+ ;
+ Q:(FROMORTO="")
+ I ($G(QNAME)="") S QNAME="DEFAULT"
+ D
+ .I $E(DIR)="I" S DIR="IN" Q
+ .I $E(DIR)="O" S DIR="OUT" Q
+ I DIR'="IN",DIR'="OUT" Q
+ Q:'$G(IEN778)
+ D:$D(^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778))
+ .K ^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778)
+ .;don't let the count become negative
+ .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)))
+ Q
+ ;
+STOPQUE(DIR,QUEUE) ;
+ ;This API is used to set a stop flag on a named queue.
+ ;DIR=<"IN" or "OUT">
+ ;QUEUE - the name of the queue to be stopped
+ ;
+ Q:$G(DIR)=""
+ Q:$G(QUEUE)=""
+ S ^HLTMP("STOPPED QUEUES",DIR,QUEUE)=1
+ Q
+STARTQUE(DIR,QUEUE) ;
+ ;This API is used to REMOVE the stop flag on a named queue.
+ ;DIR=<"IN" or "OUT">
+ ;QUEUE - the name of the queue to be stopped
+ ;
+ Q:$G(DIR)=""
+ Q:$G(QUEUE)=""
+ K ^HLTMP("STOPPED QUEUES",DIR,QUEUE)
+ Q
+STOPPED(DIR,QUEUE) ;
+ ;This API is used to DETERMINE if the stop flag on a named queue is set.
+ ;Input:
+ ;  DIR=<"IN" or "OUT">
+ ;  QUEUE - the name of the queue to be checked
+ ;Output:
+ ;  Function returns 1 if the queue is stopped, 0 otherwise
+ Q:$G(DIR)="" 0
+ Q:$G(QUEUE)="" 0
+ I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1
+ Q 0

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m

-              r613
+              r623
+HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;07/19/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+GETWORK(WORK)   ;
+        ;GET WORK function for a single server or a Taskman multi-server
+        N LINK
+        I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1
+        Q 0
+        ;
+DOWORKS(WORK)   ;
+        ;DO WORK rtn for a single server (non-concurrent)
+        D SERVER(WORK("LINK"))
+        Q
+DOWORKM(WORK)   ;
+        ;DO WORK rtn for a Taskman multi-server (Cache systems only)
+        D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
+        Q
+        ;
+VMS2(LINKNAME)  ;called from a VMS TCP Service once a connection request has been received.  This entry point should be used only if an additional VMS TCPIP Services are being created for HLO.
+        ;Input:
+        ;   LINKNAME - only pass it in if an additional service is being created on a different port
+        Q:'$L(LINKNAME)
+        D VMS
+        Q
+        ;
+VMS     ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port.
+        Q:$$CHKSTOP^HLOPROC
+        D
+        .Q:$L($G(LINKNAME))
+        .;
+        .N PROC,NODE
+        .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0))
+        .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME)
+        .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME)
+        .S LINKNAME="HLO DEFAULT LISTENER"
+        ;
+        D SERVER(LINKNAME,"SYS$NET")
+        Q
+        ;
+SERVER(LINKNAME,LOGICAL)        ; LINKNAME identifies the logical link, which describes the communication channel to be used
+        N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1"
+        N HLCSTATE,INQUE
+        S INQUE=0
+        Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
+        K LINKNAME
+        F  Q:'HLCSTATE("CONNECTED")  D  Q:$$CHKSTOP^HLOPROC
+        .N HLMSTATE,SENT
+        .;
+        .;read msg and parse the hdr
+        .;HLMSTATE("MSA",1) is set with type of ack to return
+        .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D
+        ..;
+        ..;send an ack if required and save the MSA segment
+        ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT)
+        ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
+        ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
+        ..I $G(HLMSTATE("ACK TO","IEN")),$L($G(HLMSTATE("ACK TO","SEQUENCE QUEUE"))) D ADVANCE^HLOQUE(HLMSTATE("ACK TO","SEQUENCE QUEUE"),+HLMSTATE("ACK TO","IEN"))
+        .E  D INQUE() H:HLCSTATE("CONNECTED") 1
+        ;
+END     D CLOSE^HLOT(.HLCSTATE)
+        D INQUE()
+        D SAVECNTS^HLOSTAT(.HLCSTATE)
+        Q
+        ;
+CONNECT(HLCSTATE,LINKNAME,LOGICAL)      ;
+        ;sets up HLCSTATE() and opens a server connection
+        ;
+        N LINK,NODE
+        S HLCSTATE("CONNECTED")=0
+        Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0
+        Q:+LINK("SERVER")'=1 0
+        S HLCSTATE("SERVER")=LINK("SERVER")
+        M HLCSTATE("LINK")=LINK
+        S HLCSTATE("READ TIMEOUT")=20
+        S HLCSTATE("OPEN TIMEOUT")=30
+        S HLCSTATE("READ")="" ;buffer for reads
+        ;
+        ;HLCSTATE("BUFFER",<seg>,<line>)  write buffer
+        S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer
+        S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
+        ;
+        S HLCSTATE("COUNTS")=0
+        S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
+        S NODE=^%ZOSF("OS")
+        S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
+        Q:HLCSTATE("SYSTEM","OS")="" 0
+        D  ;get necessary system parameters
+        .N SYS,SUB
+        .D SYSPARMS^HLOSITE(.SYS)
+        .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB)
+        .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
+        I HLCSTATE("LINK","LLP")="TCP" D
+        .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
+        E  ;no other LLP implemented
+        ;
+        Q HLCSTATE("CONNECTED")
+        ;
+INQUE(MSGIEN,PARMS)     ;
+        ;puts received messages on the incoming queue and sets the B x-refs
+        I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS
+        I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D
+        .F  S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN  D
+        ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
+        ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
+        ..D:INQUE(MSGIEN,"PASS")
+        ...N PURGE
+        ...S PURGE=+$G(INQUE(MSGIEN,"PURGE"))
+        ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN"))
+        ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
+        .K INQUE S INQUE=0
+        Q
+        ;
+SAVEACK(HLMSTATE,SENT)  ;
+        ;Input:
+        ;  SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
+        ;
+        N NODE,I
+        S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
+        S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
+        S $P(NODE,"^",3)="MSA"
+        F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I))
+        S ^HLB(HLMSTATE("IEN"),4)=NODE
+        S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1
+        Q
+        ;
+UPDATE(HLMSTATE,HLCSTATE)       ;
+        ;Updates status and purge date when appropriate
+        ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
+        ;
+        N PARMS,PURGE,WAIT
+        S PARMS("PASS")=0
+        I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D
+        .N IEN
+        .S IEN=HLMSTATE("IEN")
+        .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2)
+        D:'PARMS("PASS")  ;if not passing to the app, set the purge date
+        .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
+        .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
+        .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="ER"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="ER":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
+        .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
+        .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
+        .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
+        .;if this is an app ack, purge the original message at the same time
+        .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D
+        ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
+        ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
+        ;
+        ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message
+        I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU"
+        I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
+        .N APP
+        .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
+        .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+        ;
+        ;set the necessary parms for passing the msg to the app via the infiler
+        D:PARMS("PASS")
+        .N I,FROM
+        .S FROM=HLMSTATE("HDR","SENDING FACILITY",1)
+        .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
+        .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
+        .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
+        .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1)
+        .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
+        ;
+        S PARMS("BODY")=HLMSTATE("BODY")
+        S PARMS("DT/TM")=HLMSTATE("DT/TM")
+        S PARMS("MSGID")=HLMSTATE("ID")
+        D INQUE(HLMSTATE("IEN"),.PARMS)
+        Q
+        ;
+WRITEACK(HLCSTATE,HLMSTATE)     ;
+        ;Sends an accept ack
+        ;
+        ;Input:
+        ;  HLCSTATE (pass by reference) defines the communication channel
+        ;  HLMSTATE (pass by reference) the message being acked
+        ;     ("MSA",1) - value for MSA-1
+        ;     ("MSA",2) - value for MSA-2
+        ;     ("MSA",3) - value for MSA-3
+        ;     ("HDR") - parsed values for the message being ack'd
+        ;Output:
+        ;  Function returns 1 if successful, 0 otherwise
+        ;  HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
+        ;  HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
+        ;
+        N HDR,SUB,FS,CS,MSA,ACKID,TIME
+        ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
+        S FS="|"
+        S CS="^"
+        S TIME=$$NOW^XLFDT
+        S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
+        S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
+        S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
+        ;
+        S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
+        S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3)
+        ;
+        S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE"
+        ;
+        S MSA(1)="MSA"_FS
+        F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
+        I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1
+        S HLMSTATE("MSA","DT/TM OF MESSAGE")=""
+        Q 0
+HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+GETWORK(WORK) ;
+ ;GET WORK function for a single server or a Taskman multi-server
+ N LINK
+ I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1
+ Q 0
+ ;
+DOWORKS(WORK) ;
+ ;DO WORK rtn for a single server (non-concurrent)
+ D SERVER(WORK("LINK"))
+ Q
+DOWORKM(WORK) ;
+ ;DO WORK rtn for a Taskman multi-server (Cache systems only)
+ D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
+ Q
+ ;
+VMS2(LINKNAME) ;called from a VMS TCP Service once a connection request has been received.  This entry point should be used only if an additional VMS TCPIP Services are being created for HLO.
+ ;Input:
+ ;   LINKNAME - only pass it in if an additional service is being created on a different port
+ Q:'$L(LINKNAME)
+ D VMS
+ Q
+ ;
+VMS ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port.
+ Q:$$CHKSTOP^HLOPROC
+ D
+ .Q:$L($G(LINKNAME))
+ .;
+ .N PROC,NODE
+ .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0))
+ .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME)
+ .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME)
+ .S LINKNAME="HLO DEFAULT LISTENER"
+ ;
+ D SERVER(LINKNAME,"SYS$NET")
+ Q
+ ;
+SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1"
+ N HLCSTATE,INQUE
+ S INQUE=0
+ Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
+ K LINKNAME
+ F  Q:'HLCSTATE("CONNECTED")  D  Q:$$CHKSTOP^HLOPROC
+ .N HLMSTATE,SENT
+ .;
+ .;read msg and parse the hdr
+ .;HLMSTATE("MSA",1) is set with type of ack to return
+ .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D
+ ..;
+ ..;send an ack if required and save the MSA segment
+ ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT)
+ ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
+ ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
+ .E  D INQUE() H:HLCSTATE("CONNECTED") 1
+ ;
+END D CLOSE^HLOT(.HLCSTATE)
+ D INQUE()
+ D SAVECNTS^HLOSTAT(.HLCSTATE)
+ Q
+ ;
+CONNECT(HLCSTATE,LINKNAME,LOGICAL) ;
+ ;sets up HLCSTATE() and opens a server connection
+ ;
+ N LINK,NODE
+ S HLCSTATE("CONNECTED")=0
+ Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0
+ Q:+LINK("SERVER")'=1 0
+ S HLCSTATE("SERVER")=LINK("SERVER")
+ M HLCSTATE("LINK")=LINK
+ S HLCSTATE("READ TIMEOUT")=20
+ S HLCSTATE("OPEN TIMEOUT")=30
+ S HLCSTATE("READ")="" ;buffer for reads
+ ;
+ ;HLCSTATE("BUFFER",<seg>,<line>)  write buffer
+ S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer
+ S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
+ ;
+ S HLCSTATE("COUNTS")=0
+ S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
+ S NODE=^%ZOSF("OS")
+ S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
+ Q:HLCSTATE("SYSTEM","OS")="" 0
+ D  ;get necessary system parameters
+ .N SYS,SUB
+ .D SYSPARMS^HLOSITE(.SYS)
+ .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB)
+ .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
+ I HLCSTATE("LINK","LLP")="TCP" D
+ .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
+ E  ;no other LLP implemented
+ ;
+ Q HLCSTATE("CONNECTED")
+ ;
+INQUE(MSGIEN,PARMS) ;
+ ;puts received messages on the incoming queue and sets the B x-refs
+ I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS
+ I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D
+ .F  S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN  D
+ ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
+ ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
+ ..D:INQUE(MSGIEN,"PASS")
+ ...N PURGE
+ ...S PURGE=+$G(INQUE(MSGIEN,"PURGE"))
+ ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN"))
+ ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
+ .K INQUE S INQUE=0
+ Q
+ ;
+SAVEACK(HLMSTATE,SENT) ;
+ ;Input:
+ ;  SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
+ ;
+ N NODE,I
+ S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
+ S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
+ S $P(NODE,"^",3)="MSA"
+ F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I))
+ S ^HLB(HLMSTATE("IEN"),4)=NODE
+ S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1
+ Q
+ ;
+UPDATE(HLMSTATE,HLCSTATE) ;
+ ;Updates status and purge date when appropriate
+ ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
+ ;
+ N PARMS,PURGE,WAIT
+ S PARMS("PASS")=0
+ I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D
+ .N IEN
+ .S IEN=HLMSTATE("IEN")
+ .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2)
+ D:'PARMS("PASS")  ;if not passing to the app, set the purge date
+ .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
+ .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
+ .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="AE"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
+ .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
+ .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
+ .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
+ .;if this is an app ack, purge the original message at the same time
+ .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D
+ ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
+ ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
+ ;
+ ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message
+ I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU"
+ I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
+ .N APP
+ .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
+ .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
+ ;
+ ;set the necessary parms for passing the msg to the app via the infiler
+ D:PARMS("PASS")
+ .N I,FROM
+ .S FROM=HLMSTATE("HDR","SENDING FACILITY",1)
+ .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
+ .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
+ .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
+ .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1)
+ .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
+ ;
+ S PARMS("BODY")=HLMSTATE("BODY")
+ S PARMS("DT/TM")=HLMSTATE("DT/TM")
+ S PARMS("MSGID")=HLMSTATE("ID")
+ D INQUE(HLMSTATE("IEN"),.PARMS)
+ Q
+ ;
+WRITEACK(HLCSTATE,HLMSTATE) ;
+ ;Sends an accept ack
+ ;
+ ;Input:
+ ;  HLCSTATE (pass by reference) defines the communication channel
+ ;  HLMSTATE (pass by reference) the message being acked
+ ;     ("MSA",1) - value for MSA-1
+ ;     ("MSA",2) - value for MSA-2
+ ;     ("MSA",3) - value for MSA-3
+ ;     ("HDR") - parsed values for the message being ack'd
+ ;Output:
+ ;  Function returns 1 if successful, 0 otherwise
+ ;  HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
+ ;  HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
+ ;
+ N HDR,SUB,FS,CS,MSA,ACKID,TIME
+ ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
+ S FS="|"
+ S CS="^"
+ S TIME=$$NOW^XLFDT
+ S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
+ S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
+ S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
+ ;
+ S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
+ S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3)
+ ;
+ S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE"
+ ;
+ S MSA(1)="MSA"_FS
+ F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
+ I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1
+ S HLMSTATE("MSA","DT/TM OF MESSAGE")=""
+ Q 0

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m

-              r613
+              r623
+HLOSRVR1        ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;07/17/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+READMSG(HLCSTATE,HLMSTATE)      ;
+        ;Reads a message.  The header is parsed. Does these checks:
+        ; 1) Duplicate?
+        ; 2) Wrong Receiving Facility?
+        ; 3) Can the Receiving App accept this message, based message type & event?
+        ; 4) Processing ID must match the receiving system
+        ; 5) Must have an ID
+        ; 6) Header must be BHS or MSH
+        ;
+        ;Output:
+        ;  Function returns 1 if the message was read fully, 0 otherwise
+        ;  HLMSTATE (pass by reference) the message.  It will include the fields for the return ack in HLMSTATE("MSA")
+        ;
+        N ACK,SEG,STORE,I
+        ;
+        S STORE=1
+        Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
+        D SPLITHDR(.SEG)
+        ;
+        ;parse the header, stop if unsuccessful because the server cannot know what to do next
+        I '$$PARSEHDR^HLOPRS(.SEG) D  Q 0
+        .S HLCSTATE("MESSAGE ENDED")=0
+        .D CLOSE^HLOT(.HLCSTATE)
+        D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
+        I HLMSTATE("ID")="" D
+        .S STORE=0
+        .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
+        I STORE,$$DUP(.HLMSTATE) S STORE=0
+        ;
+        ;if the message is not to be stored, just read it and discard the segments
+        I 'STORE D
+        .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
+        ;
+        E  D
+        .N FS
+        .S FS=HLMSTATE("HDR","FIELD SEPARATOR")
+        .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
+        ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT
+        ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
+        ..I SEGTYPE="MSA" D
+        ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
+        ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30)
+        ...I $E(CODE,1)'="A" S SEGTYPE="" Q
+        ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
+        ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
+        ..I 'HLMSTATE("BATCH") D
+        ...D:SEGTYPE="MSA"
+        ....S HLMSTATE("ACK TO")=OLDMSGID
+        ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
+        ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER")
+        ....I $G(IEN) D
+        .....S HLMSTATE("ACK TO","IEN")=IEN
+        .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
+        ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
+        ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
+        ..E  D  ;batch
+        ...I SEGTYPE="MSH" D
+        ....D SPLITHDR(.SEG)
+        ....S NEWMSGID=$P(SEG(2),FS,5)
+        ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
+        ...E  D  ;not MSH
+        ....D:SEGTYPE="MSA"
+        .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
+        .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
+        .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
+        .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER")
+        .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
+        ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
+        .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
+        ;
+        I STORE,'HLCSTATE("MESSAGE ENDED") D
+        .;reading failed, don't store
+        .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
+        .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
+        E  D:STORE
+        .D CHECKMSG(.HLMSTATE)
+        .D ADDAC(.HLMSTATE) ;so future duplicates are detected
+        .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
+        ;
+        D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
+        Q HLCSTATE("MESSAGE ENDED")
+        ;
+ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
+        ;
+        N FROM
+        S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+        S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
+        Q
+        ;
+DUP(HLMSTATE)   ;
+        ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
+        ;Input:
+        ; HLMSTATE (pass by reference) the message being read
+        ;Output:
+        ;  Function returns 1 if the message is a duplicate, 0 otherwise
+        ;  HLMSTATE (pass by reference) IF the message is a duplicate:
+        ;     returns the prior MSA segment in HLMSTATE("MSA")
+        ;
+        N IEN,FROM,DUP
+        S (IEN,DUP)=0
+        ;
+        ;no way to determine!  Bad header will be rejected
+        Q:(HLMSTATE("ID")="") 0
+        ;
+        S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+        F  S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN  D  Q:DUP
+        .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
+        .;need the MSA to return
+        .D  Q
+        ..N NODE
+        ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
+        ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
+        ..Q:$L(HLMSTATE("MSA",1))'=2
+        ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
+        ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
+        ..S DUP=1
+        ;
+        Q DUP
+        ;
+CHECKMSG(HLMSTATE)      ;
+        ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
+        ;Input:
+        ;  HLMSTATE("HDR") - the parsed header segment
+        ;Output:
+        ;  HLMSTATE("STATUS")="ER" if an error is detected
+        ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
+        ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
+        ;  HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
+        ;
+        N WANTACK,PASS,ACTION,QUEUE,ERROR
+        M HDR=HLMSTATE("HDR")
+        S ERROR=0
+        I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
+        .S WANTACK=0
+        E  D
+        .S WANTACK=1
+        I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q
+        I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
+        .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q
+        .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
+        E  D  Q:ERROR  ;this is an app ack
+        .;does the original message exist?
+        .N NODE
+        .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
+        .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
+        .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
+        .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
+        .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
+        .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
+        .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
+        ;
+        I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
+        ;
+        ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
+        S PASS=0
+        D
+        .;if its an ack to an existing message, don't check the receiving facility
+        .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
+        .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
+        .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
+        .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
+        .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
+        .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
+        I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
+        I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
+        Q
+        ;
+DEL777(IEN777)  ;delete a record from file 777 where the read did not complete
+        ;
+        K ^HLA(IEN777,0)
+        Q
+DEL778(IEN778)  ;delete a record from file 778 where the read did not complete
+        ;
+        K ^HLB(IEN778,0)
+        Q
+        ;
+SPLITHDR(HDR)   ;
+        ;splits hdr segment into two lines, first being just components 1-6
+        ;
+        N TEMP,FS
+        D SQUISH(.HDR)
+        S FS=$E($G(HDR(1)),4)
+        S TEMP(1)=$P($G(HDR(1)),FS,1,6)
+        S TEMP(2)=""
+        I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
+        S HDR(2)=TEMP(2)_$G(HDR(2))
+        S HDR(1)=TEMP(1)
+        Q
+        ;
+SQUISH(SEG)     ;
+        ;reformat the segment array into full lines
+        ;
+        ;nothing to do if less than 2 lines
+        Q:'$O(SEG(1))
+        ;
+        N A,I,J,K,MAX,COUNT,LEN
+        S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
+        S (COUNT,I)=0,J=1
+        F  S I=$O(SEG(I)) Q:'I  D
+        .S LEN=$L(SEG(I))
+        .F K=1:1:LEN D
+        ..S A(J)=$G(A(J))_$E(SEG(I),K)
+        ..S COUNT=COUNT+1
+        ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
+        K SEG
+        M SEG=A
+        Q
+        ;
+ERROR   ;error trap
+        S $ETRAP="Q:$QUIT """" Q"
+        D END^HLOSRVR
+        ;
+        ;multi-listener should stop execution, only a single server may continue
+        I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
+        .;don't log these errors
+        .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+        ..;
+        .E  D
+        ..D ^%ZTER
+        ;
+        ;debugging?
+        I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
+        ;
+        ;possibly an endless loop?
+        N HOUR
+        S HOUR=$E($$NOW^XLFDT,1,10)
+        I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+        ;
+        ;resume execution for the single listener
+        S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+        D UNWIND^%ZTER
+        Q
+HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;03/26/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+READMSG(HLCSTATE,HLMSTATE) ;
+ ;Reads a message.  The header is parsed. Does these checks:
+ ; 1) Duplicate?
+ ; 2) Wrong Receiving Facility?
+ ; 3) Can the Receiving App accept this message, based message type & event?
+ ; 4) Processing ID must match the receiving system
+ ; 5) Must have an ID
+ ; 6) Header must be BHS or MSH
+ ;
+ ;Output:
+ ;  Function returns 1 if the message was read fully, 0 otherwise
+ ;  HLMSTATE (pass by reference) the message.  It will include the fields for the return ack in HLMSTATE("MSA")
+ ;
+ N ACK,SEG,STORE,I
+ ;
+ S STORE=1
+ Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
+ D SPLITHDR(.SEG)
+ ;
+ ;parse the header, stop if unsuccessful because the server cannot know what to do next
+ I '$$PARSEHDR^HLOPRS(.SEG) D  Q 0
+ .S HLCSTATE("MESSAGE ENDED")=0
+ .D CLOSE^HLOT(.HLCSTATE)
+ D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
+ I HLMSTATE("ID")="" D
+ .S STORE=0
+ .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
+ I STORE,$$DUP(.HLMSTATE) S STORE=0
+ ;
+ ;if the message is not to be stored, just read it and discard the segments
+ I 'STORE D
+ .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
+ ;
+ E  D
+ .N FS
+ .S FS=HLMSTATE("HDR","FIELD SEPARATOR")
+ .F  Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)  D
+ ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT
+ ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
+ ..I SEGTYPE="MSA" D
+ ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
+ ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30)
+ ...I $E(CODE,1)'="A" S SEGTYPE="" Q
+ ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
+ ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
+ ..I 'HLMSTATE("BATCH") D
+ ...D:SEGTYPE="MSA"
+ ....S HLMSTATE("ACK TO")=OLDMSGID
+ ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
+ ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
+ ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
+ ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
+ ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
+ ..E  D  ;batch
+ ...I SEGTYPE="MSH" D
+ ....D SPLITHDR(.SEG)
+ ....S NEWMSGID=$P(SEG(2),FS,5)
+ ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
+ ...E  D  ;not MSH
+ ....D:SEGTYPE="MSA"
+ .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
+ .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
+ .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
+ .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
+ .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
+ ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
+ .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
+ ;
+ I STORE,'HLCSTATE("MESSAGE ENDED") D
+ .;reading failed, don't store
+ .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
+ .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
+ E  D:STORE
+ .D CHECKMSG(.HLMSTATE)
+ .D ADDAC(.HLMSTATE) ;so future duplicates are detected
+ .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
+ ;
+ D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
+ Q HLCSTATE("MESSAGE ENDED")
+ ;
+ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
+ ;
+ N FROM
+ S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+ S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
+ Q
+ ;
+DUP(HLMSTATE) ;
+ ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
+ ;Input:
+ ; HLMSTATE (pass by reference) the message being read
+ ;Output:
+ ;  Function returns 1 if the message is a duplicate, 0 otherwise
+ ;  HLMSTATE (pass by reference) IF the message is a duplicate:
+ ;     returns the prior MSA segment in HLMSTATE("MSA")
+ ;
+ N IEN,FROM,DUP
+ S (IEN,DUP)=0
+ ;
+ ;no way to determine!  Bad header will be rejected
+ Q:(HLMSTATE("ID")="") 0
+ ;
+ S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
+ F  S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN  D  Q:DUP
+ .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
+ .;need the MSA to return
+ .D  Q
+ ..N NODE
+ ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
+ ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
+ ..Q:$L(HLMSTATE("MSA",1))'=2
+ ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
+ ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
+ ..S DUP=1
+ ;
+ Q DUP
+ ;
+CHECKMSG(HLMSTATE) ;
+ ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
+ ;Input:
+ ;  HLMSTATE("HDR") - the parsed header segment
+ ;Output:
+ ;  HLMSTATE("STATUS")="SE" if an error is detected
+ ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
+ ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
+ ;  HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
+ ;
+ N WANTACK,PASS,ACTION,QUEUE,ERROR
+ M HDR=HLMSTATE("HDR")
+ S ERROR=0
+ I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
+ .S WANTACK=0
+ E  D
+ .S WANTACK=1
+ I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
+ I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
+ .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
+ .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
+ E  D  Q:ERROR  ;this is an app ack
+ .;does the original message exist?
+ .N NODE
+ .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
+ .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
+ .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
+ .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
+ .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
+ .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
+ .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
+ ;
+ I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
+ ;
+ ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
+ S PASS=0
+ D
+ .;if its an ack to an existing message, don't check the receiving facility
+ .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
+ .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
+ .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
+ .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
+ .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
+ .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
+ I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
+ I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
+ Q
+ ;
+DEL777(IEN777) ;delete a record from file 777 where the read did not complete
+ ;
+ K ^HLA(IEN777,0)
+ Q
+DEL778(IEN778) ;delete a record from file 778 where the read did not complete
+ ;
+ K ^HLB(IEN778,0)
+ Q
+ ;
+SPLITHDR(HDR) ;
+ ;splits hdr segment into two lines, first being just components 1-6
+ ;
+ N TEMP,FS
+ D SQUISH(.HDR)
+ S FS=$E($G(HDR(1)),4)
+ S TEMP(1)=$P($G(HDR(1)),FS,1,6)
+ S TEMP(2)=""
+ I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
+ S HDR(2)=TEMP(2)_$G(HDR(2))
+ S HDR(1)=TEMP(1)
+ Q
+ ;
+SQUISH(SEG) ;
+ ;reformat the segment array into full lines
+ ;
+ ;nothing to do if less than 2 lines
+ Q:'$O(SEG(1))
+ ;
+ N A,I,J,K,MAX,COUNT,LEN
+ S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
+ S (COUNT,I)=0,J=1
+ F  S I=$O(SEG(I)) Q:'I  D
+ .S LEN=$L(SEG(I))
+ .F K=1:1:LEN D
+ ..S A(J)=$G(A(J))_$E(SEG(I),K)
+ ..S COUNT=COUNT+1
+ ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
+ K SEG
+ M SEG=A
+ Q
+ ;
+ERROR ;error trap
+ S $ETRAP="Q:$QUIT """" Q"
+ D END^HLOSRVR
+ ;
+ ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
+ I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
+ .;don't log these common errors
+ .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+ ..;
+ .E  D
+ ..D ^%ZTER
+ ;
+ ;while debugging quit on all errors
+ I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
+ ;
+ ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count
+ N HOUR
+ S HOUR=$E($$NOW^XLFDT,1,10)
+ ;
+ I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
+ ;
+ ;resume execution for the single listener
+ S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
+ D UNWIND^%ZTER
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m

-              r613
+              r623
+HLOSRVR2        ;ALB/CJM-HL7 - HLO Server ;07/20/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**131,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+NEWMSG(HLCSTATE,HLMSTATE,HDR)   ;
+        ;initialize the HLMSTATE array after reading the header
+        ;Inputs:
+        ;  HLCSTATE (pass by reference)
+        ;  HDR (pass by reference) parsed header
+        ;Output:
+        ;  HLMSTATE (pass by reference)
+        ;
+        K HLMSTATE
+        S HLMSTATE("IEN")=""
+        S HLMSTATE("BODY")=""
+        S HLMSTATE("DIRECTION")="IN"
+        S HLMSTATE("CURRENT SEGMENT")=0 ;no segments in cache
+        S HLMSTATE("UNSTORED LINES")=1 ;just the header in cache so far
+        S HLMSTATE("LINE COUNT")=0 ;no lines within message stored to disk
+        I HDR("SEGMENT TYPE")="BHS" D
+        .S HLMSTATE("BATCH")=1
+        .S HLMSTATE("ID")=HDR("BATCH CONTROL ID")
+        .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 ;no messages in batch
+        .S HLMSTATE("UNSTORED MSH")=0
+        E  D
+        .S HLMSTATE("BATCH")=0
+        .S HLMSTATE("ID")=HDR("MESSAGE CONTROL ID")
+        M HLMSTATE("HDR")=HDR
+        M HLMSTATE("SYSTEM")=HLCSTATE("SYSTEM")
+        S HLMSTATE("STATUS")=""
+        S HLMSTATE("STATUS","QUEUE")=""
+        S HLMSTATE("STATUS","ACTION")=""
+        S HLMSTATE("STATUS","LINK NAME")=HLCSTATE("LINK","NAME")
+        S HLMSTATE("STATUS","PORT")=$P(HDR("SENDING FACILITY",2),":",2)
+        ;
+        ;if this is a batch, and it references another batch, assume it is a b.
+        I HLMSTATE("BATCH"),HLMSTATE("ID")]"" D
+        .N IEN
+        .S HLMSTATE("ACK TO")=HLMSTATE("ID")
+        .S HLMSTATE("ACK TO","STATUS")="SU"
+        .S IEN=$O(^HLB("B",HLMSTATE("ID"),0))
+        .I IEN S HLMSTATE("ACK TO","IEN")=IEN_"^"
+        E  S HLMSTATE("ACK TO")=""
+        I 'HLMSTATE("BATCH"),HDR("ACCEPT ACK TYPE")="",HDR("APP ACK TYPE")="" D
+        .S HLMSTATE("ORIGINAL MODE")=1
+        E  D
+        .S HLMSTATE("ORIGINAL MODE")=0
+        N I F I=1,3 S HLMSTATE("MSA",I)=""
+        S HLMSTATE("MSA",2)=HLMSTATE("ID")
+        Q
+HLOSRVR2 ;ALB/CJM-HL7 - Sends an application ack over an open connection, for original mode ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**131**;Oct 13, 1995;Build 10
+ ;
+NEWMSG(HLCSTATE,HLMSTATE,HDR) ;
+ ;initialize the HLMSTATE array after reading the header
+ ;Inputs:
+ ;  HLCSTATE (pass by reference)
+ ;  HDR (pass by reference) parsed header
+ ;Output:
+ ;  HLMSTATE (pass by reference)
+ ;
+ K HLMSTATE
+ S HLMSTATE("IEN")=""
+ S HLMSTATE("BODY")=""
+ S HLMSTATE("DIRECTION")="IN"
+ S HLMSTATE("CURRENT SEGMENT")=0 ;no segments in cache
+ S HLMSTATE("UNSTORED LINES")=1 ;just the header in cache so far
+ S HLMSTATE("LINE COUNT")=0 ;no lines within message stored to disk
+ I HDR("SEGMENT TYPE")="BHS" D
+ .S HLMSTATE("BATCH")=1
+ .S HLMSTATE("ID")=HDR("BATCH CONTROL ID")
+ .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 ;no messages in batch
+ .S HLMSTATE("UNSTORED MSH")=0
+ E  D
+ .S HLMSTATE("BATCH")=0
+ .S HLMSTATE("ID")=HDR("MESSAGE CONTROL ID")
+ M HLMSTATE("HDR")=HDR
+ M HLMSTATE("SYSTEM")=HLCSTATE("SYSTEM")
+ S HLMSTATE("STATUS")=""
+ S HLMSTATE("STATUS","QUEUE")=""
+ S HLMSTATE("STATUS","ACTION")=""
+ S HLMSTATE("STATUS","LINK NAME")=HLCSTATE("LINK","NAME")
+ S HLMSTATE("STATUS","PORT")=$P(HDR("SENDING FACILITY",2),":",2)
+ ;
+ ;if this is a batch, and it references another batch, assume it is a b.
+ I HLMSTATE("BATCH"),HLMSTATE("ID")]"" D
+ .N IEN
+ .S HLMSTATE("ACK TO")=HLMSTATE("ID")
+ .S HLMSTATE("ACK TO","STATUS")="SU"
+ .S IEN=$O(^HLB("B",HLMSTATE("ID"),0))
+ .I IEN S HLMSTATE("ACK TO","IEN")=IEN_"^"
+ E  S HLMSTATE("ACK TO")=""
+ I 'HLMSTATE("BATCH"),HDR("ACCEPT ACK TYPE")="",HDR("APP ACK TYPE")="" D
+ .S HLMSTATE("ORIGINAL MODE")=1
+ E  D
+ .S HLMSTATE("ORIGINAL MODE")=0
+ N I F I=1,3 S HLMSTATE("MSA",I)=""
+ S HLMSTATE("MSA",2)=HLMSTATE("ID")
+ Q
+ ;
+ACKNOW(MSG,ERROR) ;
+ ;Sends the messge immediately if there is an open connection, otherwise
+ ;will return an error.
+ ;
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR2"
+ N SENT
+ S SENT=0,ERROR=""
+ I '$G(HLCSTATE("CONNECTED")) D
+ .S ERROR="NOT CONNECTED"
+ .S MSG("STATUS")="TF"
+ E  S MSG("STATUS")="SU"
+ S:'$G(MSG("DT/TM CREATED")) MSG("DT/TM CREATED")=$$NOW^XLFDT
+ S MSG("STATUS","PURGE")=$$FMADD^XLFDT(MSG("DT/TM CREATED"),$S($G(HLCSTATE("ERROR PURGE")):HLCSTATE("ERROR PURGE"),1:7))
+ D
+ .I $G(MSG("UNSTORED LINES")),'$$SAVEMSG^HLOF777(.MSG) S ERROR="$$SAVE^HLOF777 FAILED!" Q
+ .I '$$SAVEMSG^HLOF778(.MSG) S ERROR="$$SAVE^HLOF778 FAILED!" Q
+ .Q:MSG("STATUS")'="SU"
+ .I '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.MSG) S ERROR="TRANSMISSION FAILURE" Q
+ .S SENT=1
+ .D COUNT^HLOSTAT(.HLCSTATE,ACK("HDR","RECEIVING APPLICATION"),ACK("HDR","SENDING APPLICATION"),ACK("HDR","MESSAGE TYPE")_"~"_ACK("HDR","EVENT"))
+ ;
+END ;
+ I 'SENT,MSG("STATUS")="SU",$G(MSG("IEN")) D
+ .Q:'$D(^HLB(MSG("IEN"),0))
+ .S MSG("STATUS")="TF"
+ .S MSG("STATUS","ERROR TEXT")=ERROR
+ .S $P(^HLB(MSG("IEN"),0),"^",20)=MSG("STATUS")
+ .S $P(^HLB(MSG("IEN"),0),"^",21)=MSG("STATUS","ERROR TEXT")
+ .S ^HLB("ERRORS","TF",$S($L($G(MSG("HDR","RECEIVING APPLICATION"))):MSG("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),MSG("DT/TM CREATED"),IEN)=""
+ ;
+ Q SENT
+ ;
+ERROR ;error trap for ACKNOW
+ S SENT=0,ERROR="TRANSMISSION FAILURE:"_$P($ECODE,",",1,2)
+ S $ETRAP="D UNWIND^%ZTER"
+ ;
+ ;don't log some common errors
+ I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+ .;nothing!
+ E  D
+ .D ^%ZTER
+ G END^HLOSRVR2
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m

-              r613
+              r623
 HLOTCP  ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;07/10/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
 OPEN(HLCSTATE,LOGICAL)  ;
         ;This may be called either in the context of a client or a server.
         ;For the server, there are 3 situations:
         ; 1) The server is not concurrent.  In this case the TCP device should be opened.
         ; 2) The server is concurrent, but this process was spawned by the OS
         ;    (via a VMS TCP Service)  In this case, the device should be opened
         ;    via the LOGICAL that was passed in.
         ;  3) The server is concurrent, but this process was spawned by the
         ;     TaskMan multi-listener.  In this case TaskMan already opened the
         ;     device.  This case can be determined by the absence of the LOGICAL
         ;     input parameter.
+        ;
         N IP,PORT,DNSFLAG
+        ;
         S DNSFLAG=0 ;DNS has not been contacted for IP
+        ;
         S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP")
         S PORT=HLCSTATE("LINK","PORT")
         S HLCSTATE("CONNECTED")=0
         S HLCSTATE("READ HEADER")="READHDR^HLOTCP"
         S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
         S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
         S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
         S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
         S HLCSTATE("CLOSE")="CLOSE^HLOTCP"
+        ;
         ;spawned by TaskMan multi-listener? If so, the device has already been opened
         I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D  Q
         .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510
         .S HLCSTATE("CONNECTED")=1
+        ;
         ;if no IP, not a server, give DNS a shot
         I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP=""
+        ;
 RETRY   I HLCSTATE("SYSTEM","OS")="DSM" D
         .S HLCSTATE("TCP BUFFER SIZE")=512
         .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
         .E  S HLCSTATE("DEVICE")=PORT
         .S HLCSTATE("FLUSH")="!"
         .I $G(HLCSTATE("SERVER")) D
         ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
         ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
         ..I $T D
         ...S HLCSTATE("CONNECTED")=1
         ...U HLCSTATE("DEVICE"):NOECHO
         .E  D  ;client
         ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
         ..I $T D
         ...S HLCSTATE("CONNECTED")=1
         ...U HLCSTATE("DEVICE"):NOECHO
         E  I HLCSTATE("SYSTEM","OS")="CACHE" D
         .S HLCSTATE("FLUSH")="!"
         .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
         .E  S HLCSTATE("DEVICE")="|TCP|"_PORT
         .S HLCSTATE("TCP BUFFER SIZE")=510
         .I $G(HLCSTATE("SERVER")) D
         ..I HLCSTATE("SERVER")="1^S" D  Q
         ...;single server (no concurrent connections)
         ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
         ...I $T D
         ....N A
         ....S HLCSTATE("CONNECTED")=1
         ....U HLCSTATE("DEVICE")
         ....F  R *A:HLCSTATE("READ TIMEOUT") Q:$T  I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q
         ..;
         ..;multi-server spawned by OS - VMS TCP Services
         ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q
         ..S HLCSTATE("CONNECTED")=1
         ..U HLCSTATE("DEVICE"):(::"-S")
         ..;
         .E  D  ;client
         ..S HLCSTATE("TCP BUFFER SIZE")=510
         ..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
         ..I $T D
         ...S HLCSTATE("CONNECTED")=1
         E  D  ;any other system but Cache or DSM
         .S HLCSTATE("TCP BUFFER SIZE")=256
         .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
         .S HLCSTATE("CONNECTED")='POP
         .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO
+        ;
         ;if not connected, not the server, give DNS a shot if not tried already
         I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY
         I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
+        Q
+        ;
 DNS(DOMAIN)     ;
         Q $P($$ADDRESS^XLFNSLK(DOMAIN),",")
+        ;
 WRITEHDR(HLCSTATE,HDR)  ;
+        ;
         ;insure that package buffer is empty
         K HLCSTATE("BUFFER")
         S HLCSTATE("BUFFER","BYTE COUNT")=0
         S HLCSTATE("BUFFER","SEGMENT COUNT")=0
         S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0
+        ;
         ;Start the message with <SB>, then write the header
         N SEG
         S SEG(1)=$C(11)_HDR(1)
         S SEG(2)=HDR(2)
         Q $$WRITESEG(.HLCSTATE,.SEG)
+        ;
 WRITESEG(HLCSTATE,SEG)  ;
         N I,LAST
         S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
         S I=0,LAST=$O(SEG(99999),-1)
         F  S I=$O(SEG(I)) Q:'I  D
         .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH
         .I I=LAST S SEG(I)=SEG(I)_$C(13)
         .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20
         Q HLCSTATE("CONNECTED")
+        ;
 FLUSH   ;flushes the HL7 package buffer, and the system TCP buffer when full
         N SEGMENT,MAX
         S SEGMENT=0
         S MAX=HLCSTATE("TCP BUFFER SIZE")
         U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
         F  S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT  D
         .N I S I=0
         .F  S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I  D
         ..N LINE,J
         ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X)
         ..S HLCSTATE("FIRST WRITE")=0
         ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
         ..F  Q:'(J+$L(LINE)>MAX)  D
+        ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
         ...S LINE=$E(LINE,(MAX-J)+1,99999)
         ...S J=0
+        ..I (LINE]"") W LINE S HLCSTATE("FLUSHED")=0
         K HLCSTATE("BUFFER")
         S HLCSTATE("BUFFER","SEGMENT COUNT")=1
         S HLCSTATE("BUFFER","BYTE COUNT")=0
         S HLCSTATE("FIRST WRITE")=0
+        Q
+        ;
 READSEG(HLCSTATE,SEG)   ;
+        ;
         ;Output:
         ;  SEG - returns the segment (pass by reference)
         ;  Function returns 1 on success, 0 on failure
+        ;
         N SUCCESS,COUNT,BUF
         S (COUNT,SUCCESS)=0
         K SEG
+        ;
         ;anything left from last read?
         S BUF=HLCSTATE("READ")
         S HLCSTATE("READ")=""
         I BUF]"" D  ;something was left!
         .S COUNT=1
         .I BUF[$C(13) D  Q
         ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999)
         ..S SUCCESS=1
         .S SEG(1)=BUF,BUF=""
         I 'SUCCESS U HLCSTATE("DEVICE") F  R BUF:HLCSTATE("READ TIMEOUT") Q:'$T  D  Q:SUCCESS
         .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q
         .S COUNT=COUNT+1,SEG(COUNT)=BUF
+        ;
         I SUCCESS D
         .S HLCSTATE("READ")=BUF ;save the leftover
         .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1
         ;Cache can return the connection status
         E  I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
+        ;
         ;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
         I SUCCESS,SEG(COUNT)[$C(28) D
         .K SEG
         .S SUCCESS=0
         .S HLCSTATE("MESSAGE ENDED")=1
         Q SUCCESS
+        ;
 READHDR(HLCSTATE,HDR)   ;
         ;reads the next header segment in the message stream, discarding everything that comes before it
+        ;
         N SEG,SUCCESS,J,I
         S SUCCESS=0
         K HDR
         F  Q:'$$READSEG(.HLCSTATE,.SEG)  D  Q:SUCCESS
         .S I=0
         .;look for the <SB>
         .;perhaps the <SB> isn't in the first line
         .F  S I=$O(SEG(I)) Q:'I  D  Q:SUCCESS
         ..I (SEG(I)'[$C(11)) K SEG(I) Q
         ..S SEG(I)=$P(SEG(I),$C(11),2)
         ..S SUCCESS=1
         ..K:SEG(I)="" SEG(I)
         I SUCCESS S (I,J)=0 F  S J=$O(SEG(J)) Q:'J  S I=I+1,HDR(I)=SEG(J)
         Q SUCCESS
+        ;
 CLOSE(HLCSTATE) ;
         CLOSE HLCSTATE("DEVICE")
+        Q
+        ;
 ENDMSG(HLCSTATE)               ;
         N SEG
         S SEG(1)=$C(28)
         I $$WRITESEG(.HLCSTATE,.SEG) D  Q 1
         .D FLUSH
         .U HLCSTATE("DEVICE")
+        .I ('$G(HLCSTATE("FLUSHED")))!$X W @HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
         Q 0
+HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+OPEN(HLCSTATE,LOGICAL) ;
+ ;This may be called either in the context of a client or a server.
+ ;For the server, there are 3 situations:
+ ; 1) The server is not concurrent.  In this case the TCP device should be opened.
+ ; 2) The server is concurrent, but this process was spawned by the OS
+ ;    (via a VMS TCP Service)  In this case, the device should be opened
+ ;    via the LOGICAL that was passed in.
+ ;  3) The server is concurrent, but this process was spawned by the
+ ;     TaskMan multi-listener.  In this case TaskMan already opened the
+ ;     device.  This case can be determined by the absence of the LOGICAL
+ ;     input parameter.
+ ;
+ N IP,PORT,DNSFLAG
+ ;
+ S DNSFLAG=0 ;DNS has not been contacted for IP
+ ;
+ S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP")
+ S PORT=HLCSTATE("LINK","PORT")
+ S HLCSTATE("CONNECTED")=0
+ S HLCSTATE("READ HEADER")="READHDR^HLOTCP"
+ S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
+ S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
+ S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
+ S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
+ S HLCSTATE("CLOSE")="CLOSE^HLOTCP"
+ ;
+ ;spawned by TaskMan multi-listener? If so, the device has already been opened
+ I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D  Q
+ .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510
+ .S HLCSTATE("CONNECTED")=1
+ ;
+ ;if no IP, not a server, give DNS a shot
+ I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP=""
+ ;
+RETRY I HLCSTATE("SYSTEM","OS")="DSM" D
+ .S HLCSTATE("TCP BUFFER SIZE")=512
+ .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
+ .E  S HLCSTATE("DEVICE")=PORT
+ .S HLCSTATE("FLUSH")="!"
+ .I $G(HLCSTATE("SERVER")) D
+ ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+ ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+ ..I $T D
+ ...S HLCSTATE("CONNECTED")=1
+ ...U HLCSTATE("DEVICE"):NOECHO
+ .E  D  ;client
+ ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
+ ..I $T D
+ ...S HLCSTATE("CONNECTED")=1
+ ...U HLCSTATE("DEVICE"):NOECHO
+ E  I HLCSTATE("SYSTEM","OS")="CACHE" D
+ .S HLCSTATE("FLUSH")="!"
+ .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
+ .E  S HLCSTATE("DEVICE")="|TCP|"_PORT
+ .S HLCSTATE("TCP BUFFER SIZE")=510
+ .I $G(HLCSTATE("SERVER")) D
+ ..I HLCSTATE("SERVER")="1^S" D  Q
+ ...;single server (no concurrent connections)
+ ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
+ ...I $T D
+ ....N A
+ ....S HLCSTATE("CONNECTED")=1
+ ....U HLCSTATE("DEVICE")
+ ....F  R *A:HLCSTATE("READ TIMEOUT") Q:$T  I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q
+ ..;
+ ..;multi-server spawned by OS - VMS TCP Services
+ ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q
+ ..S HLCSTATE("CONNECTED")=1
+ ..U HLCSTATE("DEVICE"):(::"-S")
+ ..;
+ .E  D  ;client
+ ..S HLCSTATE("TCP BUFFER SIZE")=510
+ ..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
+ ..I $T D
+ ...S HLCSTATE("CONNECTED")=1
+ E  D  ;any other system but Cache or DSM
+ .S HLCSTATE("TCP BUFFER SIZE")=256
+ .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
+ .S HLCSTATE("CONNECTED")='POP
+ .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO
+ ;
+ ;if not connected, not the server, give DNS a shot if not tried already
+ I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY
+ I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
+ Q
+ ;
+DNS(DOMAIN) ;
+ Q $P($$ADDRESS^XLFNSLK(DOMAIN),",")
+ ;
+WRITEHDR(HLCSTATE,HDR) ;
+ ;
+ ;insure that package buffer is empty
+ K HLCSTATE("BUFFER")
+ S HLCSTATE("BUFFER","BYTE COUNT")=0
+ S HLCSTATE("BUFFER","SEGMENT COUNT")=0
+ S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0
+ ;
+ ;Start the message with <SB>, then write the header
+ N SEG
+ S SEG(1)=$C(11)_HDR(1)
+ S SEG(2)=HDR(2)
+ Q $$WRITESEG(.HLCSTATE,.SEG)
+ ;
+WRITESEG(HLCSTATE,SEG) ;
+ N I,LAST
+ S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
+ S I=0,LAST=$O(SEG(99999),-1)
+ F  S I=$O(SEG(I)) Q:'I  D
+ .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH
+ .I I=LAST S SEG(I)=SEG(I)_$C(13)
+ .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20
+ Q HLCSTATE("CONNECTED")
+ ;
+FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full
+ N SEGMENT,MAX
+ S SEGMENT=0
+ S MAX=HLCSTATE("TCP BUFFER SIZE")
+ U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
+ F  S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT  D
+ .N I S I=0
+ .F  S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I  D
+ ..N LINE,J
+ ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X)
+ ..S HLCSTATE("FIRST WRITE")=0
+ ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
+ ..F  Q:'(J+$L(LINE)>MAX)  D
+ ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
+ ...S LINE=$E(LINE,(MAX-J)+1,99999)
+ ...S J=0
+ ..W:(LINE]"") LINE
+ K HLCSTATE("BUFFER")
+ S HLCSTATE("BUFFER","SEGMENT COUNT")=1
+ S HLCSTATE("BUFFER","BYTE COUNT")=0
+ S HLCSTATE("FIRST WRITE")=0
+ Q
+ ;
+READSEG(HLCSTATE,SEG) ;
+ ;
+ ;Output:
+ ;  SEG - returns the segment (pass by reference)
+ ;  Function returns 1 on success, 0 on failure
+ ;
+ N SUCCESS,COUNT,BUF
+ S (COUNT,SUCCESS)=0
+ K SEG
+ ;
+ ;anything left from last read?
+ S BUF=HLCSTATE("READ")
+ S HLCSTATE("READ")=""
+ I BUF]"" D  ;something was left!
+ .S COUNT=1
+ .I BUF[$C(13) D  Q
+ ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999)
+ ..S SUCCESS=1
+ .S SEG(1)=BUF,BUF=""
+ I 'SUCCESS U HLCSTATE("DEVICE") F  R BUF:HLCSTATE("READ TIMEOUT") Q:'$T  D  Q:SUCCESS
+ .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q
+ .S COUNT=COUNT+1,SEG(COUNT)=BUF
+ ;
+ I SUCCESS D
+ .S HLCSTATE("READ")=BUF ;save the leftover
+ .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1
+ ;Cache can return the connection status
+ E  I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
+ ;
+ ;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
+ I SUCCESS,SEG(COUNT)[$C(28) D
+ .K SEG
+ .S SUCCESS=0
+ .S HLCSTATE("MESSAGE ENDED")=1
+ Q SUCCESS
+ ;
+READHDR(HLCSTATE,HDR) ;
+ ;reads the next header segment in the message stream, discarding everything that comes before it
+ ;
+ N SEG,SUCCESS,J,I
+ S SUCCESS=0
+ K HDR
+ F  Q:'$$READSEG(.HLCSTATE,.SEG)  D  Q:SUCCESS
+ .S I=0
+ .;look for the <SB>
+ .;perhaps the <SB> isn't in the first line
+ .F  S I=$O(SEG(I)) Q:'I  D  Q:SUCCESS
+ ..I (SEG(I)'[$C(11)) K SEG(I) Q
+ ..S SEG(I)=$P(SEG(I),$C(11),2)
+ ..S SUCCESS=1
+ ..K:SEG(I)="" SEG(I)
+ I SUCCESS S (I,J)=0 F  S J=$O(SEG(J)) Q:'J  S I=I+1,HDR(I)=SEG(J)
+ Q SUCCESS
+ ;
+CLOSE(HLCSTATE) ;
+ CLOSE HLCSTATE("DEVICE")
+ Q
+ ;
+ENDMSG(HLCSTATE)        ;
+ N SEG
+ S SEG(1)=$C(28)
+ I $$WRITESEG(.HLCSTATE,.SEG) D  Q 1
+ .D FLUSH
+ .U HLCSTATE("DEVICE")
+ .W:$X @HLCSTATE("FLUSH")
+ Q 0

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m

-              r613
+              r623
+HLOUSR  ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;07/30/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+EN      ;
+        ;
+        N HLSCREEN,TESTOPEN,HLRFRSH,HLPARMS
+        D WAIT^DICD
+        D EN^VALM("HLO SYSTEM MONITOR")
+        Q
+        ;
+BRIEF   ;
+        N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST
+        S HLRFRSH="BRIEF^HLOUSR"
+        S (HLSCREEN,VALMSG)="Brief System Status"
+        S VALMCNT=16
+        ;K @VALMAR
+        D CLEAN^VALM10
+        S VALMBG=1
+        S VALMBCK="R"
+        S VALMDDF("COL 1")="COL1^1^80^"
+        K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5")
+        D CHGCAP^VALM("COL 1"," Brief Operational Overview")
+        S @VALMAR@(1,0)="SYSTEM STATUS:             "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING")
+        S @VALMAR@(2,0)="PROCESS MANAGER:           "_$S($$RUNNING:"RUNNING",1:"STOPPED")
+        ;
+        S TIME=$P($G(TESTOPEN("LISTENER")),"^",2)
+        I TIME,$$FMDIFF^XLFDT($$NOW^XLFDT,TIME,2)<300 D
+        .S STATUS=+TESTOPEN("LISTENER")
+        E  D
+        .S STATUS=0
+        .S LINK=$P($G(^HLD(779.1,1,0)),"^",10)
+        .I LINK S LINK=$P($G(^HLCS(870,LINK,0)),"^") Q:'$L(LINK)  S STATUS=$$IFOPEN^HLOUSR1(LINK)
+        .S TESTOPEN("LISTENER")=STATUS_"^"_$$NOW^XLFDT
+        ;
+        S @VALMAR@(3,0)="STANDARD LISTENER:         "_$S(STATUS:"OPERATIONAL",1:"NOT OPERATIONAL")
+        ;
+        S @VALMAR@(4,0)="TASKMAN:                   "_$S($$TM^%ZTLOAD:"RUNNING",1:"NOT RUNNING")
+        ;
+        S (LIST,LINK)=""
+        F  S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK=""  D  I $L(LIST)>60 S LIST=LIST_",..." Q
+        .N TIME,QUE,LINKARY
+        .I $$GETLINK^HLOTLNK($P(LINK,":"),.LINKARY)
+        .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME=""
+        .I '$G(LINKARY("SHUTDOWN")),TIME="" Q
+        .I '$G(LINKARY("SHUTDOWN")),($$HDIFF^XLFDT($H,TIME,2)<300) Q
+        .S LIST=LIST_$S($L(LIST):", ",1:"")_$P(LINK,":")
+        S @VALMAR@(5,0)="DOWN LINKS: "_LIST
+        S @VALMAR@(6,0)="CLIENT LINK PROCESSES:     "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","OUTGOING CLIENT LINK"))
+        S @VALMAR@(7,0)="IN-FILER PROCESSES:        "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","INCOMING QUEUES"))
+        S COUNT=0,LINK=""
+        F  S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK=""  D
+        .S QUE=""
+        .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  D
+        ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
+        ..S:TEMP>0 COUNT=COUNT+TEMP
+        S @VALMAR@(8,0)="MESSAGES PENDING ON OUT QUEUES:    "_$$RJ(+COUNT,7)_"     ON SEQUENCE QUEUES:  "_$$RJ(+$G(^HLC("QUEUECOUNT","SEQUENCE")),7)
+        S TEMP="STOPPED OUTGOING QUEUES: "
+        S COUNT=0,QUE=""
+        F  S QUE=$O(^HLTMP("STOPPED QUEUES","OUT",QUE)) Q:QUE=""  S COUNT=COUNT+1 Q:COUNT>4  S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..."
+        S @VALMAR@(9,0)=TEMP
+        S COUNT=0,QUE=""
+        F  S QUE=$O(^HLC("QUEUECOUNT","IN",QUE)) Q:QUE=""  D
+        .S FROM=""
+        .F  S FROM=$O(^HLC("QUEUECOUNT","IN",QUE,FROM)) Q:FROM=""  D
+        ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM))
+        ..S:TEMP>0 COUNT=COUNT+TEMP
+        S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_$$RJ(+COUNT,7)
+        S TEMP="STOPPED INCOMING QUEUES: "
+        S COUNT=0,QUE=""
+        F  S QUE=$O(^HLTMP("STOPPED QUEUES","IN",QUE)) Q:QUE=""  S COUNT=COUNT+1 Q:COUNT>4  S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..."
+        S @VALMAR@(11,0)=TEMP
+        S @VALMAR@(12,0)="FILE 777 RECORD COUNT:         "_$$RJ($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^"),10)_"     --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^",2))
+        S @VALMAR@(13,0)="FILE 778 RECORD COUNT:         "_$$RJ($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^"),10)_"     --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^",2))
+        S TODAY=$$DT^XLFDT
+        S @VALMAR@(14,0)="MESSAGES SENT TODAY:           "_$$RJ($$ADD("OUT"),10)
+        S @VALMAR@(15,0)="MESSAGES RECEIVED TODAY:       "_$$RJ($$ADD("IN"),10)
+        S @VALMAR@(16,0)="MESSAGE ERRORS TODAY:          "_$$RJ($$ADD("EOUT")+$$ADD("EIN"),10)
+        Q
+ADD(DIR)        ;
+        N RAP,SAP,TIME,TOTAL
+        S TOTAL=0
+        S TIME=TODAY-.0001
+        F  S TIME=$O(^HLSTATS(DIR,"HOURLY",TIME)) Q:'TIME  Q:((TIME\1)>TODAY)  D
+        .S SAP=""
+        .F  S SAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP)) Q:SAP=""  D
+        ..Q:SAP="ACCEPT ACK"
+        ..S RAP=""
+        ..F  S RAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP)) Q:RAP=""  D
+        ...S TYPE=""
+        ...F  S TYPE=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) Q:TYPE=""  D
+        ....S TOTAL=TOTAL+$G(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE))
+        Q TOTAL
+        ;
+HELP    ;
+        S X="?" D DISP^XQORM1 W !!
+        Q
+        ;
+EXIT    ;
+        D CLEAN^VALM10
+        D CLEAR^VALM1
+        Q
+        ;
+EXPND   ;
+        Q
+        ;
+PROCS   ;
+        S HLRFRSH="PROCS^HLOUSR"
+        ;K @VALMAR
+        D CLEAN^VALM10
+        S VALMCNT=0
+        S VALMBCK="R"
+        S VALMDDF("COL 1")="COL1^1^34^"
+        S VALMDDF("COL 2")="COL 2^35^10^MIN^H"
+        S VALMDDF("COL 3")="COL 3^47^10^MAX^H"
+        S VALMDDF("COL 4")="COL 4^59^10^#RUNNING^H"
+        S VALMDDF("COL 5")="COL 5^71^10^#QUEUED^IOBON"
+        D CHGCAP^VALM("COL 1","Process Type")
+        N IEN
+        S IEN=0
+        F  S IEN=$O(^HLD(779.3,"C",1,IEN)) Q:'IEN  D
+        .N PROC
+        .Q:'$$GETPROC^HLOPROC1(IEN,.PROC)
+        .Q:PROC("NAME")="VMS TCP LISTENER"
+        .S VALMCNT=VALMCNT+1
+        .S @VALMAR@(VALMCNT,0)=$$LJ(PROC("NAME"),30)_$$RJ(PROC("MINIMUM"),6)_$$RJ(PROC("MAXIMUM"),12)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","RUNNING",PROC("NAME"))),14)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","QUEUED",PROC("NAME"))),12)
+        S VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)=""
+        S IEN=""
+        F  S IEN=$O(^HLTMP("HL7 RUNNING PROCESSES",IEN)) Q:IEN=""  D
+        .N NODE
+        .S NODE=$G(^HLTMP("HL7 RUNNING PROCESSES",IEN))
+        .Q:NODE=""
+        .S VALMCNT=VALMCNT+1
+        .S @VALMAR@(VALMCNT,0)="$J: "_$$LJ(IEN,9)_" ->"_$$CJ($P(NODE,"^",3),28)_"<- started at "_$$HTE^XLFDT($P(NODE,"^"))
+        Q
+        ;
+OUTQUEUE        ;
+        N LINK
+        D CLEAN^VALM10
+        ;K @VALMAR
+        S HLRFRSH="OUTQUEUE^HLOUSR"
+        S (HLSCREEN,VALMSG)="Outgoing Queues *down links !stopped queues"
+        S VALMCNT=0
+        S VALMBCK="R"
+        S VALMDDF("COL 1")="COL 1^2^20^ Link^H"
+        S VALMDDF("COL 2")="COL 2^28^20^Queue^H"
+        S VALMDDF("COL 3")="COL 3^50^20^Count^H"
+        K VALMDDF("COL 4"),VALMDDF("COL 5")
+        D CHGCAP^VALM("COL 1"," Link")
+        S LINK=""
+        F  S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK=""  D
+        .N COUNT,QUE,SHOW
+        .S SHOW=LINK
+        .I $D(^HLTMP("FAILING LINKS",SHOW)) S SHOW="*"_SHOW
+        .S QUE=""
+        .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  D
+        ..S COUNT=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
+        ..Q:COUNT<1
+        ..S VALMCNT=VALMCNT+1
+        ..I $E(SHOW)="*" D
+        ...S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_"   "_$$RJ(COUNT,10),SHOW=""
+        ...D CNTRL^VALM10(VALMCNT,1,1,IOBON,IOBOFF)
+        ..E  S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_"   "_$$RJ(COUNT,10),SHOW=""
+        Q
+        ;
+INQUEUE ;
+        N FROM
+        D CLEAN^VALM10
+        ;K @VALMAR
+        S HLRFRSH="INQUEUE^HLOUSR"
+        S (HLSCREEN,VALMSG)="Incoming Queues ('!' = stopped queues)"
+        S VALMCNT=0
+        S VALMBCK="R"
+        S VALMDDF("COL 1")="COL 1^1^40^ From^H"
+        S VALMDDF("COL 2")="COL 2^45^20^Queue^H"
+        S VALMDDF("COL 3")="COL 3^70^10^Count^H"
+        K VALMDDF("COL 4"),VALMDDF("COL 5")
+        D CHGCAP^VALM("COL 1"," From")
+        S FROM=""
+        F  S FROM=$O(^HLC("QUEUECOUNT","IN",FROM)) Q:FROM=""  D
+        .N COUNT,QUE,SHOW
+        .S SHOW=$$LJ(FROM,40)_"  "
+        .S QUE=""
+        .F  S QUE=$O(^HLC("QUEUECOUNT","IN",FROM,QUE)) Q:QUE=""  D
+        ..S COUNT=$G(^HLC("QUEUECOUNT","IN",FROM,QUE))
+        ..Q:COUNT<0
+        ..S VALMCNT=VALMCNT+1
+        ..S @VALMAR@(VALMCNT,0)=SHOW_$$LJ($S($$STOPPED^HLOQUE("IN",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10)
+        ..S SHOW=$$LJ("",40)_"  "
+        Q
+VIEWLINK        ;
+        N C,QUIT,LINK,LINKARY,TEMP
+        S (QUIT,C,LINK)=""
+        S VALMBCK="R"
+        ;
+        ;currently HL7 (Optimized) only does TCP
+        S LINK=$$ASKLINK
+        Q:LINK=""
+        Q:'$$GETLINK^HLOTLNK(LINK,.LINKARY)
+        S LINK=LINK_":"_LINKARY("PORT")
+        W !,"Hit any key to stop...",!
+        F  D  Q:QUIT
+        .N COUNT,QUE
+        .S (COUNT,QUE)=""
+        .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) S:TEMP>0 COUNT=COUNT+TEMP
+        .W $C(13),"                             ",$C(13),"MESSAGES PENDING TRANSMISSION: ",IOBON,$$RJ(+COUNT,10),IOBOFF
+        .R *C:1 I $T S QUIT=1
+        Q
+        ;
+CJ(STRING,LEN)  ;
+        Q $$CJ^XLFSTR($E(STRING,1,LEN),LEN)
+LJ(STRING,LEN)  ;
+        Q $$LJ^XLFSTR($E(STRING,1,LEN),LEN)
+RJ(STRING,LEN)  ;
+        Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN)
+        ;
+RUNNING()       ;Process Manager running?
+        N RUNNING
+        L +^HLTMP("PROCESS MANAGER"):0
+        S RUNNING='$T
+        I 'RUNNING L -^HLTMP("PROCESS MANAGER")
+        Q RUNNING
+        ;
+TESTLINK        ;
+        N LINK,LINKNAME,OK
+        S VALMBCK="R"
+        S LINKNAME=$$ASKLINK
+        Q:LINKNAME=""
+        S OK=$$IFOPEN^HLOUSR1(LINKNAME)
+        I OK W !,LINKNAME_" IS operational..."
+        E  W !,LINKNAME_" is NOT operational..."
+        W !,"Hit any key to continue..."
+        R *C:DTIME
+        Q
+        ;
+ASKLINK()       ;
+        N DIC,TCP,X,Y,DTOUT,DUOUT
+        S DIC=870
+        S DIC(0)="AENQ"
+        S TCP=$O(^HLCS(869.1,"B","TCP",0))
+        S DIC("A")="Select a TCP link:"
+        S DIC("S")="I $P(^(0),U,3)=TCP"
+        D FULL^VALM1
+        D ^DIC
+        I +Y'=-1,'$D(DTOUT),'$D(DUOUT) Q $P(Y,"^",2)
+        Q ""
+        ;
+STOP    ;
+        I '$$ASKYESNO^HLOUSR2("Are you SURE that you want to stop sending and receiving messages","NO") S VALMBCK="" Q
+        ;
+        D STOPHL7^HLOPROC1
+        S VALMBCK="R",VALMSG="HL7 (Optimized) has been stopped...."
+        H 5
+        D @HLRFRSH
+        ;D:HLSCREEN="Brief System Status" BRIEF^HLOUSR
+        ;D:HLSCREEN="Running Processes" PROCS^HLOUSR
+        Q
+        ;
+UPDMODE ;realtime
+        Q:'$L(HLRFRSH)
+        N TOP,BOTTOM,DX,DY,IOTM,IOBM,LINE,OLD,OLDCNT
+        S OLDCNT=VALMCNT
+        W !!!!!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
+        S IOTM=20,IOBM=23 W @IOSTBM
+        S TOP=VALMBG
+        S BOTTOM=TOP+20
+        F LINE=TOP:1:BOTTOM D
+        .I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
+        .S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
+        F LINE=TOP:1:BOTTOM D
+        .S OLD(LINE)=@VALMAR@(LINE,0)
+        F LINE=17:1:BOTTOM D
+        .S DX=50,DY=22 X IOXY W !
+        .D WRITE^VALM10(LINE)
+        D  F  R *C:4 Q:$T  D
+        .D @HLRFRSH
+        .F LINE=TOP:1:BOTTOM D
+        ..I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
+        ..S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
+        .S VALMCNT=BOTTOM
+        .F LINE=TOP:1:BOTTOM IF OLD(LINE)'=@VALMAR@(LINE,0) D
+        ..S OLD(LINE)=@VALMAR@(LINE,0)
+        ..S DX=50,DY=22 X IOXY W !
+        ..D WRITE^VALM10(LINE)
+        S VALMCNT=OLDCNT
+        S VALMBCK="R"
+        Q
+HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;02/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+EN ;
+ ;
+ N HLSCREEN,TESTOPEN,HLRFRSH
+ D WAIT^DICD
+ D EN^VALM("HLO SYSTEM MONITOR")
+ Q
+ ;
+BRIEF ;Init variables and list array
+ N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST
+ S HLRFRSH="BRIEF^HLOUSR"
+ S (HLSCREEN,VALMSG)="Brief System Status"
+ S VALMCNT=8
+ ;K @VALMAR
+ D CLEAN^VALM10
+ S VALMBG=1
+ S VALMBCK="R"
+ K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5")
+ D CHGCAP^VALM("COL 1","Brief Operational Overview")
+ S @VALMAR@(1,0)="SYSTEM STATUS:             "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING")
+ S @VALMAR@(2,0)="PROCESS MANAGER:           "_$S($$RUNNING:"RUNNING",1:"STOPPED")
+ ;
+ S TIME=$P($G(TESTOPEN("LISTENER")),"^",2)
+ I TIME,$$FMDIFF^XLFDT($$NOW^XLFDT,TIME,2)<300 D
+ .S STATUS=+TESTOPEN("LISTENER")
+ E  D
+ .S STATUS=0
+ .S LINK=$P($G(^HLD(779.1,1,0)),"^",10)
+ .I LINK S LINK=$P($G(^HLCS(870,LINK,0)),"^") Q:'$L(LINK)  S STATUS=$$IFOPEN^HLOUSR1(LINK)
+ .S TESTOPEN("LISTENER")=STATUS_"^"_$$NOW^XLFDT
+ ;
+ S @VALMAR@(3,0)="STANDARD LISTENER:         "_$S(STATUS:"OPERATIONAL",1:"NOT OPERATIONAL")
+ ;
+ S @VALMAR@(4,0)="TASKMAN:                   "_$S($$TM^%ZTLOAD:"RUNNING",1:"NOT RUNNING")
+ ;
+ S (LIST,LINK)=""
+ F  S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK=""  D  I $L(LIST)>60 S LIST=LIST_",..." Q
+ .N TIME,QUE,LINKARY
+ .I $$GETLINK^HLOTLNK($P(LINK,":"),.LINKARY)
+ .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME=""
+ .I '$G(LINKARY("SHUTDOWN")),TIME="" Q
+ .I '$G(LINKARY("SHUTDOWN")),($$HDIFF^XLFDT($H,TIME,2)<300) Q
+ .S LIST=LIST_$S($L(LIST):", ",1:"")_$P(LINK,":")
+ S @VALMAR@(5,0)="DOWN LINKS: "_LIST
+ S @VALMAR@(6,0)="CLIENT LINK PROCESSES:     "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","OUTGOING CLIENT LINK"))
+ S @VALMAR@(7,0)="IN-FILER PROCESSES:        "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","INCOMING QUEUES"))
+ S COUNT=0,LINK=""
+ F  S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK=""  D
+ .S QUE=""
+ .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  D
+ ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
+ ..S:TEMP>0 COUNT=COUNT+TEMP
+ S @VALMAR@(8,0)="MESSAGES PENDING TRANSMISSION:      "_+COUNT
+ S TEMP="STOPPED OUTGOING QUEUES: "
+ S COUNT=0,QUE=""
+ F  S QUE=$O(^HLTMP("STOPPED QUEUES","OUT",QUE)) Q:QUE=""  S COUNT=COUNT+1 Q:COUNT>4  S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..."
+ S @VALMAR@(9,0)=TEMP
+ S COUNT=0,QUE=""
+ F  S QUE=$O(^HLC("QUEUECOUNT","IN",QUE)) Q:QUE=""  D
+ .S FROM=""
+ .F  S FROM=$O(^HLC("QUEUECOUNT","IN",QUE,FROM)) Q:FROM=""  D
+ ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM))
+ ..S:TEMP>0 COUNT=COUNT+TEMP
+ S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS:   "_+COUNT
+ S TEMP="STOPPED INCOMING QUEUES: "
+ S COUNT=0,QUE=""
+ F  S QUE=$O(^HLTMP("STOPPED QUEUES","IN",QUE)) Q:QUE=""  S COUNT=COUNT+1 Q:COUNT>4  S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..."
+ S @VALMAR@(11,0)=TEMP
+ S @VALMAR@(12,0)="FILE 777 RECORD COUNT:         "_$$RJ($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^"),10)_"     --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^",2))
+ S @VALMAR@(13,0)="FILE 778 RECORD COUNT:         "_$$RJ($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^"),10)_"     --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^",2))
+ S TODAY=$$DT^XLFDT
+ S @VALMAR@(14,0)="MESSAGES SENT TODAY:           "_$$RJ($$ADD("OUT"),10)
+ S @VALMAR@(15,0)="MESSAGES RECEIVED TODAY:       "_$$RJ($$ADD("IN"),10)
+ S @VALMAR@(16,0)="MESSAGE ERRORS TODAY:          "_$$RJ($$ADD("EOUT")+$$ADD("EIN"),10)
+ Q
+ADD(DIR) ;
+ N RAP,SAP,TIME,TOTAL
+ S TOTAL=0
+ S TIME=TODAY-.0001
+ F  S TIME=$O(^HLSTATS(DIR,"HOURLY",TIME)) Q:'TIME  Q:((TIME\1)>TODAY)  D
+ .S SAP=""
+ .F  S SAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP)) Q:SAP=""  D
+ ..Q:SAP="ACCEPT ACK"
+ ..S RAP=""
+ ..F  S RAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP)) Q:RAP=""  D
+ ...S TYPE=""
+ ...F  S TYPE=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) Q:TYPE=""  D
+ ....S TOTAL=TOTAL+$G(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE))
+ Q TOTAL
+ ;
+HELP ;Help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+EXIT ;Exit code
+ D CLEAN^VALM10
+ D CLEAR^VALM1
+ ;
+ Q
+ ;
+EXPND ;Expand code
+ Q
+ ;
+PROCS ;
+ S HLRFRSH="PROCS^HLOUSR"
+ ;K @VALMAR
+ D CLEAN^VALM10
+ S VALMCNT=0
+ S VALMBCK="R"
+ S VALMDDF("COL 2")="COL 2^35^10^MIN^H"
+ S VALMDDF("COL 3")="COL 3^47^10^MAX^H"
+ S VALMDDF("COL 4")="COL 4^59^10^#RUNNING^H"
+ S VALMDDF("COL 5")="COL 5^71^10^#QUEUED^IOBON"
+ D CHGCAP^VALM("COL 1","Process Type")
+ N IEN
+ S IEN=0
+ F  S IEN=$O(^HLD(779.3,"C",1,IEN)) Q:'IEN  D
+ .N PROC
+ .Q:'$$GETPROC^HLOPROC1(IEN,.PROC)
+ .Q:PROC("NAME")="VMS TCP LISTENER"
+ .S VALMCNT=VALMCNT+1
+ .S @VALMAR@(VALMCNT,0)=$$LJ(PROC("NAME"),30)_$$RJ(PROC("MINIMUM"),6)_$$RJ(PROC("MAXIMUM"),12)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","RUNNING",PROC("NAME"))),14)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","QUEUED",PROC("NAME"))),12)
+ S VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)=""
+ S IEN=""
+ F  S IEN=$O(^HLTMP("HL7 RUNNING PROCESSES",IEN)) Q:IEN=""  D
+ .N NODE
+ .S NODE=$G(^HLTMP("HL7 RUNNING PROCESSES",IEN))
+ .Q:NODE=""
+ .S VALMCNT=VALMCNT+1
+ .S @VALMAR@(VALMCNT,0)="$J: "_$$LJ(IEN,9)_" ->"_$$CJ($P(NODE,"^",3),28)_"<- started at "_$$HTE^XLFDT($P(NODE,"^"))
+ Q
+ ;
+OUTQUEUE ;
+ N LINK
+ D CLEAN^VALM10
+ ;K @VALMAR
+ S HLRFRSH="OUTQUEUE^HLOUSR"
+ S (HLSCREEN,VALMSG)="Outgoing Queues *down links !stopped queues"
+ S VALMCNT=0
+ S VALMBCK="R"
+ S VALMDDF("COL 1")="COL 1^2^20^ Link^H"
+ S VALMDDF("COL 2")="COL 2^28^20^Queue^H"
+ S VALMDDF("COL 3")="COL 3^50^20^Count^H"
+ K VALMDDF("COL 4"),VALMDDF("COL 5")
+ D CHGCAP^VALM("COL 1"," Link")
+ S LINK=""
+ F  S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK=""  D
+ .N COUNT,QUE,SHOW
+ .S SHOW=LINK
+ .I $D(^HLTMP("FAILING LINKS",SHOW)) S SHOW="*"_SHOW
+ .S QUE=""
+ .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  D
+ ..S COUNT=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
+ ..Q:COUNT<1
+ ..S VALMCNT=VALMCNT+1
+ ..I $E(SHOW)="*" D
+ ...S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_"   "_$$RJ(COUNT,10),SHOW=""
+ ...D CNTRL^VALM10(VALMCNT,1,1,IOBON,IOBOFF)
+ ..E  S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_"   "_$$RJ(COUNT,10),SHOW=""
+ Q
+ ;
+INQUEUE ;
+ N FROM
+ D CLEAN^VALM10
+ ;K @VALMAR
+ S HLRFRSH="INQUEUE^HLOUSR"
+ S (HLSCREEN,VALMSG)="Incoming Queues ('!' = stopped queues)"
+ S VALMCNT=0
+ S VALMBCK="R"
+ S VALMDDF("COL 1")="COL 1^1^40^ From^H"
+ S VALMDDF("COL 2")="COL 2^45^20^Queue^H"
+ S VALMDDF("COL 3")="COL 3^70^10^Count^H"
+ K VALMDDF("COL 4"),VALMDDF("COL 5")
+ D CHGCAP^VALM("COL 1"," From")
+ S FROM=""
+ F  S FROM=$O(^HLC("QUEUECOUNT","IN",FROM)) Q:FROM=""  D
+ .N COUNT,QUE,SHOW
+ .S SHOW=$$LJ(FROM,40)_"  "
+ .S QUE=""
+ .F  S QUE=$O(^HLC("QUEUECOUNT","IN",FROM,QUE)) Q:QUE=""  D
+ ..S COUNT=$G(^HLC("QUEUECOUNT","IN",FROM,QUE))
+ ..Q:COUNT<0
+ ..S VALMCNT=VALMCNT+1
+ ..S @VALMAR@(VALMCNT,0)=SHOW_$$LJ($S($$STOPPED^HLOQUE("IN",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10)
+ ..S SHOW=$$LJ("",40)_"  "
+ Q
+VIEWLINK ;
+ N C,QUIT,LINK,LINKARY,TEMP
+ S (QUIT,C,LINK)=""
+ S VALMBCK="R"
+ ;
+ ;currently HL7 (Optimized) only does TCP, when serial added a change is needed here
+ S LINK=$$ASKLINK
+ Q:LINK=""
+ Q:'$$GETLINK^HLOTLNK(LINK,.LINKARY)
+ S LINK=LINK_":"_LINKARY("PORT")
+ W !,"Hit any key to stop...",!
+ F  D  Q:QUIT
+ .N COUNT,QUE
+ .S (COUNT,QUE)=""
+ .F  S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE=""  S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) S:TEMP>0 COUNT=COUNT+TEMP
+ .W $C(13),"                             ",$C(13),"MESSAGES PENDING TRANSMISSION: ",IOBON,$$RJ(+COUNT,10),IOBOFF
+ .R *C:1 I $T S QUIT=1
+ Q
+ ;
+CJ(STRING,LEN) ;
+ Q $$CJ^XLFSTR($E(STRING,1,LEN),LEN)
+LJ(STRING,LEN) ;
+ Q $$LJ^XLFSTR($E(STRING,1,LEN),LEN)
+RJ(STRING,LEN) ;
+ Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN)
+ ;
+RUNNING() ;Is the Process Manager running?
+ N RUNNING
+ L +^HLTMP("PROCESS MANAGER"):0
+ S RUNNING='$T
+ I 'RUNNING L -^HLTMP("PROCESS MANAGER")
+ Q RUNNING
+ ;
+TESTLINK ;
+ N LINK,LINKNAME,OK
+ S VALMBCK="R"
+ S LINKNAME=$$ASKLINK
+ Q:LINKNAME=""
+ S OK=$$IFOPEN^HLOUSR1(LINKNAME)
+ I OK W !,LINKNAME_" IS operational..."
+ E  W !,LINKNAME_" is NOT operational..."
+ W !,"Hit any key to continue..."
+ R *C:DTIME
+ Q
+ ;
+ASKLINK() ;
+ N DIC,TCP,X,Y,DTOUT,DUOUT
+ S DIC=870
+ S DIC(0)="AENQ"
+ S TCP=$O(^HLCS(869.1,"B","TCP",0))
+ S DIC("A")="Select a TCP link:"
+ S DIC("S")="I $P(^(0),U,3)=TCP"
+ D FULL^VALM1
+ D ^DIC
+ I +Y'=-1,'$D(DTOUT),'$D(DUOUT) Q $P(Y,"^",2)
+ Q ""
+ ;
+STOP ;
+ I '$$ASKYESNO^HLOUSR2("Are you SURE that you want to stop sending and receiving messages","NO") S VALMBCK="" Q
+ ;
+ D STOPHL7^HLOPROC1
+ S VALMBCK="R",VALMSG="HL7 (Optimized) has been stopped...."
+ H 5
+ D @HLRFRSH
+ ;D:HLSCREEN="Brief System Status" BRIEF^HLOUSR
+ ;D:HLSCREEN="Running Processes" PROCS^HLOUSR
+ Q
+ ;
+UPDMODE ;update mode
+ Q:'$L(HLRFRSH)
+ N QUIT,NEW,TOP,BOTTOM,DX,DY,IOTM,IOBM,I
+ W !!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
+ S IOTM=3,IOBM=23
+ W @IOSTBM
+ S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY
+ I VALMCNT>16 F I=17:1:$S(VALMCNT<22:VALMCNT,1:21) W !,@VALMAR@(I,0)
+ S QUIT=0
+ S TOP=VALMBG
+ S BOTTOM=TOP+23
+ S OLD=VALMAR
+ S VALMAR="NEW"
+ S VALMCNT=0
+ F  D  Q:QUIT
+ .N LINE
+ .R *C:3 I $T S QUIT=1
+ .S (VALMCNT,I)=0
+ .D @HLRFRSH
+ .F LINE=TOP:1:BOTTOM IF $G(@OLD@(LINE,0))'=$G(@VALMAR@(LINE,0)) D
+ ..S:'$D(@VALMAR@(LINE,0)) @VALMAR@(LINE,0)=" "
+ ..D WRITE^VALM10(LINE)
+ K @OLD M @OLD=@VALMAR S VALMAR=OLD
+ S VALMBCK="R"
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m

-              r613
+              r623
+HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;07/25/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+EN      ;
+        N MSGIEN
+        S MSGIEN=$$PICKMSG
+        I 'MSGIEN S VALMBCK="R" Q
+        D EN^VALM("HLO SINGLE MESSAGE DISPLAY")
+        Q
+        ;
+HDR     ;
+        Q
+        ;
+BLANK   ;
+        S VALMCNT=0
+        D EXIT
+        Q
+DISPLAY ;
+        K @VALMAR
+        S VALMBCK="R"
+        N MSG
+        S VALMBG=1
+        Q:'MSGIEN
+        D SHOWMSG($P(MSGIEN,"^"),$P(MSGIEN,"^",2))
+        Q
+        ;
+PICKMSG()       ;
+        ;ask the user to select a message & return its ien
+        N MSGIEN,DIR,COUNT,LIST
+        D FULL^VALM1
+        S DIR(0)="F3:30"
+        S DIR("A")="Message ID"
+        S DIR("?")="Enter the full Message Control ID or Batch Control ID of the message, or '^' to exit."
+PICK    D ^DIR
+        I $D(DIRUT)!(Y="") Q 0
+        I $G(@VALMAR@("INDEX",Y)) Q $G(@VALMAR@("INDEX",Y))
+        S COUNT=$$FINDMSG^HLOMSG1(Y,.LIST)
+        I COUNT="0" W !!,"That message can not be found! Try Again",! G PICK
+        I COUNT=1 Q LIST(1)
+        I COUNT>1 D
+        .N ITEM
+        .W !,"There is more than one message with that ID! You must choose one to display.",1
+        .S ITEM=0
+        .F  S ITEM=$O(LIST(ITEM)) Q:'ITEM  D
+        ..N MSG
+        ..Q:'$$GETMSG^HLOMSG(+LIST(ITEM),.MSG)
+        ..W !,"[",ITEM,"]","  DT/TM: ",$$FMTE^XLFDT(MSG("DT/TM CREATED"),2),"   STATUS: ",MSG("STATUS")
+        .S DIR(0)="NO^1:"_COUNT,DIR("A")="Choose",DIR("?")="Choose one message from the list"
+        .D ^DIR
+        .I Y S Y=LIST(Y)
+        Q Y
+        ;
+HELP    ;Help code
+        S X="?" D DISP^XQORM1 W !!
+        Q
+        ;
+EXIT    ;Exit code
+        D CLEAN^VALM10
+        D CLEAR^VALM1
+        S VALMBCK="R"
+        ;
+        Q
+        ;
+EXPND   ;Expand code
+        Q
+        ;
+CJ(STRING,LEN)  ;
+        Q $$CJ^XLFSTR(STRING,LEN)
+LJ(STRING,LEN)  ;
+        Q $$LJ^XLFSTR(STRING,LEN)
+SP(LEN,CHAR)    ;
+        ;return padding - " " is the default pad character
+        N STR
+        S:$G(CHAR)="" CHAR=" "
+        S $P(STR,CHAR,LEN)=CHAR
+        Q STR
+        ;
+SHOWMSG(MSGIEN,SUBIEN)  ;
+        ;Description:
+        ;
+        ;Input:
+        ;Output:
+        ;
+        N MSG,I,TEMP,LINE
+        S VALMCNT=0
+        S SUBIEN=+$G(SUBIEN)
+        I '$$GETMSG^HLOMSG(MSGIEN,.MSG) W !,"UNABLE TO DISPLAY THE MESSAGE",!! Q
+        I SUBIEN D GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+        ;
+        S I=0
+        ;** administrative information **
+        S @VALMAR@($$I,0)=$$CJ("Administrative Information",80)
+        D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+        S LINE="MsgID: "_$$LJ(MSG("ID"),18)
+        S LINE=LINE_"Status: "_$$LJ(MSG("STATUS"),5)
+        S:MSG("ACK TO")]"" LINE=LINE_$$LJ(" Ack To:",14)_MSG("ACK TO")
+        S:MSG("ACK BY")]"" LINE=LINE_$$LJ(" Ack'd By:",14)_MSG("ACK BY")
+        S @VALMAR@($$I,0)=LINE
+        I MSG("STATUS","ERROR TEXT")]"" S @VALMAR@($$I,0)="Error: "_"** "_MSG("STATUS","ERROR TEXT")_" **"
+        S @VALMAR@($$I,0)="Dir:   "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ("  Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ("  Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2)
+        S @VALMAR@($$I,0)="Link:  "_$$LJ(MSG("STATUS","LINK NAME"),29)_"   "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE")
+        I $L($G(MSG("STATUS","SEQUENCE QUEUE"))) D
+        .S @VALMAR@($$I,0)="Sequence Queue: "_MSG("STATUS","SEQUENCE QUEUE")_"    Moved: "_$S(MSG("STATUS","MOVED TO OUT QUEUE"):"YES",1:"NO")
+        I MSG("STATUS","ACCEPT ACK'D") D
+        .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" DT/TM Ack'd: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
+        .S @VALMAR@($$I,0)="   "_MSG("STATUS","ACCEPT ACK MSA")
+        I MSG("DIRECTION")="IN" D
+        .S LINE="App Response Rtn: "
+        .I $L($G(MSG("STATUS","APP ACK RESPONSE"))) S LINE=$$LJ(LINE_MSG("STATUS","APP ACK RESPONSE"),38)_" Executed: "_$S(MSG("STATUS","APP HANDOFF"):"   YES",1:"   NO")
+        .S @VALMAR@($$I,0)=LINE
+        I MSG("DIRECTION")="OUT",(MSG("STATUS","APP ACK'D")!MSG("STATUS","ACCEPT ACK'D")) D
+        .S LINE=""
+        .I MSG("STATUS","ACCEPT ACK'D") D
+        ..I MSG("STATUS","ACCEPT ACK RESPONSE")="" S MSG("STATUS","ACCEPT ACK RESPONSE")="n/a"
+        ..S LINE="Accept Ack Rtn: "_MSG("STATUS","ACCEPT ACK RESPONSE")
+        .S LINE=$$LJ(LINE,39)
+        .I MSG("STATUS","APP ACK'D") D
+        ..I MSG("STATUS","APP ACK RESPONSE")="" S MSG("STATUS","APP ACK RESPONSE")="n/a"
+        ..S LINE=LINE_"App Ack Rtn: "_MSG("STATUS","APP ACK RESPONSE")
+        .S @VALMAR@($$I,0)=LINE
+        ;
+        ;** the message text **
+        S @VALMAR@($$I,0)=""
+        I '$G(SUBIEN) D
+        .S @VALMAR@($$I,0)=$$CJ("Message Text",80)
+        .D CNTRL^VALM10(VALMCNT,33,16,IORVON,IORVOFF)
+        E  D
+        .S @VALMAR@($$I,0)=$$CJ("Individual Message Text (Batched)",80)
+        .D CNTRL^VALM10(VALMCNT,23,35,IORVON,IORVOFF)
+        D SHOWBODY(.MSG,$G(SUBIEN))
+        ;
+        ;** display its application acknowledgment **
+        I MSG("ACK BY")]"",$$FINDMSG^HLOMSG1(MSG("ACK BY"),.TEMP)=1 S MSGIEN=TEMP(1) D
+        .N MSG
+        .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG)
+        .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG)
+        .S @VALMAR@($$I,0)=""
+        .S @VALMAR@($$I,0)=$$CJ("Application Acknowledgment",80)
+        .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+        .D SHOWBODY(.MSG,$P(MSGIEN,"^",2))
+        ;
+        ;** display the original message **
+        I MSG("ACK TO")]"",$$FINDMSG^HLOMSG1(MSG("ACK TO"),.TEMP)=1 S MSGIEN=TEMP(1) D
+        .N MSG
+        .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG)
+        .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG)
+        .S @VALMAR@($$I,0)=""
+        .S @VALMAR@($$I,0)=$$CJ("Original Message",80)
+        .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+        .D SHOWBODY(.MSG,$P(MSGIEN,"^",2))
+        Q
+        ;
+SHOWBODY(MSG,SUBIEN)    ;
+        N NODE,I,SEG,QUIT
+        S QUIT=0
+        M SEG=MSG("HDR")
+        D ADD(.SEG)
+        S MSG("BATCH","CURRENT MESSAGE")=0
+        I MSG("BATCH") D
+        .I $G(SUBIEN) D  Q
+        ..S MSG("BATCH","CURRENT MESSAGE")=SUBIEN
+        ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D ADD(.SEG)
+        .S MSG("BATCH","CURRENT MESSAGE")=0
+        .N LAST S LAST=0
+        .F  Q:'$$NEXTMSG^HLOMSG(.MSG,.SEG)  D  Q:QUIT
+        ..D ADD(.SEG)
+        ..S LAST=MSG("BATCH","CURRENT MESSAGE")
+        ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D ADD(.SEG)
+        .I MSG("DIRECTION")="OUT" K SEG S SEG(1)="BTS"_$E($G(NODE(1)),4)_LAST D ADD(.SEG)
+        E  D
+        .F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D  Q:QUIT
+        ..D ADD(.SEG)
+        Q
+I()     ;
+        S VALMCNT=VALMCNT+1
+        Q VALMCNT
+ADD(SEG)        ;
+        N QUIT,I,J,LINE
+        S QUIT=0
+        S (I,J)=1
+        S LINE(1)=$E(SEG(1),1,80),SEG(1)=$E(SEG(1),81,9999)
+        I SEG(1)="" K SEG(1)
+        D SHIFT(.I,.J)
+        S @VALMAR@($$I,0)=LINE(1)
+        S I=1
+        F  S I=$O(LINE(I)) Q:'I  D
+        .S @VALMAR@($$I,0)=LINE(I)
+        .D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF)
+        Q
+        ;
+SHIFT(I,J)      ;
+        I '$D(SEG(I)) S I=$O(SEG(0)) Q:'I
+        I $L(LINE(J))<80 D
+        .N LEN
+        .S LEN=$L(LINE(J))
+        .S LINE(J)=LINE(J)_$E(SEG(I),1,80-LEN)
+        .S SEG(I)=$E(SEG(I),81-LEN,9999)
+        .I SEG(I)="" K SEG(I)
+        E  D
+        .S J=J+1
+        .S LINE(J)="-"
+        D SHIFT(.I,.J)
+        Q
+        ;
+SCRLMODE        ;scroll mode
+        Q:'$L(HLRFRSH)
+        N QUIT,IOTM,IOBM,DX,DY,LINE,IOTM,IOBM
+        W !!,IOINHI,"Hit any key to escape scroll mode...",IOINORM
+        S IOTM=3,IOBM=23
+        S QUIT=0
+        S LINE=$S(VALMCNT<17:1,1:17)
+        W @IOSTBM
+        S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY
+        F I=1:1 D  Q:QUIT
+        .;every 10 seconds refresh the data
+        .I I>42 D @HLRFRSH S I=0
+        .I LINE+1>VALMCNT D
+        ..S TEMP=$G(@VALMAR@(LINE,0))
+        ..W !,IOUON,TEMP_$$SP(80-$L(TEMP)),IOUOFF
+        .E  W !,$G(@VALMAR@(LINE,0))
+        .S LINE=LINE+1
+        .I LINE>VALMCNT S LINE=1
+        .I (I=22)!(I=43) R *C:5 I $T S QUIT=1 Q
+        S VALMBG=LINE-23 I VALMBG<0 S VALMBG=1
+        S VALMBCK="R"
+        Q
+HLP     ;
+        Q
+        ;
+IFOPEN(LINK)    ;
+        ;returns 1 if the link can be opened, otherwise 0
+        ;
+        ;Inputs:
+        ;  LINK - name of the link (required), optionally post-fixed with ":"_<port #>, will default to that defined for link
+        ;
+        N LINKNAME,LINKARY,POP,IO,IOF,IOST,OPEN,PORT
+        S OPEN=0
+        S LINKNAME=$P(LINK,":")
+        S PORT=$P(LINK,":",2)
+        Q:LINKNAME="" 0
+        Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINKARY) 0
+        S:PORT LINKARY("PORT")=PORT
+        Q:'$G(LINKARY("PORT")) 0
+        I LINKARY("IP")="",LINKARY("DOMAIN")="",LINKARY("LLP")="TCP",LINKARY("SERVER") D
+        .N DATA
+        .S LINKARY("DOMAIN")=$P($G(^HLD(779.1,1,0)),"^")
+        .Q:LINKARY("DOMAIN")=""
+        .S DATA(.08)=LINKARY("DOMAIN")
+        .Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA)
+        D:$G(LINKARY("IP"))'=""
+        .D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15)
+        .S OPEN='POP
+        I 'OPEN,LINKARY("DOMAIN")'="",$G(^HLTMP("DNS LAST",LINKARY("IEN")))<$$DT^XLFDT D
+        .N IP
+        .S ^HLTMP("DNS LAST",LINKARY("IEN"))=$$DT^XLFDT
+        .S IP=$$DNS^HLOTCP(LINKARY("DOMAIN"))
+        .I IP'="",IP'=LINKARY("IP") D
+        ..N DATA
+        ..S DATA(400.01)=IP,LINKARY("IP")=IP
+        ..Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA)
+        ..D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15)
+        ..S OPEN='POP
+        C:OPEN IO
+        ;D CLOSE^%ZISTCP
+        Q OPEN
+HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+EN ;
+ N MSGIEN
+ S MSGIEN=$$PICKMSG
+ I 'MSGIEN S VALMBCK="R" Q
+ D EN^VALM("HLO SINGLE MESSAGE DISPLAY")
+ Q
+ ;
+HDR ;
+ Q
+ ;
+BLANK ;
+ S VALMCNT=0
+ D EXIT
+ Q
+DISPLAY ;
+ K @VALMAR
+ S VALMBCK="R"
+ N MSG
+ S VALMBG=1
+ Q:'MSGIEN
+ D SHOWMSG($P(MSGIEN,"^"),$P(MSGIEN,"^",2))
+ Q
+ ;
+PICKMSG() ;
+ ;ask the user to select a message & return its ien
+ N MSGIEN,DIR,COUNT,LIST
+ D FULL^VALM1
+ S DIR(0)="F3:30"
+ S DIR("A")="Message ID"
+ S DIR("?")="Enter the full Message Control ID or Batch Control ID of the message, or '^' to exit."
+PICK D ^DIR
+ I $D(DIRUT)!(Y="") Q 0
+ I $G(@VALMAR@("INDEX",Y)) Q $G(@VALMAR@("INDEX",Y))
+ S COUNT=$$FINDMSG^HLOMSG1(Y,.LIST)
+ I COUNT="0" W !!,"That message can not be found! Try Again",! G PICK
+ I COUNT=1 Q LIST(1)
+ I COUNT>1 D
+ .N ITEM
+ .W !,"There is more than one message with that ID! You must choose one to display.",1
+ .S ITEM=0
+ .F  S ITEM=$O(LIST(ITEM)) Q:'ITEM  D
+ ..N MSG
+ ..Q:'$$GETMSG^HLOMSG(+LIST(ITEM),.MSG)
+ ..W !,"[",ITEM,"]","  DT/TM: ",$$FMTE^XLFDT(MSG("DT/TM CREATED"),2),"   STATUS: ",MSG("STATUS")
+ .S DIR(0)="NO^1:"_COUNT,DIR("A")="Choose",DIR("?")="Choose one message from the list"
+ .D ^DIR
+ .I Y S Y=LIST(Y)
+ Q Y
+ ;
+HELP ;Help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+EXIT ;Exit code
+ D CLEAN^VALM10
+ D CLEAR^VALM1
+ S VALMBCK="R"
+ ;
+ Q
+ ;
+EXPND ;Expand code
+ Q
+ ;
+CJ(STRING,LEN) ;
+ Q $$CJ^XLFSTR(STRING,LEN)
+LJ(STRING,LEN) ;
+ Q $$LJ^XLFSTR(STRING,LEN)
+SP(LEN,CHAR) ;
+ ;return padding - " " is the default pad character
+ N STR
+ S:$G(CHAR)="" CHAR=" "
+ S $P(STR,CHAR,LEN)=CHAR
+ Q STR
+ ;
+SHOWMSG(MSGIEN,SUBIEN) ;
+ ;Description:
+ ;
+ ;Input:
+ ;Output:
+ ;
+ N MSG,I,TEMP,LINE
+ S VALMCNT=0
+ S SUBIEN=+$G(SUBIEN)
+ I '$$GETMSG^HLOMSG(MSGIEN,.MSG) W !,"UNABLE TO DISPLAY THE MESSAGE",!! Q
+ I SUBIEN D GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+ ;
+ S I=0
+ ;** administrative information **
+ S @VALMAR@($$I,0)=$$CJ("Administrative Information",80)
+ D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+ S LINE="MsgID: "_$$LJ(MSG("ID"),18)
+ S LINE=LINE_"Status: "_$$LJ(MSG("STATUS"),5)
+ S:MSG("ACK TO")]"" LINE=LINE_$$LJ(" Ack To:",14)_MSG("ACK TO")
+ S:MSG("ACK BY")]"" LINE=LINE_$$LJ(" Ack'd By:",14)_MSG("ACK BY")
+ S @VALMAR@($$I,0)=LINE
+ I MSG("STATUS","ERROR TEXT")]"" S @VALMAR@($$I,0)="Error: "_"** "_MSG("STATUS","ERROR TEXT")_" **"
+ S @VALMAR@($$I,0)="Dir:   "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ("  Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ("  Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2)
+ S @VALMAR@($$I,0)="Link:  "_$$LJ(MSG("STATUS","LINK NAME"),29)_"   "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE")
+ I MSG("STATUS","ACCEPT ACK'D") D
+ .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" At: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
+ .S @VALMAR@($$I,0)="   "_MSG("STATUS","ACCEPT ACK MSA")
+ I MSG("DIRECTION")="IN" D
+ .S LINE="App Response Rtn: "
+ .I $L($G(MSG("STATUS","APP ACK RESPONSE"))) S LINE=$$LJ(LINE_MSG("STATUS","APP ACK RESPONSE"),38)_" Executed: "_$S(MSG("STATUS","APP HANDOFF"):"   YES",1:"   NO")
+ .S @VALMAR@($$I,0)=LINE
+ I MSG("DIRECTION")="OUT",(MSG("STATUS","APP ACK'D")!MSG("STATUS","ACCEPT ACK'D")) D
+ .S LINE=""
+ .I MSG("STATUS","ACCEPT ACK'D") D
+ ..I MSG("STATUS","ACCEPT ACK RESPONSE")="" S MSG("STATUS","ACCEPT ACK RESPONSE")="n/a"
+ ..S LINE="Accept Ack Rtn: "_MSG("STATUS","ACCEPT ACK RESPONSE")
+ .S LINE=$$LJ(LINE,39)
+ .I MSG("STATUS","APP ACK'D") D
+ ..I MSG("STATUS","APP ACK RESPONSE")="" S MSG("STATUS","APP ACK RESPONSE")="n/a"
+ ..S LINE=LINE_"App Ack Rtn: "_MSG("STATUS","APP ACK RESPONSE")
+ .S @VALMAR@($$I,0)=LINE
+ ;
+ ;** the message text **
+ S @VALMAR@($$I,0)=""
+ I '$G(SUBIEN) D
+ .S @VALMAR@($$I,0)=$$CJ("Message Text",80)
+ .D CNTRL^VALM10(VALMCNT,33,16,IORVON,IORVOFF)
+ E  D
+ .S @VALMAR@($$I,0)=$$CJ("Individual Message Text (Batched)",80)
+ .D CNTRL^VALM10(VALMCNT,23,35,IORVON,IORVOFF)
+ D SHOWBODY(.MSG,$G(SUBIEN))
+ ;
+ ;** display its application acknowledgment **
+ I MSG("ACK BY")]"",$$FINDMSG^HLOMSG1(MSG("ACK BY"),.TEMP)=1 S MSGIEN=TEMP(1) D
+ .N MSG
+ .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG)
+ .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG)
+ .S @VALMAR@($$I,0)=""
+ .S @VALMAR@($$I,0)=$$CJ("Application Acknowledgment",80)
+ .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+ .D SHOWBODY(.MSG,$P(MSGIEN,"^",2))
+ ;
+ ;** display the original message **
+ I MSG("ACK TO")]"",$$FINDMSG^HLOMSG1(MSG("ACK TO"),.TEMP)=1 S MSGIEN=TEMP(1) D
+ .N MSG
+ .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG)
+ .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG)
+ .S @VALMAR@($$I,0)=""
+ .S @VALMAR@($$I,0)=$$CJ("Original Message",80)
+ .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF)
+ .D SHOWBODY(.MSG,$P(MSGIEN,"^",2))
+ Q
+ ;
+SHOWBODY(MSG,SUBIEN) ;
+ N NODE,I,SEG,QUIT
+ S QUIT=0
+ M SEG=MSG("HDR")
+ D ADD(.SEG)
+ S MSG("BATCH","CURRENT MESSAGE")=0
+ I MSG("BATCH") D
+ .I $G(SUBIEN) D  Q
+ ..S MSG("BATCH","CURRENT MESSAGE")=SUBIEN
+ ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D ADD(.SEG)
+ .S MSG("BATCH","CURRENT MESSAGE")=0
+ .N LAST S LAST=0
+ .F  Q:'$$NEXTMSG^HLOMSG(.MSG,.SEG)  D  Q:QUIT
+ ..D ADD(.SEG)
+ ..S LAST=MSG("BATCH","CURRENT MESSAGE")
+ ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D ADD(.SEG)
+ .I MSG("DIRECTION")="OUT" K SEG S SEG(1)="BTS"_$E($G(NODE(1)),4)_LAST D ADD(.SEG)
+ E  D
+ .F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  D  Q:QUIT
+ ..D ADD(.SEG)
+ Q
+I() ;
+ S VALMCNT=VALMCNT+1
+ Q VALMCNT
+ADD(SEG) ;
+ N QUIT,I,J,LINE
+ S QUIT=0
+ S (I,J)=1
+ S LINE(1)=$E(SEG(1),1,80),SEG(1)=$E(SEG(1),81,9999)
+ I SEG(1)="" K SEG(1)
+ D SHIFT(.I,.J)
+ S @VALMAR@($$I,0)=LINE(1)
+ S I=1
+ F  S I=$O(LINE(I)) Q:'I  D
+ .S @VALMAR@($$I,0)=LINE(I)
+ .D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF)
+ Q
+ ;
+SHIFT(I,J) ;
+ I '$D(SEG(I)) S I=$O(SEG(0)) Q:'I
+ I $L(LINE(J))<80 D
+ .N LEN
+ .S LEN=$L(LINE(J))
+ .S LINE(J)=LINE(J)_$E(SEG(I),1,80-LEN)
+ .S SEG(I)=$E(SEG(I),81-LEN,9999)
+ .I SEG(I)="" K SEG(I)
+ E  D
+ .S J=J+1
+ .S LINE(J)="-"
+ D SHIFT(.I,.J)
+ Q
+ ;
+SCRLMODE ;scroll mode
+ Q:'$L(HLRFRSH)
+ N QUIT,IOTM,IOBM,DX,DY,LINE,IOTM,IOBM
+ W !!,IOINHI,"Hit any key to escape scroll mode...",IOINORM
+ S IOTM=3,IOBM=23
+ S QUIT=0
+ S LINE=$S(VALMCNT<17:1,1:17)
+ W @IOSTBM
+ S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY
+ F I=1:1 D  Q:QUIT
+ .;every 10 seconds refresh the data
+ .I I>42 D @HLRFRSH S I=0
+ .I LINE+1>VALMCNT D
+ ..S TEMP=$G(@VALMAR@(LINE,0))
+ ..W !,IOUON,TEMP_$$SP(80-$L(TEMP)),IOUOFF
+ .E  W !,$G(@VALMAR@(LINE,0))
+ .S LINE=LINE+1
+ .I LINE>VALMCNT S LINE=1
+ .I (I=22)!(I=43) R *C:5 I $T S QUIT=1 Q
+ S VALMBG=LINE-23 I VALMBG<0 S VALMBG=1
+ S VALMBCK="R"
+ Q
+HLP ;
+ Q
+ ;
+IFOPEN(LINK) ;
+ ;returns 1 if the link can be opened, otherwise 0
+ ;
+ ;Inputs:
+ ;  LINK - name of the link (required), optionally post-fixed with ":"_<port #>, will default to that defined for link
+ ;
+ N LINKNAME,LINKARY,POP,IO,IOF,IOST,OPEN,PORT
+ S OPEN=0
+ S LINKNAME=$P(LINK,":")
+ S PORT=$P(LINK,":",2)
+ Q:LINKNAME="" 0
+ Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINKARY) 0
+ S:PORT LINKARY("PORT")=PORT
+ Q:'$G(LINKARY("PORT")) 0
+ I LINKARY("IP")="",LINKARY("DOMAIN")="",LINKARY("LLP")="TCP",LINKARY("SERVER") D
+ .N DATA
+ .S LINKARY("DOMAIN")=$P($G(^HLD(779.1,1,0)),"^")
+ .Q:LINKARY("DOMAIN")=""
+ .S DATA(.08)=LINKARY("DOMAIN")
+ .Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA)
+ D:$G(LINKARY("IP"))'=""
+ .D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15)
+ .S OPEN='POP
+ I 'OPEN,LINKARY("DOMAIN")'="",$G(^HLTMP("DNS LAST",LINKARY("IEN")))<$$DT^XLFDT D
+ .N IP
+ .S ^HLTMP("DNS LAST",LINKARY("IEN"))=$$DT^XLFDT
+ .S IP=$$DNS^HLOTCP(LINKARY("DOMAIN"))
+ .I IP'="",IP'=LINKARY("IP") D
+ ..N DATA
+ ..S DATA(400.01)=IP,LINKARY("IP")=IP
+ ..Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA)
+ ..D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15)
+ ..S OPEN='POP
+ C:OPEN IO
+ ;D CLOSE^%ZISTCP
+ Q OPEN

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m

-              r613
+              r623
+HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;07/17/2007
+        ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+        ;Per VHA Directive 2004-038, this routine should not be modified
+        ;
+EN      ;
+        D WAIT^DICD
+        D EN^VALM("HLO MESSAGE VIEWER")
+        Q
+        ;
+SHOWLIST        ;
+        N PARMS,I,ERRCOUNT
+        S (VALMBG,VALMCNT,I,ERRCOUNT)=0
+        D CLEAN^VALM10
+        S VALMBG=1
+        I '$$ASKPARMS(.PARMS) S VALMBCK="" Q
+        I PARMS("ALL") D
+        .N APP
+        .S APP=""
+        .F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
+        ..N TIME,IEN
+        ..S TIME=PARMS("START")
+        ..Q:($O(^HLB("ERRORS",APP,TIME))="")
+        ..S @VALMAR@($$I,0)="Application: "_APP
+        ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
+        ..F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+        E  D
+        .N APP
+        .S APP=PARMS("APP")
+        .N TIME,IEN
+        .S TIME=PARMS("START")
+        .Q:$O(^HLB("ERRORS",APP,TIME))=""
+        .S @VALMAR@($$I,0)="Application: "_APP
+        .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
+        .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+        ;
+SHOW    S VALMBCK="R"
+        ;
+        Q
+ADDTO(IEN,TIME,ERRCOUNT)        ;
+        N NODE,MSG
+        Q:'$$GETMSG^HLOMSG(+IEN,.MSG)
+        S ERRCOUNT=ERRCOUNT+1
+        ;application errors could be an error to a msg within a batch
+        ;also, need to go to the ack msg to get the error text from the MSA segment
+        ;
+        N SUBIEN,MSA,ERRTEXT
+        S (ERRTEXT,MSA)=""
+        S SUBIEN=$P(IEN,"^",2)
+        ;within batch?
+        D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+        S ERRTEXT=MSG("STATUS","ERROR TEXT")
+        I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
+        .N MSG,SEG,FS,AIEN
+        .S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
+        .Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
+        .I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
+        .F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
+        I ERRTEXT="",MSG("ACK BY")="" D
+        .N FS
+        .S FS=$E(MSG("HDR",1),4)
+        .I $L(FS) S ERRTEXT=$P($G(MSG("STATUS","ACCEPT ACK MSA")),FS,4)
+        S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,35)
+        D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+        I $L(ERRTEXT)>35 D
+        .S @VALMAR@($$I,0)=$$RJ(" ",45)_$E(ERRTEXT,36,115)
+        S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+        Q
+        ;
+ASKPARMS(PARMS) ;
+        K PARMS
+        S PARMS("START")=$$ASKBEGIN("T-1")
+        I 'PARMS("START") Q 0
+        S PARMS("MAX")=$$ASKMAX()
+        Q:'(PARMS("MAX")>-1) 0
+        S PARMS("ALL")=$$ASKYESNO("Include ALL applications","YES")
+        I PARMS("ALL") Q 1
+        I PARMS("ALL")="" Q 0
+        S PARMS("APP")=$$ASKAPP
+        I PARMS("APP")="" Q 0
+        Q 1
+        ;
+ASKMAX()               ;
+        N DIR
+        S DIR(0)="N^1:30000:0"
+        S DIR("A")="Maximum List Size"
+        S DIR("B")=1000
+        S DIR("?",1)="In case a large number of errors meet your search criteria, what are the"
+        S DIR("?")="maximum number of errors to display? (30,000 maximum)"
+        D ^DIR
+        Q:$D(DTOUT)!$D(DUOUT) -1
+        Q X-1
+ASKAPP()        ;
+        D FULL^VALM1
+        S VALMBCK="R"
+        N DIR
+        S DIR(0)="F^3:60"
+        S DIR("A")="Receiving Application"
+        S DIR("?")="Enter the full name of the application, or '^' to exit."
+        D ^DIR
+        I $D(DIRUT)!(Y="") Q ""
+        Q Y
+        ;
+ASKYESNO(PROMPT,DEFAULT)        ;
+        ;Description: Displays PROMPT, appending '?'.  Expects a YES NO response
+        ;Input:
+        ;   PROMPT - text to display as prompt.  Appends '?'
+        ;   DEFAULT - (optional) YES or NO.  If not passed, defaults to YES
+        ;Output:
+        ;  Function value: 1 if yes, 0 if no, "" if '^' entered or timeout
+        ;
+        N DIR,Y
+        S DIR(0)="Y"
+        S DIR("A")=PROMPT
+        S DIR("B")=$S($G(DEFAULT)="NO":"NO",1:"YES")
+        D ^DIR
+        Q:$D(DIRUT) ""
+        Q Y
+        ;
+STRTSTPQ        ;
+        ;action to start or stop a queue, either incoming or outgoing
+        ;
+        N STOP,INOROUT,QUE
+        S VALMBCK="R"
+        D FULL^VALM1
+        ;ask if stop or start
+        D  Q:STOP=""
+        .N DIR
+        .S DIR(0)="S^1:START;2:STOP"
+        .S DIR("A")="Do you want to START or STOP a queue"
+        .S DIR("B")="1"
+        .D ^DIR
+        .S STOP=$S(Y=1:0,Y=2:1,1:"")
+        ;ask if in or out
+        D  Q:INOROUT=""
+        .N DIR
+        .S DIR(0)="S^I:INCOMING;O:OUTGOING"
+        .S DIR("A")="Do you want to "_$S(STOP:"stop",1:"start")_" an incoming queue or an outgoing queue"
+        .S DIR("B")="I"
+        .D ^DIR
+        .S INOROUT=$S(Y="I":"IN",Y="O":"OUT",1:"")
+        S QUE=$$ASKQUE(INOROUT)
+        Q:QUE=""
+        I STOP=$$STOPPED^HLOQUE(INOROUT,QUE) D
+        .N C
+        .I STOP D
+        ..W !,"That queue is already stopped!"
+        .E  W !,"That queue is not stopped!"
+        .W !,IOINHI,"Hit any key to continue...",IOINORM
+        .R *C:DTIME
+        E  D
+        .N C
+        .D:STOP STOPQUE^HLOQUE(INOROUT,QUE)
+        .D:'STOP STARTQUE^HLOQUE(INOROUT,QUE)
+        .W !,"DONE!"
+        .W !,IOINHI,"Hit any key to continue...",IOINORM
+        .R *C:DTIME
+        .D @HLRFRSH
+        Q
+        ;
+ASKQUE(DIR)     ;
+        N QUEUE
+AGAIN   W !,"Enter the full, exact name of queue:"
+        S QUEUE=""
+        R QUEUE:60 I '$T Q ""
+        I $E(QUEUE)="?" W !,"Each message is placed on a queue that has an arbitrary name up to 20",!,"characters long." I $$ASKYESNO("Would you like to see a list of the queues that currently exist","NO") D  G AGAIN
+        .N SUB,QUE,QUIT,COUNT
+        .K ^TMP($J,"HLO QUEUES")
+        .S SUB=""
+        .F  S SUB=$O(^HLB("QUEUE",DIR,SUB)) Q:SUB=""  D
+        ..S QUE=""
+        ..F  S QUE=$O(^HLB("QUEUE",DIR,SUB,QUE)) Q:QUE=""  S ^TMP($J,"HLO QUEUES",QUE)=""
+        .S QUE=""
+        .S IOSL=$G(IOSL,20)
+        .S (COUNT,QUIT)=0
+        .W !
+        .F  S QUE=$O(^TMP($J,"HLO QUEUES",QUE)) Q:QUE=""  Q:QUIT  D
+        ..W !,QUE
+        ..S COUNT=COUNT+1
+        ..I COUNT>(IOSL-3) D
+        ...N Y
+        ...D PAUSE^VALM1
+        ...I 'Y S QUIT=1
+        ...S COUNT=0
+        .W !
+        .K ^TMP($J,"HLO QUEUES")
+        Q:$E(QUEUE)="?" ""
+        Q:$E(QUEUE)="^" ""
+        Q QUEUE
+        ;
+ASKBEGIN(DEFAULT)       ;
+        ;Description: Asks the user to enter a beginning date.
+        ;Input: DEFAULT - the suggested default dt/time (optional)
+        ;Output: Returns the date as the function value, or 0 if the user does not select a date
+        ;
+        ;
+        N %DT
+        S %DT="AEST"
+        S %DT("A")="Enter the beginning date/time: "
+        S %DT("B")=$$FMTE^XLFDT($S($L($G(DEFAULT)):DEFAULT,1:$$FMADD^XLFDT(DT,-1)))
+        S %DT(0)="-NOW"
+        Q:$D(DTOUT) 0
+        D ^%DT
+        I Y=-1 Q 0
+        Q Y
+        ;
+ASKEND(BEGIN)   ;
+        ;Description: Asks the user to enter an ending date/time
+        ;Input: BEGIN - the earliest date/time allowed
+        ;Output: Returns the date as the function value, or 0 if the user does not select a date/time
+        ;
+        N %DT
+        S %DT="AEST"
+        S %DT("A")="Enter the ending date/time: "
+        S %DT("B")="NOW"
+        S %DT(0)=BEGIN
+        Q:$D(DTOUT) 0
+        D ^%DT
+        I Y=-1 Q 0
+        Q Y
+        ;
+LJ(STRING,LEN)  ;
+        Q $$LJ^XLFSTR(STRING,LEN)
+RJ(STRING,LEN)  ;
+        Q $$RJ^XLFSTR(STRING,LEN)
+        ;
+I()     ;
+        S VALMCNT=VALMCNT+1
+        Q VALMCNT
+        ;
+HEADER  ;
+        Q
+HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
+ ;Per VHA Directive 2004-038, this routine should not be modified
+ ;
+EN ;
+ D WAIT^DICD
+ D EN^VALM("HLO MESSAGE VIEWER")
+ Q
+ ;
+SHOWLIST(TYPE) ;
+ ;TYPE= "SE", "AE", "TF"
+ N PARMS,I,ERRCOUNT
+ S (VALMBG,VALMCNT,I,ERRCOUNT)=0
+ D CLEAN^VALM10
+ S VALMBG=1
+ I '$$ASKPARMS(.PARMS) S VALMBCK="" Q
+ I PARMS("ALL") D
+ .N APP
+ .S APP=""
+ .F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
+ ..N TIME,IEN
+ ..S TIME=PARMS("START")
+ ..Q:($O(^HLB("ERRORS",TYPE,APP,TIME))="")
+ ..S @VALMAR@($$I,0)="Application: "_APP
+ ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
+ ..F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ E  D
+ .N APP
+ .S APP=PARMS("APP")
+ .N TIME,IEN
+ .S TIME=PARMS("START")
+ .Q:$O(^HLB("ERRORS",TYPE,APP,TIME))=""
+ .S @VALMAR@($$I,0)="Application: "_APP
+ .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ ;
+SHOW S VALMBCK="R"
+ ;
+ Q
+ADDTO(LTYPE,IEN,TIME,ERRCOUNT) ;
+ N NODE,MSG
+ Q:'$$GETMSG^HLOMSG(+IEN,.MSG)
+ S ERRCOUNT=ERRCOUNT+1
+ I LTYPE'="AE" D
+ .N TYPE
+ .S TYPE=$S(MSG("BATCH"):"BATCH",1:MSG("MESSAGE TYPE")_"~"_MSG("EVENT"))
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(TYPE,8)_$$LJ($$FMTE^XLFDT(TIME,2),20)_MSG("STATUS","ERROR TEXT")
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ E  D
+ .;application errors - could be an error to a msg within a batch
+ .;also, need to go to the ack msg to get the error text from the MSA segment
+ .;
+ .N SUBIEN,MSA,ERRTEXT
+ .S (ERRTEXT,MSA)=""
+ .S SUBIEN=$P(IEN,"^",2)
+ .;within batch?
+ .D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+ .S ERRTEXT=MSG("STATUS","ERROR TEXT")
+ .I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
+ ..N MSG,SEG,FS,AIEN
+ ..S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
+ ..Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
+ ..I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
+ ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,37)
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .I $L(ERRTEXT)>37 D
+ ..S @VALMAR@($$I,0)="~"_$E(ERRTEXT,38,112)
+ ..D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ Q
+ ;
+ASKPARMS(PARMS) ;
+ K PARMS
+ S PARMS("START")=$$ASKBEGIN("T-1")
+ I 'PARMS("START") Q 0
+ S PARMS("MAX")=$$ASKMAX()
+ Q:'(PARMS("MAX")>-1) 0
+ S PARMS("ALL")=$$ASKYESNO("Include ALL applications","YES")
+ I PARMS("ALL") Q 1
+ I PARMS("ALL")="" Q 0
+ S PARMS("APP")=$$ASKAPP
+ I PARMS("APP")="" Q 0
+ Q 1
+ ;
+ASKMAX()        ;
+ N DIR
+ S DIR(0)="N^1:30000:0"
+ S DIR("A")="Maximum List Size"
+ S DIR("B")=1000
+ S DIR("?",1)="In case a large number of errors meet your search criteria, what are the"
+ S DIR("?")="maximum number of errors to display? (30,000 maximum)"
+ D ^DIR
+ Q:$D(DTOUT)!$D(DUOUT) -1
+ Q X-1
+ASKAPP() ;
+ D FULL^VALM1
+ S VALMBCK="R"
+ N DIR
+ S DIR(0)="F^3:60"
+ S DIR("A")="Application"
+ S DIR("?")="Enter the full name of the application, or '^' to exit."
+ S DIR("?",1)="For transmission failures, enter the sending application. "
+ S DIR("?",2)="For other errors, enter the name of the receiving application. "
+ D ^DIR
+ I $D(DIRUT)!(Y="") Q ""
+ Q Y
+ ;
+ASKYESNO(PROMPT,DEFAULT) ;
+ ;Description: Displays PROMPT, appending '?'.  Expects a YES NO response
+ ;Input:
+ ;   PROMPT - text to display as prompt.  Appends '?'
+ ;   DEFAULT - (optional) YES or NO.  If not passed, defaults to YES
+ ;Output:
+ ;  Function value: 1 if yes, 0 if no, "" if '^' entered or timeout
+ ;
+ N DIR,Y
+ S DIR(0)="Y"
+ S DIR("A")=PROMPT
+ S DIR("B")=$S($G(DEFAULT)="NO":"NO",1:"YES")
+ D ^DIR
+ Q:$D(DIRUT) ""
+ Q Y
+ ;
+STRTSTPQ ;
+ ;action to start or stop a queue, either incoming or outgoing
+ ;
+ N STOP,INOROUT,QUE
+ S VALMBCK="R"
+ D FULL^VALM1
+ ;ask if stop or start
+ D  Q:STOP=""
+ .N DIR
+ .S DIR(0)="S^1:START;2:STOP"
+ .S DIR("A")="Do you want to START or STOP a queue"
+ .S DIR("B")="1"
+ .D ^DIR
+ .S STOP=$S(Y=1:0,Y=2:1,1:"")
+ ;ask if in or out
+ D  Q:INOROUT=""
+ .N DIR
+ .S DIR(0)="S^I:INCOMING;O:OUTGOING"
+ .S DIR("A")="Do you want to "_$S(STOP:"stop",1:"start")_" an incoming queue or an outgoing queue"
+ .S DIR("B")="I"
+ .D ^DIR
+ .S INOROUT=$S(Y="I":"IN",Y="O":"OUT",1:"")
+ S QUE=$$ASKQUE(INOROUT)
+ Q:QUE=""
+ I STOP=$$STOPPED^HLOQUE(INOROUT,QUE) D
+ .N C
+ .I STOP D
+ ..W !,"That queue is already stopped!"
+ .E  W !,"That queue is not stopped!"
+ .W !,IOINHI,"Hit any key to continue...",IOINORM
+ .R *C:DTIME
+ E  D
+ .N C
+ .D:STOP STOPQUE^HLOQUE(INOROUT,QUE)
+ .D:'STOP STARTQUE^HLOQUE(INOROUT,QUE)
+ .W !,"DONE!"
+ .W !,IOINHI,"Hit any key to continue...",IOINORM
+ .R *C:DTIME
+ .D @HLRFRSH
+ Q
+ ;
+ASKQUE(DIR) ;
+ N QUEUE
+AGAIN W !,"Enter the full, exact name of queue:"
+ S QUEUE=""
+ R QUEUE:60 I '$T Q ""
+ I $E(QUEUE)="?" W !,"Each message is placed on a queue that has an arbitrary name up to 20",!,"characters long." I $$ASKYESNO("Would you like to see a list of the queues that currently exist","NO") D  G AGAIN
+ .N SUB,QUE,QUIT,COUNT
+ .K ^TMP($J,"HLO QUEUES")
+ .S SUB=""
+ .F  S SUB=$O(^HLB("QUEUE",DIR,SUB)) Q:SUB=""  D
+ ..S QUE=""
+ ..F  S QUE=$O(^HLB("QUEUE",DIR,SUB,QUE)) Q:QUE=""  S ^TMP($J,"HLO QUEUES",QUE)=""
+ .S QUE=""
+ .S IOSL=$G(IOSL,20)
+ .S (COUNT,QUIT)=0
+ .W !
+ .F  S QUE=$O(^TMP($J,"HLO QUEUES",QUE)) Q:QUE=""  Q:QUIT  D
+ ..W !,QUE
+ ..S COUNT=COUNT+1
+ ..I COUNT>(IOSL-3) D
+ ...N Y
+ ...D PAUSE^VALM1
+ ...I 'Y S QUIT=1
+ ...S COUNT=0
+ .W !
+ .K ^TMP($J,"HLO QUEUES")
+ Q:$E(QUEUE)="?" ""
+ Q:$E(QUEUE)="^" ""
+ Q QUEUE
+ ;
+ASKBEGIN(DEFAULT) ;
+ ;Description: Asks the user to enter a beginning date.
+ ;Input: DEFAULT - the suggested default dt/time (optional)
+ ;Output: Returns the date as the function value, or 0 if the user does not select a date
+ ;
+ ;
+ N %DT
+ S %DT="AEST"
+ S %DT("A")="Enter the beginning date/time: "
+ S %DT("B")=$$FMTE^XLFDT($S($L($G(DEFAULT)):DEFAULT,1:$$FMADD^XLFDT(DT,-1)))
+ S %DT(0)="-NOW"
+ Q:$D(DTOUT) 0
+ D ^%DT
+ I Y=-1 Q 0
+ Q Y
+ ;
+ASKEND(BEGIN) ;
+ ;Description: Asks the user to enter an ending date/time
+ ;Input: BEGIN - the earliest date/time allowed
+ ;Output: Returns the date as the function value, or 0 if the user does not select a date/time
+ ;
+ N %DT
+ S %DT="AEST"
+ S %DT("A")="Enter the ending date/time: "
+ S %DT("B")="NOW"
+ S %DT(0)=BEGIN
+ Q:$D(DTOUT) 0
+ D ^%DT
+ I Y=-1 Q 0
+ Q Y
+ ;
+LJ(STRING,LEN) ;
+ Q $$LJ^XLFSTR(STRING,LEN)
+ ;
+I() ;
+ S VALMCNT=VALMCNT+1
+ Q VALMCNT
+ ;
+HEADER ;
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m

-              r613
+              r623
+HLTF    ;AISC/SAW,JRP-Create/Process Message Text File Entries ;10/17/2007  09:41
+        ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        Q
+        ;
+FILE    ;Create Entries in files 772 and 773 for Version 1.5 Interface Only
+        D CREATE(,.HLDA,.HLDT,.HLDT1)
+        Q
+CREATE(HLMID,MTIEN,HLDT,HLDT1)  ;Create entries in Message Text (#772)
+        ;
+        ;Input  : HLMID = Variable in which value of message ID will be
+        ;                 returned (pass by reference)
+        ;         MTIEN = Variable in which IEN of Message Text file entry
+        ;                 will be returned (pass by reference)
+        ;         HLDT = Variable in which current date/time in FM internal
+        ;                format will be returned (pass by reference)
+        ;         HLDT1 = Variable in which current date/time in HL7 format
+        ;                 will be returned (pass by reference)
+        ;
+        ;Output : See above
+        ;
+        ;Notes  : If HLDT has a value [upon entry], the created entries will
+        ;         be given that value for their date/time (value of .01)
+        ;       : Current date/time used if HLDT is not passed or invalid
+        ;
+        ;Make entry in Message Administration file
+        N Y
+        S HLDT=$G(HLDT)
+        D MT(.HLDT)
+        S Y=$$CHNGMID(MTIEN,.HLMID),HLDT1=$$HLDATE^HLFNC(HLDT)
+        Q
+TCP(HLMID,MTIEN,HLDT)   ;create new message in 772 & 773 entries
+        ;used for incoming messages and outgoing responses
+        ;Input  : HLMID = Variable in which value of message ID will be
+        ;                 returned (pass by reference)
+        ;         MTIEN = Variable in which IEN of file 773 entry
+        ;                 will be returned (pass by reference)
+        ;         HLDT = Variable in which current date/time in FM internal
+        ;                format will be returned (pass by reference)
+        ;
+        S HLDT=$G(HLDT),HLMID=$G(HLMID)
+        D MT(.HLDT)
+        S MTIEN=$$MA(MTIEN,.HLMID)
+        Q
+        ;
+MT(HLX) ;Create entry in Message Text file (#772)
+        ;
+        ;Input  : HLX = Date/time entry in file should be given (value of .01)
+        ;               Defaults to current date/time
+        ;
+        ;Output : HLDT = Date/time of created entry (value of .01)
+        ;       : HLDT1 = HLDT in HL7 format
+        ;
+        ;Notes  : HLX must be in FileMan format (default value used if not)
+        ;       : HLDT will be in FileMan format
+        ;       : MTIEN is ien in file 772
+        ;
+        ;Check for input
+        S HLX=$G(HLX)
+        ;Declare variables
+        N DIC,DD,DO,HLCNT,HLJ,X,Y
+        F HLCNT=0:1 D  Q:Y>0  H HLCNT
+        . I (HLX'?7N.1".".6N) S HLX=$$NOW^XLFDT
+        . S DIC="^HL(772,",DIC(0)="L",(HLDT,X)=HLX
+        . S Y=$$STUB772(X) ; This call substituted for D FILE^DICN by HL*1.6*109
+        . ;Entry not created - try again
+        . I Y<0 S HLX="" Q
+        . S MTIEN=+Y
+        ;***If we didn't get a record in 772, need to do something
+        I Y<0 Q
+        S HLDT1=$$HLDATE^HLFNC(HLDT)
+        Q
+        ;add to Message Admin file #773
+MA(X,HLMID)     ;X=ien in file 772, HLMID=msg. id (passed by ref.)
+        ;return ien in file 773
+        ;
+        ; patch HL*1.6*122: MPI-client/server start
+        F  L +^HL(772,+$G(X)):10 Q:$T  H 1
+        Q:'$G(^HL(772,X,0)) 0
+        L -^HL(772,+$G(X))
+        ; patch HL*1.6*122: MPI-client/server end
+        ;
+        N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y
+        S DIC="^HLMA(",DIC(0)="L"
+        F HLCNT=0:1 D  Q:Y>0  H HLCNT
+        . S Y=$$STUB773(X) ; This call substituted for D FILE^DICN by HL*1.6*109
+        ;***If we didn't get a record in 773, need to do something
+        I Y<0 Q 0
+        S HLDA=+Y,HLMID=$$MAID(HLDA,$G(HLMID))
+        Q HLDA
+        ;
+MAID(Y,HLMID)   ;Determine message ID (if needed) & store message ID
+        ;Y=ien in 773, HLMID=id,  Output message id
+        N HLJ
+        ;need to have id contain institution number to make unique
+        S:$G(HLMID)="" HLMID=+$P($$PARAM^HLCS2,U,6)_Y
+        S HLJ(773,Y_",",2)=HLMID
+        D FILE^HLDIE("","HLJ","","MAID","HLTF") ;HL*1.6*109
+        Q HLMID
+        ;
+CHNGMID(PTRMT,NEWID)    ;Change message ID for entry in Message Text file
+        ;Input  : PTRMT - Pointer to entry in Message Text file (#772)
+        ;         NEWID - New message ID
+        ;Output : 0 = Success
+        ;         -1^ErrorText = Error/Bad input
+        ;
+        ;Check input
+        S PTRMT=+$G(PTRMT)
+        S NEWID=$G(NEWID)
+        Q:('$D(^HL(772,PTRMT,0))) "-1^Did not pass valid pointer to Message Text file (#772)"
+        N HLJ
+        I $G(NEWID)="" S NEWID=+$P($$PARAM^HLCS2,U,6)_PTRMT
+        S HLJ(772,PTRMT_",",6)=NEWID
+        D FILE^HLDIE("","HLJ","","CHNGMID","HLTF") ; HL*1.6*109
+        Q 0
+        ;
+OUT(HLDA,HLMID,HLMTN)   ;File Data in Message Text File for Outgoing Message
+        ;Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        D OUT^HLTF2($G(HLDA),$G(HLMID),$G(HLMTN))
+        Q
+        ;
+IN(HLMTN,HLMID,HLTIME)  ;File Data in Message Text File for Incoming Message
+        ;Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        D IN^HLTF2($G(HLMTN),$G(HLMID),$G(HLTIME))
+        Q
+        ;
+ACK(HLMSA,HLIO,HLDA)    ;Process 'ACK' Message Type - Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        D ACK^HLTF2($G(HLMSA),$G(HLIO),$G(HLDA))
+        Q
+        ;
+STUB772(FLD01,OS)       ;
+        ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set.
+        ;Inputs:
+        ;  OS (optional), the value of ^%ZOSF("OS")
+        ;  FLD01 (optional), the value for the .01 field
+        ;Output - the function returns the ien of the newly created record
+        ;
+        N IEN
+        I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
+        ;
+        I OS'["DSM",OS'["OpenM" D
+        .F  L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN
+        E  D
+        .F  S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN
+        ;
+        ; patch HL*1.6*122: MPI-client/server start
+        F  L +^HL(772,IEN):10 Q:$T  H 1
+        S ^HL(772,IEN,0)=$G(FLD01)_"^"
+        I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)=""
+        L -^HL(772,IEN)
+        ; patch HL*1.6*122: MPI-client/server end
+        ;
+        Q IEN
+        ;
+STUB773(FLD01,OS)       ;
+        ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set.
+        ;Inputs:
+        ;  OS (optional), the value of ^%ZOSF("OS")
+        ;  FLD01 (optional), the value for the .01 field
+        ;Output - the function returns the ien of the newly created record
+        ;
+        N IEN
+        I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
+        ;
+        I OS'["DSM",OS'["OpenM" D
+        .F  L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN
+        E  D
+        .F  S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HLMA(IEN):10 Q:$T  H 1
+        S ^HLMA(IEN,0)=$G(FLD01)_"^"
+        I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)=""
+        L -^HLMA(IEN)
+        ;
+        Q IEN
+HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;01/23/06  12:56
+ ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120**;Oct 13, 1995;Build 12
+FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only
+ D CREATE(,.HLDA,.HLDT,.HLDT1)
+ Q
+CREATE(HLMID,MTIEN,HLDT,HLDT1) ;Create entries in Message Text (#772)
+ ;
+ ;Input  : HLMID = Variable in which value of message ID will be
+ ;                 returned (pass by reference)
+ ;         MTIEN = Variable in which IEN of Message Text file entry
+ ;                 will be returned (pass by reference)
+ ;         HLDT = Variable in which current date/time in FM internal
+ ;                format will be returned (pass by reference)
+ ;         HLDT1 = Variable in which current date/time in HL7 format
+ ;                 will be returned (pass by reference)
+ ;
+ ;Output : See above
+ ;
+ ;Notes  : If HLDT has a value [upon entry], the created entries will
+ ;         be given that value for their date/time (value of .01)
+ ;       : Current date/time used if HLDT is not passed or invalid
+ ;
+ ;Make entry in Message Administration file
+ N Y
+ S HLDT=$G(HLDT)
+ D MT(.HLDT)
+ S Y=$$CHNGMID(MTIEN,.HLMID),HLDT1=$$HLDATE^HLFNC(HLDT)
+ Q
+TCP(HLMID,MTIEN,HLDT) ;create new message in 772 & 773 entries
+ ;used for incoming messages and outgoing responses
+ ;Input  : HLMID = Variable in which value of message ID will be
+ ;                 returned (pass by reference)
+ ;         MTIEN = Variable in which IEN of file 773 entry
+ ;                 will be returned (pass by reference)
+ ;         HLDT = Variable in which current date/time in FM internal
+ ;                format will be returned (pass by reference)
+ ;
+ S HLDT=$G(HLDT),HLMID=$G(HLMID)
+ D MT(.HLDT)
+ S MTIEN=$$MA(MTIEN,.HLMID)
+ Q
+ ;
+MT(HLX) ;Create entry in Message Text file (#772)
+ ;
+ ;Input  : HLX = Date/time entry in file should be given (value of .01)
+ ;               Defaults to current date/time
+ ;
+ ;Output : HLDT = Date/time of created entry (value of .01)
+ ;       : HLDT1 = HLDT in HL7 format
+ ;
+ ;Notes  : HLX must be in FileMan format (default value used if not)
+ ;       : HLDT will be in FileMan format
+ ;       : MTIEN is ien in file 772
+ ;
+ ;Check for input
+ S HLX=$G(HLX)
+ ;Declare variables
+ N DIC,DD,DO,HLCNT,HLJ,X,Y
+ F HLCNT=0:1 D  Q:Y>0  H HLCNT
+ . I (HLX'?7N.1".".6N) S HLX=$$NOW^XLFDT
+ . S DIC="^HL(772,",DIC(0)="L",(HLDT,X)=HLX
+ . S Y=$$STUB772(X) ; This call substituted for D FILE^DICN by HL*1.6*109
+ . ;Entry not created - try again
+ . I Y<0 S HLX="" Q
+ . S MTIEN=+Y
+ ;***If we didn't get a record in 772, need to do something
+ I Y<0 Q
+ S HLDT1=$$HLDATE^HLFNC(HLDT)
+ Q
+ ;add to Message Admin file #773
+MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.)
+ ;return ien in file 773
+ Q:'$G(^HL(772,X,0)) 0
+ N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y
+ S DIC="^HLMA(",DIC(0)="L"
+ F HLCNT=0:1 D  Q:Y>0  H HLCNT
+ . S Y=$$STUB773(X) ; This call substituted for D FILE^DICN by HL*1.6*109
+ ;***If we didn't get a record in 773, need to do something
+ I Y<0 Q 0
+ S HLDA=+Y,HLMID=$$MAID(HLDA,$G(HLMID))
+ Q HLDA
+ ;
+MAID(Y,HLMID) ;Determine message ID (if needed) & store message ID
+ ;Y=ien in 773, HLMID=id,  Output message id
+ N HLJ
+ ;need to have id contain institution number to make unique
+ S:$G(HLMID)="" HLMID=+$P($$PARAM^HLCS2,U,6)_Y
+ S HLJ(773,Y_",",2)=HLMID
+ D FILE^HLDIE("","HLJ","","MAID","HLTF") ;HL*1.6*109
+ Q HLMID
+ ;
+CHNGMID(PTRMT,NEWID) ;Change message ID for entry in Message Text file
+ ;Input  : PTRMT - Pointer to entry in Message Text file (#772)
+ ;         NEWID - New message ID
+ ;Output : 0 = Success
+ ;         -1^ErrorText = Error/Bad input
+ ;
+ ;Check input
+ S PTRMT=+$G(PTRMT)
+ S NEWID=$G(NEWID)
+ Q:('$D(^HL(772,PTRMT,0))) "-1^Did not pass valid pointer to Message Text file (#772)"
+ N HLJ
+ I $G(NEWID)="" S NEWID=+$P($$PARAM^HLCS2,U,6)_PTRMT
+ S HLJ(772,PTRMT_",",6)=NEWID
+ D FILE^HLDIE("","HLJ","","CHNGMID","HLTF") ; HL*1.6*109
+ Q 0
+ ;
+OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message
+ ;Version 1.5 Interface Only
+ Q:'$D(HLFS)
+ ;
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
+ ;
+ ;-- if message contained MSA find inbound message
+ I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
+ . N HLDAI
+ . S HLDAI=0
+ . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
+ . I 'HLDAI K HLDAI
+ ;
+ D STUFF^HLTF0("O")
+ ;
+ N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
+ ;
+ ;-- update status if MSA and found inbound message
+ I $D(HLMSA),$D(HLDAI) D
+ .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2)
+ .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
+ Q
+ ;
+IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message
+ ;Version 1.5 Interface Only
+ Q:'$D(HLFS)
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
+ ;
+ N HLDAI S HLDA=0
+ I $D(HLNDAP),HLMID]"" D
+ .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
+ .I HLDA D
+ ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
+ ..K ^HL(772,HLDA,"IN")
+ .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
+ ..S HLDAI=0
+ ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
+ ..I 'HLDAI K HLDAI
+ ;
+ I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
+ ;
+ D STUFF^HLTF0("I")
+ N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ ;
+ D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
+ ;
+ I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
+ .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
+ Q
+ ;
+ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only
+ ; To determine the correct message to link the ACK, HLIO is used.
+ ; For an ack from DHCP (original message from remote system) then
+ ; HLIO should be "I" so that the correct inbound message is ack-ed. For
+ ; an inbound ack (original message outbound from DHCP) HLIO should be
+ ; "O". This distinction must be made due to the possible duplicate
+ ; message ids from a bi-direction interface.
+ ;
+ ; Input : MSA - MSA from ACK message.
+ ;         HLIO - Either "I" or "O" : See note above.
+ ;Output : None
+ ;
+ N HLAC,HLMIDI
+ ;-- set up required vars
+ S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
+ ;-- quit
+ Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
+ ;-- find message to ack
+ I '$G(HLDA) S HLDA=0 D
+ . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
+ ;-- quit if no message
+ Q:'$D(^HL(772,+HLDA,0))
+ ;-- check for error
+ I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
+ I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
+ ;-- update status
+ S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
+ D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ Q
+ ;
+STUB772(FLD01,OS) ;
+ ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set.
+ ;Inputs:
+ ;  OS (optional), the value of ^%ZOSF("OS")
+ ;  FLD01 (optional), the value for the .01 field
+ ;Output - the function returns the ien of the newly created record
+ ;
+ N IEN
+ I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
+ ;
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
+ .F  L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN
+ E  D
+ .F  S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN
+ S ^HL(772,IEN,0)=$G(FLD01)_"^"
+ I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)=""
+ Q IEN
+ ;
+STUB773(FLD01,OS) ;
+ ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set.
+ ;Inputs:
+ ;  OS (optional), the value of ^%ZOSF("OS")
+ ;  FLD01 (optional), the value for the .01 field
+ ;Output - the function returns the ien of the newly created record
+ ;
+ N IEN
+ I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
+ ;
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
+ .F  L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN
+ E  D
+ .F  S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN
+ S ^HLMA(IEN,0)=$G(FLD01)_"^"
+ I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)=""
+ Q IEN

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m

-              r613
+              r623
+HLTF1   ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:43
+        ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2)       ;Merge Local/Global Array From Application into
+        ;Message Text File
+        ;
+        ;This is a routine call with parameter passing.  There are no output
+        ;parameters returned by this call.
+        ;
+        ;**  Merges incoming data for v1.5 applications only **
+        ;
+        ;Required input parameters
+        ;   MTIEN = The IEN from the Message Text file of the entry to be
+        ;             updated
+        ;  ARAYTYPE = Array type, G for global or L for local
+        ;      SUB1 = The first level subscript of the array.  Must be
+        ;               either HLS or HLA
+        ;Optional input parameter
+        ;      SUB2 = A second subscript associated with the array
+        ;
+        ;Check for required parameters
+        I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MRGE15X
+        ;
+        N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
+        ;
+        ;Merge data from a global array with two subscript
+        I ARAYTYPE="G",$G(SUB2)'="" D
+        . S X="",I=0
+        . F  S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+        ;
+        ;Merge data from a global array with one subscripts
+        I ARAYTYPE="G",$G(SUB2)="" D
+        . S X="",I=0
+        . F  S X=$O(^TMP(SUB1,$J,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+        ;
+        ;Merge data from a local array with one subscript
+        I ARAYTYPE="L" D
+        . S X="",I=0
+        . F  S X=$O(HLA(SUB1,X)) Q:'X  S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+        ;
+        ;-- update 0 node for message text
+        S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+        ;
+        ;File message statistics
+        D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+        ;
+MRGE15X ;-- exit merge
+        Q
+        ;
+MERGE(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into
+        ;Message Text File
+        ;
+        ;This is a routine call with parameter passing.  There are no output
+        ;parameters returned by this call.
+        ;
+        ;Required input parameters
+        ;   MTIEN = The IEN from the Message Text file of the entry to be
+        ;             updated
+        ;  ARAYTYPE = Array type, G for global or L for local
+        ;      SUB1 = The first level subscript of the array.  Must be
+        ;               either HLS or HLA
+        ;Optional input parameter
+        ;      SUB2 = A second subscript associated with the array
+        ;
+        ;Check for required parameters
+        I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MERGEX
+        ;
+        N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
+        ;
+        ;Merge data from a global array with two subscript
+        I ARAYTYPE="G",$G(SUB2)'="" D
+        . S X="",I=0
+        . F  S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,SUB2,X)) D
+        .. I X2=11 S X3="" F  S X3=$O(^TMP(SUB1,$J,SUB2,X,X3)) Q:'X3  D
+        ... S I=I+1,X1=$G(^TMP(SUB1,$J,SUB2,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+        .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+        ;
+        ;Merge data from a global array with one subscripts
+        I ARAYTYPE="G",$G(SUB2)="" D
+        . S X="",I=0
+        . F  S X=$O(^TMP(SUB1,$J,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,X)) D
+        .. I X2=11 S X3="" F  S X3=$O(^TMP(SUB1,$J,X,X3)) Q:'X3  D
+        ... S I=I+1,X1=$G(^TMP(SUB1,$J,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+        .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+        ;
+        ;Merge data from a local array with one subscript
+        I ARAYTYPE="L" D
+        . S X="",I=0
+        . F  S X=$O(HLA(SUB1,X)) Q:'X  S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(HLA(SUB1,X)) D
+        .. I X2=11 S X3="" F  S X3=$O(HLA(SUB1,X,X3)) Q:'X3  D
+        ... S I=I+1,X1=$G(HLA(SUB1,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+        .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+        ;
+        S:HLEVN=0 HLEVN=1
+        ;X=ien in file 773 for TCP messages
+        S X=+$O(^HLMA("B",MTIEN,0))
+        ;batch message type
+        I X,$P($G(^HLMA(X,0)),U,5)="B" D BTS
+        I 'X,$P(^HL(772,MTIEN,0),U,8),$P(^HL(772,$P(^(0),U,8),0),U,14)="B" D BTS
+        ;
+        ;-- update 0 node for message text
+        S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        L -^HL(772,+$G(MTIEN))
+        ;
+        ;File message statistics
+        D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+        ;
+MERGEX  ;-- exit merge
+        Q
+        ;
+BTS     ; create batch trailer seg (BTS)
+        ;HL*1.6*78 to obtain and insert FIELD SEPARATOR, HLFS
+        N HLFS,HLSAN
+        S HLFS=$G(HL("FS")) ; obtain from HL array
+        ; or obtain from sending application; default to "^"
+        I HLFS="" D  S:HLFS="" HLFS="^"
+        . S HLSAN=$P($G(^HL(772,MTIEN,0)),U,2)
+        . S:HLSAN HLFS=$G(^HL(771,HLSAN,"FS"))
+        S I=I+1,^HL(772,MTIEN,"IN",I,0)="BTS"_HLFS_HLEVN,I=I+1,^HL(772,MTIEN,"IN",I,0)=""
+        Q
+        ;
+MRGINT(MTOUT,MTIN,HDR)  ;Merge Internal to Internal Message from the
+        ; Outbound message in 772 (MTOUT) to an Inbound entry (MTIN). The process
+        ; will involve Moving the Header and Text into 772.
+        ;
+        ;Required input parameters
+        ;  MTOUT= Internal entry number of the Outbound message
+        ;  MTIN = Internal entry number of the Inbound  message
+        ;  HDR  = Name of the array that contains HL7 Header segment
+        ;         format: HLHDR - Used with indirection to build message in out
+        ;                         queue
+        ;  This routine will first take the header information in the array
+        ;  specified by HDR and merge into the Message Text field of file 870.
+        ;  Then it will move the message contained in 772 (MTIEN) into 870.
+        ;
+        ;Check for required parameters
+        I '$G(MTOUT)!('$G(MTIN))!(HDR="") Q
+        ;
+        ;-- initilize
+        N I,X
+        S I=0
+        ;
+        ;-- move header into 772 from HDR array
+        S X="" F  S X=$O(@HDR@(X)) Q:'X  D
+        . S I=I+1,^HL(772,MTIN,"IN",I,0)=@HDR@(X)
+        S I=I+1,^HL(772,MTIN,"IN",I,0)=""
+        ;
+        ;Move data from Message Text (MTOUT) file TO Message Text 772 (MTIN)
+        S X=0 F  S X=$O(^HL(772,MTOUT,"IN",X)) Q:X=""  S I=I+1 D
+        . S ^HL(772,MTIN,"IN",I,0)=$G(^HL(772,MTOUT,"IN",X,0))
+        ;
+        ;-- update 0 node of message and format arrays
+        S ^HL(772,MTIN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+        ;
+        Q
+HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;09/10/98  11:21
+ ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78**;Oct 13, 1995
+MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into
+ ;Message Text File
+ ;
+ ;This is a routine call with parameter passing.  There are no output
+ ;parameters returned by this call.
+ ;
+ ;**  Merges incoming data for v1.5 applications only **
+ ;
+ ;Required input parameters
+ ;   MTIEN = The IEN from the Message Text file of the entry to be
+ ;             updated
+ ;  ARAYTYPE = Array type, G for global or L for local
+ ;      SUB1 = The first level subscript of the array.  Must be
+ ;               either HLS or HLA
+ ;Optional input parameter
+ ;      SUB2 = A second subscript associated with the array
+ ;
+ ;Check for required parameters
+ I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MRGE15X
+ ;
+ N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
+ ;
+ ;Merge data from a global array with two subscript
+ I ARAYTYPE="G",$G(SUB2)'="" D
+ . S X="",I=0
+ . F  S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+ ;
+ ;Merge data from a global array with one subscripts
+ I ARAYTYPE="G",$G(SUB2)="" D
+ . S X="",I=0
+ . F  S X=$O(^TMP(SUB1,$J,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+ ;
+ ;Merge data from a local array with one subscript
+ I ARAYTYPE="L" D
+ . S X="",I=0
+ . F  S X=$O(HLA(SUB1,X)) Q:'X  S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1
+ ;
+ ;-- update 0 node for message text
+ S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+ ;
+ ;File message statistics
+ D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+ ;
+MRGE15X ;-- exit merge
+ Q
+ ;
+MERGE(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into
+ ;Message Text File
+ ;
+ ;This is a routine call with parameter passing.  There are no output
+ ;parameters returned by this call.
+ ;
+ ;Required input parameters
+ ;   MTIEN = The IEN from the Message Text file of the entry to be
+ ;             updated
+ ;  ARAYTYPE = Array type, G for global or L for local
+ ;      SUB1 = The first level subscript of the array.  Must be
+ ;               either HLS or HLA
+ ;Optional input parameter
+ ;      SUB2 = A second subscript associated with the array
+ ;
+ ;Check for required parameters
+ I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MERGEX
+ ;
+ N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
+ ;
+ ;Merge data from a global array with two subscript
+ I ARAYTYPE="G",$G(SUB2)'="" D
+ . S X="",I=0
+ . F  S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,SUB2,X)) D
+ .. I X2=11 S X3="" F  S X3=$O(^TMP(SUB1,$J,SUB2,X,X3)) Q:'X3  D
+ ... S I=I+1,X1=$G(^TMP(SUB1,$J,SUB2,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+ .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+ ;
+ ;Merge data from a global array with one subscripts
+ I ARAYTYPE="G",$G(SUB2)="" D
+ . S X="",I=0
+ . F  S X=$O(^TMP(SUB1,$J,X)) Q:'X  S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,X)) D
+ .. I X2=11 S X3="" F  S X3=$O(^TMP(SUB1,$J,X,X3)) Q:'X3  D
+ ... S I=I+1,X1=$G(^TMP(SUB1,$J,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+ .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+ ;
+ ;Merge data from a local array with one subscript
+ I ARAYTYPE="L" D
+ . S X="",I=0
+ . F  S X=$O(HLA(SUB1,X)) Q:'X  S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(HLA(SUB1,X)) D
+ .. I X2=11 S X3="" F  S X3=$O(HLA(SUB1,X,X3)) Q:'X3  D
+ ... S I=I+1,X1=$G(HLA(SUB1,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1
+ .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q
+ ;
+ S:HLEVN=0 HLEVN=1
+ ;X=ien in file 773 for TCP messages
+ S X=+$O(^HLMA("B",MTIEN,0))
+ ;batch message type
+ I X,$P($G(^HLMA(X,0)),U,5)="B" D BTS
+ I 'X,$P(^HL(772,MTIEN,0),U,8),$P(^HL(772,$P(^(0),U,8),0),U,14)="B" D BTS
+ ;
+ ;-- update 0 node for message text
+ S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+ ;
+ ;File message statistics
+ D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+ ;
+MERGEX ;-- exit merge
+ Q
+ ;
+BTS ; create batch trailer seg (BTS)
+ ;HL*1.6*78 to obtain and insert FIELD SEPARATOR, HLFS
+ N HLFS,HLSAN
+ S HLFS=$G(HL("FS")) ; obtain from HL array
+ ; or obtain from sending application; default to "^"
+ I HLFS="" D  S:HLFS="" HLFS="^"
+ . S HLSAN=$P($G(^HL(772,MTIEN,0)),U,2)
+ . S:HLSAN HLFS=$G(^HL(771,HLSAN,"FS"))
+ S I=I+1,^HL(772,MTIEN,"IN",I,0)="BTS"_HLFS_HLEVN,I=I+1,^HL(772,MTIEN,"IN",I,0)=""
+ Q
+ ;
+MRGINT(MTOUT,MTIN,HDR) ;Merge Internal to Internal Message from the
+ ; Outbound message in 772 (MTOUT) to an Inbound entry (MTIN). The process
+ ; will involve Moving the Header and Text into 772.
+ ;
+ ;Required input parameters
+ ;  MTOUT= Internal entry number of the Outbound message
+ ;  MTIN = Internal entry number of the Inbound  message
+ ;  HDR  = Name of the array that contains HL7 Header segment
+ ;         format: HLHDR - Used with indirection to build message in out
+ ;                         queue
+ ;  This routine will first take the header information in the array
+ ;  specified by HDR and merge into the Message Text field of file 870.
+ ;  Then it will move the message contained in 772 (MTIEN) into 870.
+ ;
+ ;Check for required parameters
+ I '$G(MTOUT)!('$G(MTIN))!(HDR="") Q
+ ;
+ ;-- initilize
+ N I,X
+ S I=0
+ ;
+ ;-- move header into 772 from HDR array
+ S X="" F  S X=$O(@HDR@(X)) Q:'X  D
+ . S I=I+1,^HL(772,MTIN,"IN",I,0)=@HDR@(X)
+ S I=I+1,^HL(772,MTIN,"IN",I,0)=""
+ ;
+ ;Move data from Message Text (MTOUT) file TO Message Text 772 (MTIN)
+ S X=0 F  S X=$O(^HL(772,MTOUT,"IN",X)) Q:X=""  S I=I+1 D
+ . S ^HL(772,MTIN,"IN",I,0)=$G(^HL(772,MTOUT,"IN",X,0))
+ ;
+ ;-- update 0 node of message and format arrays
+ S ^HL(772,MTIN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+ ;
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m

-              r613
+              r623
+HLTF2   ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:44
+        ;;1.6;HEALTH LEVEL SEVEN;**25,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA)        ;Merge Data From Communication Server
+        ;Module Logical Link File into Message Text File
+        ;
+        ;This is a subroutine call with parameter passing.  The output
+        ;parameters HDR (and optionally) MSA are returned by this call.
+        ;
+        ;Required input parameters
+        ;  LLD0 = Internal entry number where message is stored in Logical Link
+        ;            file or XM if message is stored in MailMan
+        ;  LLD1 = Internal entry number of IN QUEUE multiple entry in Logical
+        ;           Link file (Only required for messages stored in Logical
+        ;           Link file)
+        ;  MTIEN = Internal entry number where message is to be copied to in
+        ;            Message Text file
+        ;    HDR = The variable in which the message header segment will
+        ;            be returned
+        ;    MSA = The variable in which the message acknowledgement segment
+        ;            will be returned, if one exists for this message
+        ;
+        ;Check for required parameters
+        I $G(LLD0)']""!('$G(MTIEN)) Q
+        I LLD0'="XM",'$G(LLD1) Q
+        N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE
+        S (FLG,HLCHAR,HLEVN,X)=0
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
+        ;
+        ;Move data from Logical Link file to Message Text file
+        I LLD0'="XM" D
+        .S I=0 F  S X=$O(^HLCS(870,LLD0,1,LLD1,1,X)) Q:X'>0  S X1=$G(^(X,0)) S:"FHS,BHS,MSH"[$E(X1,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(X1) D
+        ..;If header segment, process it and set HDR equal to it
+        ..I X1'="","FHS,BHS,MSH"[$E(X1,1,3) D
+        ...I '$D(HDR) S HDR=X1,HLFS=$E(X1,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2)
+        ...S $P(X1,HLFS,8)=""
+        ...S:$E(X1,1,3)="MSH" HLEVN=HLEVN+1
+        ..;If acknowledgement segment, set MSA equal to it
+        ..I $E(X1,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=X1
+        ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=X1
+        ;
+        ;Move data from MailMan Message file to Message Text file
+        I LLD0="XM" D
+        .S I=0 F  X XMREC Q:XMER<0  S:"FHS,BHS,MSH"[$E(XMRG,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(XMRG) D  Q:XMER<0
+        ..;If header segment, process it and set HDR equal to it
+        ..I XMRG'="","FHS,BHS,MSH"[$E(XMRG,1,3) D
+        ...I '$D(HDR) S HDR=XMRG,HLFS=$E(XMRG,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2)
+        ...S $P(XMRG,HLFS,8)=""
+        ...S:$E(XMRG,1,3)="MSH" HLEVN=HLEVN+1
+        ..;If acknowledgement segment, set MSA equal to it
+        ..I $E(XMRG,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=XMRG
+        ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=XMRG
+        S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+        ;Update statistics in Message Text file for this entry
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        L -^HL(772,+$G(MTIEN))
+        ;
+        D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+        Q
+MERGEOUT(MTIEN,LLD0,LLD1,HDR)   ;Merge Text in Message Text File into
+        ;Communication Server Module Logical Link File
+        ;
+        ;This is a routine call with parameter passing.  There are no output
+        ;parameters returned by this call.
+        ;
+        ;Required input parameters
+        ;  MTIEN = Internal entry number where message is stored in Message
+        ;            Text file
+        ;  LLD0 = Internal entry number where message is to be copied to in
+        ;            Logical Link file
+        ;  LLD1 = Internal entry number of IN QUEUE multiple entry in Logical
+        ;          Link file
+        ;  HDR  = Name of the array that contains HL7 Header segment
+        ;         format: HLHDR - Used with indirection to build message in out
+        ;                         queue
+        ;  This routine will first take the header information in the array
+        ;  specified by HDR and merge into the Message Text field of file 870.
+        ;  Then it will move the message contained in 772 (MTIEN) into 870.
+        ;
+        ;Check for required parameters
+        I '$G(MTIEN)!('$G(LLD0))!('$G(LLD1))!(HDR="") Q
+        ;
+        ;-- initilize
+        N I,X
+        S I=0
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        F  L +^HLCS(870,+$G(LLD0),2,+$G(LLD1)):10 Q:$T  H 1
+        ;
+        ;-- move header into 870 from HDR array
+        S X="" F  S X=$O(@HDR@(X)) Q:'X  D
+        . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=@HDR@(X)
+        S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=""
+        ;
+        ;Move data from Message Text file to Logical Link file
+        S X=0 F  S X=$O(^HL(772,MTIEN,"IN",X)) Q:X=""  D
+        . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=$G(^HL(772,MTIEN,"IN",X,0))
+        ;
+        ;-- update 0 node of message and format arrays
+        S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        L -^HLCS(870,+$G(LLD0),2,+$G(LLD1))
+        ;
+        Q
+OUT(HLDA,HLMID,HLMTN)   ;File Data in Message Text File for Outgoing Message
+        ;Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        Q:'$D(HLFS)
+        ;
+        I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
+        ;
+        ;-- if message contained MSA find inbound message
+        I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
+        . N HLDAI
+        . S HLDAI=0
+        . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
+        . I 'HLDAI K HLDAI
+        ;
+        D STUFF^HLTF0("O")
+        ;
+        N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+        D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
+        ;
+        ;-- update status if MSA and found inbound message
+        I $D(HLMSA),$D(HLDAI) D
+        .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+        .S HLAC=$P(HLMSA,HLFS,2)
+        .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
+        .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
+        Q
+        ;
+IN(HLMTN,HLMID,HLTIME)  ;File Data in Message Text File for Incoming Message
+        ;Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        Q:'$D(HLFS)
+        I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
+        ;
+        N HLDAI S HLDA=0
+        I $D(HLNDAP),HLMID]"" D
+        .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
+        .I HLDA D
+        ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
+        ..K ^HL(772,HLDA,"IN")
+        .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
+        ..S HLDAI=0
+        ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
+        ..I 'HLDAI K HLDAI
+        ;
+        ; patch HL*1.6*122: MPI-client/server
+        ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
+        I 'HLDA D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
+        ;
+        D STUFF^HLTF0("I")
+        N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+        ;
+        D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
+        ;
+        I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
+        .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+        .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
+        .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
+        Q
+        ;
+ACK(HLMSA,HLIO,HLDA)    ;Process 'ACK' Message Type - Version 1.5 Interface Only
+        ;
+        ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
+        ; OUT, IN, and ACK to HLTF2 routine.
+        ;
+        ; To determine the correct message to link the ACK, HLIO is used.
+        ; For an ack from DHCP (original message from remote system) then
+        ; HLIO should be "I" so that the correct inbound message is ack-ed. For
+        ; an inbound ack (original message outbound from DHCP) HLIO should be
+        ; "O". This distinction must be made due to the possible duplicate
+        ; message ids from a bi-direction interface.
+        ;
+        ; Input : MSA - MSA from ACK message.
+        ;         HLIO - Either "I" or "O" : See note above.
+        ;Output : None
+        ;
+        N HLAC,HLMIDI
+        ;-- set up required vars
+        S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
+        ;-- quit
+        Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
+        ;-- find message to ack
+        I '$G(HLDA) S HLDA=0 D
+        . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
+        ;-- quit if no message
+        Q:'$D(^HL(772,+HLDA,0))
+        ;-- check for error
+        I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
+        I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
+        ;-- update status
+        S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
+        D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+        Q
+        ;
+HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97  13:56
+ ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995
+MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server
+ ;Module Logical Link File into Message Text File
+ ;
+ ;This is a subroutine call with parameter passing.  The output
+ ;parameters HDR (and optionally) MSA are returned by this call.
+ ;
+ ;Required input parameters
+ ;  LLD0 = Internal entry number where message is stored in Logical Link
+ ;            file or XM if message is stored in MailMan
+ ;  LLD1 = Internal entry number of IN QUEUE multiple entry in Logical
+ ;           Link file (Only required for messages stored in Logical
+ ;           Link file)
+ ;  MTIEN = Internal entry number where message is to be copied to in
+ ;            Message Text file
+ ;    HDR = The variable in which the message header segment will
+ ;            be returned
+ ;    MSA = The variable in which the message acknowledgement segment
+ ;            will be returned, if one exists for this message
+ ;
+ ;Check for required parameters
+ I $G(LLD0)']""!('$G(MTIEN)) Q
+ I LLD0'="XM",'$G(LLD1) Q
+ N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE
+ S (FLG,HLCHAR,HLEVN,X)=0
+ ;
+ ;Move data from Logical Link file to Message Text file
+ I LLD0'="XM" D
+ .S I=0 F  S X=$O(^HLCS(870,LLD0,1,LLD1,1,X)) Q:X'>0  S X1=$G(^(X,0)) S:"FHS,BHS,MSH"[$E(X1,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(X1) D
+ ..;If header segment, process it and set HDR equal to it
+ ..I X1'="","FHS,BHS,MSH"[$E(X1,1,3) D
+ ...I '$D(HDR) S HDR=X1,HLFS=$E(X1,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2)
+ ...S $P(X1,HLFS,8)=""
+ ...S:$E(X1,1,3)="MSH" HLEVN=HLEVN+1
+ ..;If acknowledgement segment, set MSA equal to it
+ ..I $E(X1,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=X1
+ ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=X1
+ ;
+ ;Move data from MailMan Message file to Message Text file
+ I LLD0="XM" D
+ .S I=0 F  X XMREC Q:XMER<0  S:"FHS,BHS,MSH"[$E(XMRG,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(XMRG) D  Q:XMER<0
+ ..;If header segment, process it and set HDR equal to it
+ ..I XMRG'="","FHS,BHS,MSH"[$E(XMRG,1,3) D
+ ...I '$D(HDR) S HDR=XMRG,HLFS=$E(XMRG,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2)
+ ...S $P(XMRG,HLFS,8)=""
+ ...S:$E(XMRG,1,3)="MSH" HLEVN=HLEVN+1
+ ..;If acknowledgement segment, set MSA equal to it
+ ..I $E(XMRG,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=XMRG
+ ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=XMRG
+ S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+ ;Update statistics in Message Text file for this entry
+ D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
+ Q
+MERGEOUT(MTIEN,LLD0,LLD1,HDR) ;Merge Text in Message Text File into
+ ;Communication Server Module Logical Link File
+ ;
+ ;This is a routine call with parameter passing.  There are no output
+ ;parameters returned by this call.
+ ;
+ ;Required input parameters
+ ;  MTIEN = Internal entry number where message is stored in Message
+ ;            Text file
+ ;  LLD0 = Internal entry number where message is to be copied to in
+ ;            Logical Link file
+ ;  LLD1 = Internal entry number of IN QUEUE multiple entry in Logical
+ ;          Link file
+ ;  HDR  = Name of the array that contains HL7 Header segment
+ ;         format: HLHDR - Used with indirection to build message in out
+ ;                         queue
+ ;  This routine will first take the header information in the array
+ ;  specified by HDR and merge into the Message Text field of file 870.
+ ;  Then it will move the message contained in 772 (MTIEN) into 870.
+ ;
+ ;Check for required parameters
+ I '$G(MTIEN)!('$G(LLD0))!('$G(LLD1))!(HDR="") Q
+ ;
+ ;-- initilize
+ N I,X
+ S I=0
+ ;
+ ;-- move header into 870 from HDR array
+ S X="" F  S X=$O(@HDR@(X)) Q:'X  D
+ . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=@HDR@(X)
+ S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=""
+ ;
+ ;Move data from Message Text file to Logical Link file
+ S X=0 F  S X=$O(^HL(772,MTIEN,"IN",X)) Q:X=""  D
+ . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=$G(^HL(772,MTIEN,"IN",X,0))
+ ;
+ ;-- update 0 node of message and format arrays
+ S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
+ ;
+ Q

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m

-              r613
+              r623
+HLTP3   ;SFIRMFO/RSD - Transaction Processor for TCP ;03/17/2008  11:26
+        ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122,140**;Oct 13, 1995;Build 5
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        Q
+NEW(X)  ;process new msg. ien in 773^ien in 772
+        ;HLMTIENS=ien in #773; HLMTIEN=ien in #772
+        ;HLHDRO=original header;  HLHDR=response header
+        ;set error trap
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
+        N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT
+        S HLRESLT=""
+        D INIT^HLTP3A
+        ;error with header, return commit/app reject
+        I $G(HLRESLT) D  Q
+        . ;set status & unlock record
+        . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
+        . ;quit if no commit or app ack
+        . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q
+        . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR")
+        . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
+        . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
+        . ;write ack back
+        . S X=$$WRITE^HLCSTCP2(HLTCP)
+        . ;update counter to sent
+        . D LLCNT^HLCSTCP(HLDP,4)
+        . ;update status of ack
+        . D STATUS^HLTF0(HLTCP,3,,,1)
+        ;
+        ;check for duplicate msg., use rec. app and msg. id x-ref
+        ; patch HL*1.6*120
+        I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
+        . ;HLASTMSG=last ien received during this connection
+        . ;if no duplicate, save msg. ien and quit
+        . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q
+        . N MSH,OIENS
+        . S (OIENS,Y)=X D  S Y=HLMTIENS D
+        .. ;combine MSH into single string
+        .. S MSH(Y)="",I=0 F  S I=$O(^HLMA(Y,"MSH",I)) Q:'I  S MSH(Y)=MSH(Y)_$G(^(I,0))
+        .; patch 117 & 125, check if identical
+        .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
+        .;
+        . ;msg is duplicate, set status
+        . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
+        . ;msg was resent, ignore it.
+        . I HLASTMSG=HLMTIENS K HLMTIENS Q
+        . ;find original response and send back
+        . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
+        ;
+        ;Quit if this is ack to ack
+        I $G(HL("ACK")) D  Q
+        . ;Update status of original ack message
+        . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
+        . ;unlock record
+        . D EXIT
+        ;
+        ;enhance ack., send commit, quit if not an ack, msg will be processed by filer
+        I $G(HL("ACAT"))="AL" D  Q:'$G(HL("MTIENS"))
+        . ;msg is a resend, HLASTRSP=ien of original response
+        .I $G(HLASTRSP) D
+        ..S HLTCP=HLASTRSP
+        ..D LLCNT^HLCSTCP(HLDP,3)
+        . E  D  Q:'$G(HLTCP)
+        ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
+        . S X=$$WRITE^HLCSTCP2(HLTCP)
+        . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
+        . S HLTCP=""
+        . ;if not an ack, set status to awaiting processing **109** and put on in queue
+        . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
+        ;
+        ;enhance ack., no commit & no app ack
+        I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D  Q
+        . ;set status to awaiting processing, **109** and put on in queue
+        . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
+        ;
+        ; patch HL*1.6*120 start
+        ;resending old response, msg is a resend
+        ; do not re-send duplicate when $G(HL("ACAT"))="AL"
+        I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
+        ; quit if duplicate
+        Q:$G(HLASTRSP)
+        ; patch HL*1.6*120 end
+        ;
+CONT    ;continue processing an enhance ack msg. called from DEFACK
+        ;Set special HL variables for processing rtn
+        S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
+        ;
+        ; message is an acknowledgement, HLMSA=ack code^id^text
+        I ($G(HLMSA)]"") D  Q
+        . ;X=1 if ack ok, 0=reject of error
+        . S X=$E(HLMSA,2)="A"
+        . ;Update status of original message and remove it from the queue
+        . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
+        . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
+        . D
+        .. N HLTCP ;variable to update status in file #772.
+        ..;
+        ..;**108**
+        .. N TEMP
+        .. S TEMP=HLMTIENS
+        .. N HLMTIENS
+        .. S HLMTIENS=TEMP
+        ..;**END 108**
+        ..;
+        .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
+        . ;update status of incoming & unlock
+        . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
+        ;
+        ;get entry action, exit action and processing routine
+        K HLHDR,HLLD0,HLLD1,HLMSA
+        I 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)),HLPROU=$G(HLN(771))
+        ;quit if no processing routine,update status and quit
+        I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q
+        ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
+        N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
+        ;Execute entry action of client protocol
+        X:HLENROU]"" HLENROU K HLENROU,HLDONE1
+        ;
+        ;Execute processing routine
+        X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR
+        ;update status of incoming to complete & unlock
+        D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
+        ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
+ACK     I $G(HLTCPO),$G(HLTCP) D  Q
+        . D LLCNT^HLCSTCP(HLDP,3)
+        . ;write ack back over open tcp link
+        . S X=$$WRITE^HLCSTCP2(HLTCP)
+        . ;update status of ack to complete
+        . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1)
+        . D LLCNT^HLCSTCP(HLDP,4)
+        Q
+        ;
+DEFACK(HLDP,X)  ;process the deferred application ack, called from HLCSIN
+        ;HLDP=logical link, X=ien in file 773
+        ;
+        ; patch HL*1.6*120 start
+        ; clean non-Kernel variables
+        D
+        . ; protect variables defined in STARTIN^HLCSIN
+        . N HLFLG,HLEXIT,HLPTRFLR
+        . ; protect variables defined in DEFACK^HLCSIN
+        . N HLXX,HLD0,HLPCT
+        . ; protect input parameters of this sub-routine
+        . N HLDP,X
+        . D KILL^XUSCLEAN
+        ; patch HL*1.6*120 end
+        ;
+        ;set error trap
+        N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
+        N HLERR     ;patch HL*1.6*109
+        Q:'$G(HLDP)!'$G(X)  Q:'$G(^HLMA(X,0))
+        Q:'$D(^HLMA("AC","I",HLDP,X))
+        ;
+        N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+        S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
+        S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
+        S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15)
+        S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U)
+        S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U)
+        S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U)
+        S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10)
+        M HLHDRO=^HLMA(HLMTIENS,"MSH")
+        ; if no header quit
+        Q:'$O(HLHDRO(0))
+        ;
+        S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
+        ;
+        ; quit if ien of #772 is not defined
+        Q:'HLMTIEN
+        ; quit if field separator is not defined
+        Q:HL("FS")=""
+        ;
+        S X=$$P^HLTPCK2(.HLHDRO,1)
+        ;
+        ; patch HL*1.6*120 start
+        I X="MSH" D
+        . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17)
+        . ;
+        . ; 2nd component is Processing mode
+        . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2)
+        . ; first component is Processing id
+        . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1))
+        ;
+        I X'="MSH" D
+        . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
+        . ;
+        . ; original code incorrectly treats repetition separator as
+        . ; subcomponent separator
+        . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
+        .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2)
+        . ; if subcomponent separator is correctly applied
+        . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D
+        .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4)
+        . ;
+        . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D
+        .. ; 2nd sub-component is Processing mode
+        .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2)
+        .. ; first sub-component is Processing id
+        .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT"))
+        . ; patch HL*1.6*120 end
+        . ;
+        . Q:$$P^HLTPCK2(.HLHDRO,10)=""
+        . ;HLMSA=ack code^id^text
+        . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
+        ;
+        ; quit if this is a commit ack
+        I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
+        ;
+        ;**  HL*1.6*117 **
+        K HLL("SET FOR APP ACK"),HLL("LINKS")
+        ;
+        D CONT
+        Q
+        ;
+MSA(Y)  ;Y=ien in 772, returns MSA segment
+        ;ack code^msg being ack id^text
+        ; patch HL*1.6*122
+        ; for HL7 v2.5 and beyond with MSA as 3rd segment
+        N X,SUBIEN,DATA,DONE
+        S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
+        Q:X]"" X
+        ;
+        S DONE=0
+        S SUBIEN=1
+        F  S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN  D  Q:DONE
+        . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D
+        .. S DONE=1
+        .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN
+        .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
+        ; patch HL*1.6*122 end
+        ;
+        Q X
+        ;
+ERROR   ;error trap
+        D ^%ZTER
+        I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
+        ; release locks created by inbound filer
+        ; patch HL*1.6*140
+        ; L -^HLMA("AC","I",+$G(HLXX))
+        L -^HLMA("IN-FILER","AC","I",+$G(HLXX))
+        G UNWIND^%ZTER
+        ;
+        ;
+EXIT    ;unlock
+        I $G(HLMTIENS) L -^HLMA(HLMTIENS)
+        Q
+        ;
+ONAC(IEN773)    ;
+        ;Returns 1 if the message is on the "AC","I" xref
+        ;Returns 0 otherwise
+        ;
+        N LINK
+        S LINK=$P($G(^HLMA(IEN773,0)),"^",17)
+        Q:'LINK 0
+        Q $D(^HLMA("AC","I",LINK,IEN773))
+HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ Q
+NEW(X) ;process new msg. ien in 773^msg. ien in 772
+ ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text
+ ;HLHDRO=original header;  HLHDR=response header
+ ;set error trap
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
+ N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT
+ S HLRESLT=""
+ D INIT^HLTP3A
+ ;error with header, return commit/app reject
+ I $G(HLRESLT) D  Q
+ . ;set status & unlock record
+ . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
+ . ;quit if no commit or app ack
+ . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q
+ . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR")
+ . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
+ . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
+ . ;write ack back over connection
+ . S X=$$WRITE^HLCSTCP2(HLTCP)
+ . ;update counter to sent
+ . D LLCNT^HLCSTCP(HLDP,4)
+ . ;update status of ack to complete
+ . D STATUS^HLTF0(HLTCP,3,,,1)
+ ;
+ ;check for duplicate msg., use rec. app and msg. id x-ref
+ ; patch HL*1.6*120
+ ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
+ I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
+ . ;HLASTMSG=last ien received during this connection
+ . ;if no duplicate, save msg. ien and quit
+ . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q
+ . N MSH,OIENS
+ . S (OIENS,Y)=X D  S Y=HLMTIENS D
+ .. ;combine MSH into single string
+ .. S MSH(Y)="",I=0 F  S I=$O(^HLMA(Y,"MSH",I)) Q:'I  S MSH(Y)=MSH(Y)_$G(^(I,0))
+ .; patch 117 & 125, check if identical
+ .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
+ .;
+ . ;msg is duplicate, set status as duplicate
+ . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
+ . ;msg was resent during this connection, ignore it.
+ . I HLASTMSG=HLMTIENS K HLMTIENS Q
+ . ;find original response and send back
+ . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
+ ;
+ ;Quit if this is acknowledgment to acknowledgement message
+ I $G(HL("ACK")) D  Q
+ . ;Update status of original acknowledgment message to successfully
+ . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
+ . ;unlock record
+ . D EXIT
+ ;
+ ;enhance ack., send commit, quit if not an ack, msg will be processed by filer
+ I $G(HL("ACAT"))="AL" D  Q:'$G(HL("MTIENS"))
+ . ;msg is a resend, HLASTRSP=ien of original response
+ .I $G(HLASTRSP) D
+ ..S HLTCP=HLASTRSP
+ ..D LLCNT^HLCSTCP(HLDP,3)
+ . E  D  Q:'$G(HLTCP)
+ ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
+ . S X=$$WRITE^HLCSTCP2(HLTCP)
+ . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
+ . S HLTCP=""
+ . ;if not an ack, set status to awaiting processing **109** and put on in queue
+ . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
+ ;
+ ;enhance ack., no commit & no app ack
+ I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D  Q
+ . ;set status to awaiting processing, **109** and put on in queue
+ . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
+ ;
+ ; patch HL*1.6*120 start
+ ;resending old response, msg is a resend
+ ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK
+ ; do not re-send duplicate message when $G(HL("ACAT"))="AL"
+ I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
+ ; quit if duplicate
+ Q:$G(HLASTRSP)
+ ; patch HL*1.6*120 end
+ ;
+CONT ;continue processing an enhance ack msg. called from DEFACK
+ ;Set special HL variables for processing rtn
+ S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
+ ;
+ ; message is an acknowledgement, HLMSA=ack code^id^text
+ I ($G(HLMSA)]"") D  Q
+ . ;X=1 if ack ok, 0=reject of error
+ . S X=$E(HLMSA,2)="A"
+ . ;Update status of original subscriber message and remove it from the out-going queue
+ . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
+ . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
+ . D
+ .. N HLTCP ;New variable to update status in file #772.
+ ..;
+ ..;**108**
+ .. N TEMP
+ .. S TEMP=HLMTIENS
+ .. N HLMTIENS
+ .. S HLMTIENS=TEMP
+ ..;**END 108**
+ ..;
+ .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
+ . ;update status of incoming to complete & unlock
+ . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
+ ;
+ ;get entry action, exit action and processing routine
+ K HLHDR,HLLD0,HLLD1,HLMSA
+ I 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)),HLPROU=$G(HLN(771))
+ ;quit if no processing routine,update status and quit
+ I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q
+ ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
+ N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
+ ;Execute entry action of client protocol
+ X:HLENROU]"" HLENROU K HLENROU,HLDONE1
+ ;
+ ;Execute processing routine
+ X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR
+ ;update status of incoming to complete & unlock
+ D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
+ ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK
+ACK I $G(HLTCPO),$G(HLTCP) D  Q
+ . D LLCNT^HLCSTCP(HLDP,3)
+ . ;write ack back over open tcp link
+ . S X=$$WRITE^HLCSTCP2(HLTCP)
+ . ;update status of ack to complete
+ . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1)
+ . D LLCNT^HLCSTCP(HLDP,4)
+ Q
+ ;
+DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN
+ ;HLDP=logical link, X=ien in file 773
+ ;
+ ; patch HL*1.6*120 start
+ ; clean variables except Kernel related variables
+ D
+ . ; protect variables defined in STARTIN^HLCSIN
+ . N HLFLG,HLEXIT,HLPTRFLR
+ . ; protect variables defined in DEFACK^HLCSIN
+ . N HLXX,HLD0,HLPCT
+ . ; protect input parameters of this sub-routine
+ . N HLDP,X
+ . D KILL^XUSCLEAN
+ ; patch HL*1.6*120 end
+ ;
+ ;set error trap
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
+ N HLERR     ;patch HL*1.6*109
+ Q:'$G(HLDP)!'$G(X)  Q:'$G(^HLMA(X,0))
+ ;**109 START**
+ Q:'$D(^HLMA("AC","I",HLDP,X))
+ ;**109 END**
+ ;
+ N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+ ;setup variables
+ S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
+ S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
+ S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15)
+ S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U)
+ S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U)
+ S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U)
+ S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10)
+ M HLHDRO=^HLMA(HLMTIENS,"MSH")
+ ; if no header quit
+ ;**109**
+ ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q
+ Q:'$O(HLHDRO(0))
+ ;
+ S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
+ ;
+ ; patch HL*1.6*109 start
+ ; quit if ien of #772 is not defined
+ Q:'HLMTIEN
+ ; quit if field separator is not defined
+ Q:HL("FS")=""
+ ; patch HL*1.6*109 end
+ ;
+ S X=$$P^HLTPCK2(.HLHDRO,1)
+ ;
+ ; patch HL*1.6*120 start
+ I X="MSH" D
+ . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17)
+ . ;
+ . ; 2nd component is Processing mode
+ . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2)
+ . ; first component is Processing id
+ . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1))
+ ;
+ I X'="MSH" D
+ . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
+ . ;
+ . ; original implementation incorrectly treats repetition separator as
+ . ; subcomponent separator
+ . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
+ .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2)
+ . ; if subcomponent separator is correctly applied
+ . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D
+ .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4)
+ . ;
+ . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D
+ .. ; 2nd sub-component is Processing mode
+ .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2)
+ .. ; first sub-component is Processing id
+ .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT"))
+ . ; patch HL*1.6*120 end
+ . ;
+ . Q:$$P^HLTPCK2(.HLHDRO,10)=""
+ . ;HLMSA=ack code^id^text
+ . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
+ ;
+ ; HL*1.6*108
+ ; quit if this is a commit ack
+ I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
+ ; **
+ ;
+ ;**  HL*1.6*117 **
+ K HLL("SET FOR APP ACK"),HLL("LINKS")
+ ;** END HL*1.6*117 **
+ ;
+ D CONT
+ Q
+ ;
+MSA(Y) ;Y=ien in 772, returns MSA segment
+ ;ack code^msg being ack id^text
+ N X
+ S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
+ Q X
+ ;
+ERROR ;error trap
+ D ^%ZTER
+ I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
+ ;*109* release all locks created by inbound filer
+ L -^HLMA("AC","I",+$G(HLXX))
+ G UNWIND^%ZTER
+ ;
+ ;
+EXIT ;unlock
+ I $G(HLMTIENS) L -^HLMA(HLMTIENS)
+ Q
+ ;
+ONAC(IEN773) ;
+ ;Returns 1 if the message is on the "AC","I" xref
+ ;Returns 0 otherwise
+ ;
+ N LINK
+ S LINK=$P($G(^HLMA(IEN773,0)),"^",17)
+ Q:'LINK 0
+ Q $D(^HLMA("AC","I",LINK,IEN773))

WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m

-              r613
+              r623
+HLTPCK2B        ;OIFO-O/RJH - Message Header Validation (Con't) ;10/04/2007  16:00
+        ;;1.6;HEALTH LEVEL SEVEN;**120,133,122**;Oct 13, 1995;Build 14
+        ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; splitted from HLTPCK2A
+        ; to be called from HLTPCK2A
+        ;
+MS      ;Check for Message Structure Code
+        I $G(ARY("MTN_ETN"))'="" D
+        . S ARY("MTP_ETP")=0
+        . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
+        . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
+        ;
+        ;Get server and client Protocols
+MSA     ;if ack, then get information and quit, we don't need to respond
+        I $G(MSA)]"" D  Q
+        . ;Message is an acknowledgement, find original message
+        . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
+        . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q
+        . F  S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
+        . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q
+        . ;get subscriber protocol and ack. to (show if this is an ack to an ack)
+        . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
+        . ;if no subscriber protocol then response msg. is invalid
+        . ;
+        . ; patch HL*1.6*122 start
+        . ; comment out the following code: for patch 109- dynamic addressing
+        . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
+        . ;get message text ien in file 772 and server protocol, 'EID'
+        . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
+        . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
+        . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+        . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+        . ; patch HL*1.6*122 end
+        ;
+        ;Find Server Protocol - based on sending application, message type,
+        ;event type and version ID
+        I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
+        ;
+        ;Find Server Protocol - based on sending application, message type,
+        ;and version ID
+        I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
+        ;
+        I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
+        ;Find Client Protocol - in ITEM multiple of Server Protocol
+        S ARY("EIDS")=0
+        F  S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:'ARY("EIDS")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP"))
+        I 'ARY("EIDS") S ERR="Invalid Receiving Application for this Event" Q
+        D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+        ;
+LLP     ;Get logical link pointer
+        S ARY("LL")=$P($G(HLN(770)),"^",7)
+        ;
+FAC     ;Get sending/rec facility, validate if necessary
+        ;
+        S HLCS=$E(ECH,1) ;Get component separator
+        S ARY("RAF")=$$P^HLTPCK2(.HDR,6) ;Receiving Facility
+        S ARY("SAF")=$$P^HLTPCK2(.HDR,4) ;Sending Facility
+        ;Get sending/receiving facility from Application Parameter file(771)
+        S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
+        S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
+        ;Sending/Receiving facility required?
+        S X=$G(^ORD(101,ARY("EIDS"),773))
+        S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
+RF      ;Validate Receiving Facility
+        I HLRFREQ D
+        .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility"
+        .I HL771RF]"" D  Q
+        ..;Facility data in 771 overrides data in site paramter file
+        ..Q
+        .;Check against local default value (site parameters)
+        .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
+        .;
+        .; patch HL*1.6*120 start
+        .; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D  Q
+        . I $P(ARY("RAF"),HLCS,3)="DNS" D  Q
+        .. N ERROR,HLDOMP1,HLDOMP2
+        .. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+        .. S HLDOMP1=$P(ARY("RAF"),HLCS,2)
+        .. ;
+        .. ; assume the format is <domain>:<port #>
+        .. I HLDOMP1[":" S ARY("RAF-PORT")=$P(HLDOMP1,":",2)
+        .. S HLDOMP1=$P(HLDOMP1,":")
+        .. S ARY("RAF-DOMAIN")=HLDOMP1
+        .. ;
+        .. ; if first piece of domain is "HL7." or "MPI.", remove it
+        .. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D
+        ... S HLDOMP1=$P(HLDOMP1,".",2,99)
+        .. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+        .. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
+        .. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q
+        .. ;
+        .. ; check DNS domain and ip address
+        .. ;initialize variable, HLDOMP("FLAG")
+        .. S HLDOMP("FLAG")=0
+        .. I ARY("RAF-DOMAIN")]"" D
+        ... ;
+        ... ; match DNS domain
+        ... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
+        ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
+        ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
+        ... ;
+        ... ; match ip address
+        ... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
+        .. Q:HLDOMP("FLAG")=1
+        .. I $P(ARY("RAF"),HLCS)=HLINSTN Q
+        .. ;
+        .. S:ERR="" ERR="Receiving Facility mismatch."
+        . I $P(ARY("RAF"),HLCS)=HLINSTN Q
+        . S:ERR="" ERR="Receiving Facility mismatch."
+        ; patch HL*1.6*120 end
+        ;
+SF      ;Validate Sending Facility
+        I HLSFREQ D
+        .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility"
+        .I HL771SF]"" D  Q
+        ..;Check for facility data in 771
+        ..Q
+        .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
+        .;If so, use this instead of Protocol definition for return path
+        .;
+        .; patch HL*1.6*120 start
+        . N HLDOMP
+        . ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+        . S HLDOMP=$P(ARY("SAF"),HLCS,2)
+        . ;
+        . ; assume the format is <domain>:<port #>
+        . I HLDOMP[":" S ARY("SAF-PORT")=$P(HLDOMP,":",2)
+        . S HLDOMP=$P(HLDOMP,":")
+        . S ARY("SAF-DOMAIN")=HLDOMP
+        . ;
+        . ; if first piece of domain is "HL7." or "MPI.", remove it
+        . I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D
+        .. S HLDOMP=$P(HLDOMP,".",2,99)
+        . S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+        .;Note: This expects a unique domain in domain file. Multiple entries will fail
+        . ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
+        . ;
+        . ; check DNS domain and ip address
+        . I 'HLDOMP D
+        .. ;
+        .. ;initialize variable, HLDOMP("FLAG")
+        .. S HLDOMP("FLAG")=0
+        .. I ARY("SAF-DOMAIN")]"" D
+        ... ;
+        ... ; match DNS domain
+        ... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
+        ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
+        ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
+        ... ;
+        ... ; match ip address
+        ... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D  Q
+        .... S HLDOMP("FLAG")=1
+        .... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
+        .. Q:HLDOMP("FLAG")=1
+        .. ; quit if 1st component defined
+        .. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1)
+        .. Q:ARY("SAF-COMPONENT1")]""
+        .. S:ERR="" ERR="Receiving Facility mismatch."
+        . ; patch HL*1.6*120 end
+        . ;
+        .Q:HLDOMP=$P(HLPARAM,U)  ;This is local app to app
+        .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
+        .I $G(HLNK) S ARY("LL")=HLNK
+        ;
+PID     ;Validate processing ID
+        I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID"
+        S HLPID=$P(HLPARAM,U,3) ;site param
+        S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
+        ;If message is 'debug' then event driver must be 'debug.'
+        ;If message is 'test' or 'production', then site param must match
+        I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
+        I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
+        ;
+SEC     ;Validate security field - access code and electronic signature
+        I ($P($G(HLN(773)),"^",3)) D
+        .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH))
+        .S X=$$UPPER^HLFNC(X)
+        .D ^XUSHSH
+        .I X="",(MSA="") S:(ERR="") ERR="Invalid access code" Q
+        .S ARY("DUZ")=0
+        .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
+        .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
+        .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
+        .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH),3) I (X'="") D
+        ..S X1=$G(^VA(200,ARY("DUZ"),20))
+        ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
+        ..S X=$$UPPER^HLFNC(X)
+        ..D HASH^XUSHSHP
+        ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
+        ..S ARY("ESIG")=$P(X1,"^",2)
+        I $D(ARY) M HLREC=ARY
+        Q
+HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ; splitted from HLTPCK2A
+ ; to be called from HLTPCK2A
+ ;
+MS ;Check for Message Structure Code
+ I $G(ARY("MTN_ETN"))'="" D
+ . S ARY("MTP_ETP")=0
+ . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
+ . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
+ ;
+ ;Get server and client Protocols
+MSA ;if ack, then get information and quit, we don't need to respond
+ I $G(MSA)]"" D  Q
+ . ;Message is an acknowledgement, find original message
+ . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
+ . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q
+ . F  S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
+ . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q
+ . ;get subscriber protocol and ack. to (show if this is an ack to an ack)
+ . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
+ . ;if no subscriber protocol then response msg. is invalid
+ . I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
+ . ;get message text ien in file 772 and server protocol, 'EID'
+ . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
+ . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
+ . D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+ ;
+ ;Find Server Protocol - based on sending application, message type,
+ ;event type and version ID
+ I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
+ ;
+ ;Find Server Protocol - based on sending application, message type,
+ ;and version ID
+ I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
+ ;
+ I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
+ ;Find Client Protocol - in ITEM multiple of Server Protocol
+ S ARY("EIDS")=0
+ F  S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:'ARY("EIDS")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP"))
+ I 'ARY("EIDS") S ERR="Invalid Receiving Application for this Event" Q
+ D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+ ;
+LLP ;Get logical link pointer
+ S ARY("LL")=$P($G(HLN(770)),"^",7)
+ ;
+FAC ;Get sending/rec facility, validate if necessary
+ ;
+ S HLCS=$E(ECH,1) ;Get component separator
+ S ARY("RAF")=$$P^HLTPCK2(.HDR,6) ;Receiving Facility
+ S ARY("SAF")=$$P^HLTPCK2(.HDR,4) ;Sending Facility
+ ;Get sending/receiving facility from Application Parameter file(771)
+ S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
+ S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
+ ;Sending/Receiving facility required?
+ S X=$G(^ORD(101,ARY("EIDS"),773))
+ S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
+RF ;Validate Receiving Facility
+ I HLRFREQ D
+ .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility"
+ .I HL771RF]"" D  Q
+ ..;Facility data in 771 overrides data in site paramter file
+ ..Q
+ .;Check against local default value (site parameters)
+ .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
+ .;
+ .; patch HL*1.6*120 start
+ .; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D  Q
+ . I $P(ARY("RAF"),HLCS,3)="DNS" D  Q
+ .. N ERROR,HLDOMP1,HLDOMP2
+ .. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+ .. S HLDOMP1=$P(ARY("RAF"),HLCS,2)
+ .. ;
+ .. ; assume the format is <domain>:<port #>
+ .. I HLDOMP1[":" S ARY("RAF-PORT")=$P(HLDOMP1,":",2)
+ .. S HLDOMP1=$P(HLDOMP1,":")
+ .. S ARY("RAF-DOMAIN")=HLDOMP1
+ .. ;
+ .. ; if first piece of domain is "HL7." or "MPI.", remove it
+ .. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D
+ ... S HLDOMP1=$P(HLDOMP1,".",2,99)
+ .. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+ .. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
+ .. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q
+ .. ;
+ .. ; check DNS domain and ip address
+ .. ;initialize variable, HLDOMP("FLAG")
+ .. S HLDOMP("FLAG")=0
+ .. I ARY("RAF-DOMAIN")]"" D
+ ... ;
+ ... ; match DNS domain
+ ... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
+ ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
+ ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
+ ... ;
+ ... ; match ip address
+ ... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
+ .. Q:HLDOMP("FLAG")=1
+ .. I $P(ARY("RAF"),HLCS)=HLINSTN Q
+ .. ;
+ .. S:ERR="" ERR="Receiving Facility mismatch."
+ . I $P(ARY("RAF"),HLCS)=HLINSTN Q
+ . S:ERR="" ERR="Receiving Facility mismatch."
+ ; patch HL*1.6*120 end
+ ;
+SF ;Validate Sending Facility
+ I HLSFREQ D
+ .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility"
+ .I HL771SF]"" D  Q
+ ..;Check for facility data in 771
+ ..Q
+ .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
+ .;If so, use this instead of Protocol definition for return path
+ .;
+ .; patch HL*1.6*120 start
+ . N HLDOMP
+ . ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+ . S HLDOMP=$P(ARY("SAF"),HLCS,2)
+ . ;
+ . ; assume the format is <domain>:<port #>
+ . I HLDOMP[":" S ARY("SAF-PORT")=$P(HLDOMP,":",2)
+ . S HLDOMP=$P(HLDOMP,":")
+ . S ARY("SAF-DOMAIN")=HLDOMP
+ . ;
+ . ; if first piece of domain is "HL7." or "MPI.", remove it
+ . I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D
+ .. S HLDOMP=$P(HLDOMP,".",2,99)
+ . S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+ .;Note: This expects a unique domain in domain file. Multiple entries will fail
+ . ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
+ . ;
+ . ; check DNS domain and ip address
+ . I 'HLDOMP D
+ .. ;
+ .. ;initialize variable, HLDOMP("FLAG")
+ .. S HLDOMP("FLAG")=0
+ .. I ARY("SAF-DOMAIN")]"" D
+ ... ;
+ ... ; match DNS domain
+ ... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
+ ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
+ ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
+ ... ;
+ ... ; match ip address
+ ... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D  Q
+ .... S HLDOMP("FLAG")=1
+ .... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
+ .. Q:HLDOMP("FLAG")=1
+ .. ; quit if 1st component defined
+ .. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1)
+ .. Q:ARY("SAF-COMPONENT1")]""
+ .. S:ERR="" ERR="Receiving Facility mismatch."
+ . ; patch HL*1.6*120 end
+ . ;
+ .Q:HLDOMP=$P(HLPARAM,U)  ;This is local app to app
+ .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
+ .I $G(HLNK) S ARY("LL")=HLNK
+ ;
+PID ;Validate processing ID
+ I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID"
+ S HLPID=$P(HLPARAM,U,3) ;site param
+ S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
+ ;If message is 'debug' then event driver must be 'debug.'
+ ;If message is 'test' or 'production', then site param must match
+ I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
+ I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
+ ;
+SEC ;Validate security field - access code and electronic signature
+ I ($P($G(HLN(773)),"^",3)) D
+ .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH))
+ .S X=$$UPPER^HLFNC(X)
+ .D ^XUSHSH
+ .I X="",(MSA="") S:(ERR="") ERR="Invalid access code" Q
+ .S ARY("DUZ")=0
+ .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
+ .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
+ .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
+ .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH),3) I (X'="") D
+ ..S X1=$G(^VA(200,ARY("DUZ"),20))
+ ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
+ ..S X=$$UPPER^HLFNC(X)
+ ..D HASH^XUSHSHP
+ ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
+ ..S ARY("ESIG")=$P(X1,"^",2)
+ I $D(ARY) M HLREC=ARY
+ Q

Context Navigation

Legend:

Download in other formats: