Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLCSMM

HLCSMM.m

Go to the documentation of this file. 
  1. HLCSMM ;ISC/MTC-Create Mail Message and Entry in the HL7 Transmission File ;11/03/2000  08:53 [ 04/02/2003   8:37 AM ]
  1.  ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
  1.  ;;1.6;HEALTH LEVEL SEVEN;**17,35,57,66,68**;Oct 13, 1995
  1.  ;THIS ROUTINE CONTAINS IHS MODFICIATION BY IHS/TUC/DLR 01/11/96
  1.  Q
  1.  ;
  1. EN(HLD0,HLD1) ; This routine will send a Message from the Out Queue to the
  1.  ; MailGroup Specified in the Logical Link file (#870). It is called
  1.  ; from HLCSMM1 routine that monitors the queue for a link. The MM LLP
  1.  ; uses <CR> stuffing to indicate the end of segments. The message
  1.  ; will use the following format within the XMB global.
  1.  ;  ^XMB(3.9,..1)=Segment 1
  1.  ;  ^XMB(3.9,..2)=""  - End of segment 1
  1.  ;  ^XMB(3.9,..3)=Segment 2
  1.  ;  ^XMB(3.9,..4)=Continuation of segment 2
  1.  ;  ^XMB(3.9,..5)=""  - End of segment 2
  1.  ; "             "
  1.  ; This processing will enable segment greater than 245.
  1.  ;
  1.  ; INPUT :  HLD0 - IEN of Logical Link file (#870)
  1.  ;       :  HLD1 - IEN of OutQueue Mutiple (Message)
  1.  ;
  1.  ; OUTPUT:  NONE
  1.  ;
  1.  N HLI,HLI0,HLSERV,HLFAC,HLERR,HLOGLINK,HLMSTXT,HLPARENT,HLPTXT,HLPARM
  1.  ;
  1.  S HLOGLINK=$G(^HLCS(870,HLD0,0))
  1.  ;-- get MailMan LLP parameters
  1.  S HLPARM=$G(^HLCS(870,HLD0,100))
  1.  ;-- facility
  1.  ;----- BEGIN IHS MODIFICATION
  1.  ;IHS/TUC/DLR 01/11/96 - replace VA call with IHS call
  1.  ;LINE COMMENTED OUT AND REPLACED BY NEW LINE
  1.  ;S HLFAC=$P($$SITE^VASITE,"^",2)
  1.  S HLFAC=$P($$SITE^HLZFUNC,"^",2)
  1.  ;----- END IHS MODIFICATION
  1.  I HLFAC="" S HLFAC="Unknown"
  1.  ;-- date
  1.  D NOW^%DTC S Y=% X ^DD("DD") S HLDT=Y
  1.  ;-- logical link name
  1.  S HLDAN=$P(HLOGLINK,U)
  1.  ;
  1.  ;-- Build MailMan variables
  1.  ;
  1. NEWMM ;Patch 66-introduce new Mailman API's
  1.  N XMSUB,XMTO,XMINSTR
  1.  I '$G(DUZ) N DUZ D DUZ^XUP(.5)
  1.  S XMSUB="HL7 Msg "_HLDT_" from "_HLFAC,XMSUB=$E(XMSUB,1,65)
  1.  S XMTO="G."_$P(^XMB(3.8,$P(HLPARM,U),0),U)
  1.  S XMINSTR("FROM")=.5
  1.  S XMINSTR("ADDR FLAGS")="R" ; Ignore any restrictions (domain closed or protected by security key)
  1.  D SENDMSG^XMXAPI(DUZ,XMSUB,"^HLCS(870,HLD0,2,HLD1,1)",XMTO,.XMINSTR)
  1.  ;-- Set message status to 'done'
  1.  S $P(^HLCS(870,HLD0,2,HLD1,0),"^",2)="D"
  1.  I $G(XMERR) D ERROR
  1.  Q 
  1. ERROR ;-- send Mail Message indicating error
  1.  Q:'$G(XMERR)
  1.  Q:'$D(^TMP("XMERR",$J))
  1.  N HLX,HLY,HLZ,HLPARAM,XMSUB,XMTO,XMINSTR
  1.  N DUZ D DUZ^XUP(.5) ; Want to make sure this message is sent.  It won't be if DUZ is not a valid user.
  1.  K ^TMP($J,"HLERR")
  1.  S HLNXST="ERROR" D STATUS^HLCSMM1(HLNXST) H 1
  1.  S HLPARAM=$$PARAM^HLCS2,XMTO("G."_$P(HLPARAM,U,8))="",XMTO(.5)=""
  1.  S (HLX,HLZ)=0
  1.  F  S HLX=$O(^TMP("XMERR",$J,HLX)) Q:'HLX  D
  1.  . S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=""
  1.  . S HLY=0
  1.  . F  S HLY=$O(^TMP("XMERR",$J,HLX,"TEXT",HLY)) Q:'HLY  D
  1.  . . S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=$G(^TMP("XMERR",$J,HLX,"TEXT",HLY))
  1.  . I $D(^TMP("XMERR",$J,HLX,"PARAM","VALUE")) S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=^TMP("XMERR",$J,HLX,"PARAM","VALUE")
  1.  S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=""
  1.  S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)="HL7 Logical Link: "_$G(HLDAN)
  1.  S XMSUB="Error handing HL7 message off to Mailman"
  1.  S XMINSTR("FROM")="POSTMASTER" ; msg will appear new, nomatter who receives it.
  1.  D SENDMSG^XMXAPI(DUZ,XMSUB,"^TMP($J,""HLERR"")",.XMTO,.XMINSTR)
  1.  K ^TMP($J,"HLERR"),XMERR,^TMP("XMERR",$J)
  1.  Q