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.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
;;1.6;HEALTH LEVEL SEVEN;**17,35,57,66,68**;Oct 13, 1995
;THIS ROUTINE CONTAINS IHS MODFICIATION BY IHS/TUC/DLR 01/11/96
Q
;
EN(HLD0,HLD1) ; This routine will send a Message from the Out Queue to the
; MailGroup Specified in the Logical Link file (#870). It is called
; from HLCSMM1 routine that monitors the queue for a link. The MM LLP
; uses <CR> stuffing to indicate the end of segments. The message
; will use the following format within the XMB global.
; ^XMB(3.9,..1)=Segment 1
; ^XMB(3.9,..2)="" - End of segment 1
; ^XMB(3.9,..3)=Segment 2
; ^XMB(3.9,..4)=Continuation of segment 2
; ^XMB(3.9,..5)="" - End of segment 2
; " "
; This processing will enable segment greater than 245.
;
; INPUT : HLD0 - IEN of Logical Link file (#870)
; : HLD1 - IEN of OutQueue Mutiple (Message)
;
; OUTPUT: NONE
;
N HLI,HLI0,HLSERV,HLFAC,HLERR,HLOGLINK,HLMSTXT,HLPARENT,HLPTXT,HLPARM
;
S HLOGLINK=$G(^HLCS(870,HLD0,0))
;-- get MailMan LLP parameters
S HLPARM=$G(^HLCS(870,HLD0,100))
;-- facility
;----- BEGIN IHS MODIFICATION
;IHS/TUC/DLR 01/11/96 - replace VA call with IHS call
;LINE COMMENTED OUT AND REPLACED BY NEW LINE
;S HLFAC=$P($$SITE^VASITE,"^",2)
S HLFAC=$P($$SITE^HLZFUNC,"^",2)
;----- END IHS MODIFICATION
I HLFAC="" S HLFAC="Unknown"
;-- date
D NOW^%DTC S Y=% X ^DD("DD") S HLDT=Y
;-- logical link name
S HLDAN=$P(HLOGLINK,U)
;
;-- Build MailMan variables
;
NEWMM ;Patch 66-introduce new Mailman API's
N XMSUB,XMTO,XMINSTR
I '$G(DUZ) N DUZ D DUZ^XUP(.5)
S XMSUB="HL7 Msg "_HLDT_" from "_HLFAC,XMSUB=$E(XMSUB,1,65)
S XMTO="G."_$P(^XMB(3.8,$P(HLPARM,U),0),U)
S XMINSTR("FROM")=.5
S XMINSTR("ADDR FLAGS")="R" ; Ignore any restrictions (domain closed or protected by security key)
D SENDMSG^XMXAPI(DUZ,XMSUB,"^HLCS(870,HLD0,2,HLD1,1)",XMTO,.XMINSTR)
;-- Set message status to 'done'
S $P(^HLCS(870,HLD0,2,HLD1,0),"^",2)="D"
I $G(XMERR) D ERROR
Q
ERROR ;-- send Mail Message indicating error
Q:'$G(XMERR)
Q:'$D(^TMP("XMERR",$J))
N HLX,HLY,HLZ,HLPARAM,XMSUB,XMTO,XMINSTR
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.
K ^TMP($J,"HLERR")
S HLNXST="ERROR" D STATUS^HLCSMM1(HLNXST) H 1
S HLPARAM=$$PARAM^HLCS2,XMTO("G."_$P(HLPARAM,U,8))="",XMTO(.5)=""
S (HLX,HLZ)=0
F S HLX=$O(^TMP("XMERR",$J,HLX)) Q:'HLX D
. S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=""
. S HLY=0
. F S HLY=$O(^TMP("XMERR",$J,HLX,"TEXT",HLY)) Q:'HLY D
. . S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=$G(^TMP("XMERR",$J,HLX,"TEXT",HLY))
. I $D(^TMP("XMERR",$J,HLX,"PARAM","VALUE")) S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=^TMP("XMERR",$J,HLX,"PARAM","VALUE")
S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)=""
S HLZ=HLZ+1,^TMP($J,"HLERR",HLZ)="HL7 Logical Link: "_$G(HLDAN)
S XMSUB="Error handing HL7 message off to Mailman"
S XMINSTR("FROM")="POSTMASTER" ; msg will appear new, nomatter who receives it.
D SENDMSG^XMXAPI(DUZ,XMSUB,"^TMP($J,""HLERR"")",.XMTO,.XMINSTR)
K ^TMP($J,"HLERR"),XMERR,^TMP("XMERR",$J)
Q
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
+2 ;;1.6;HEALTH LEVEL SEVEN;**17,35,57,66,68**;Oct 13, 1995
+3 ;THIS ROUTINE CONTAINS IHS MODFICIATION BY IHS/TUC/DLR 01/11/96
+4 QUIT
+5 ;
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
+2 ; from HLCSMM1 routine that monitors the queue for a link. The MM LLP
+3 ; uses <CR> stuffing to indicate the end of segments. The message
+4 ; will use the following format within the XMB global.
+5 ; ^XMB(3.9,..1)=Segment 1
+6 ; ^XMB(3.9,..2)="" - End of segment 1
+7 ; ^XMB(3.9,..3)=Segment 2
+8 ; ^XMB(3.9,..4)=Continuation of segment 2
+9 ; ^XMB(3.9,..5)="" - End of segment 2
+10 ; " "
+11 ; This processing will enable segment greater than 245.
+12 ;
+13 ; INPUT : HLD0 - IEN of Logical Link file (#870)
+14 ; : HLD1 - IEN of OutQueue Mutiple (Message)
+15 ;
+16 ; OUTPUT: NONE
+17 ;
+18 NEW HLI,HLI0,HLSERV,HLFAC,HLERR,HLOGLINK,HLMSTXT,HLPARENT,HLPTXT,HLPARM
+19 ;
+20 SET HLOGLINK=$GET(^HLCS(870,HLD0,0))
+21 ;-- get MailMan LLP parameters
+22 SET HLPARM=$GET(^HLCS(870,HLD0,100))
+23 ;-- facility
+24 ;----- BEGIN IHS MODIFICATION
+25 ;IHS/TUC/DLR 01/11/96 - replace VA call with IHS call
+26 ;LINE COMMENTED OUT AND REPLACED BY NEW LINE
+27 ;S HLFAC=$P($$SITE^VASITE,"^",2)
+28 SET HLFAC=$PIECE($$SITE^HLZFUNC,"^",2)
+29 ;----- END IHS MODIFICATION
+30 IF HLFAC=""
SET HLFAC="Unknown"
+31 ;-- date
+32 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET HLDT=Y
+33 ;-- logical link name
+34 SET HLDAN=$PIECE(HLOGLINK,U)
+35 ;
+36 ;-- Build MailMan variables
+37 ;
NEWMM ;Patch 66-introduce new Mailman API's
+1 NEW XMSUB,XMTO,XMINSTR
+2 IF '$GET(DUZ)
NEW DUZ
DO DUZ^XUP(.5)
+3 SET XMSUB="HL7 Msg "_HLDT_" from "_HLFAC
SET XMSUB=$EXTRACT(XMSUB,1,65)
+4 SET XMTO="G."_$PIECE(^XMB(3.8,$PIECE(HLPARM,U),0),U)
+5 SET XMINSTR("FROM")=.5
+6 ; Ignore any restrictions (domain closed or protected by security key)
SET XMINSTR("ADDR FLAGS")="R"
+7 DO SENDMSG^XMXAPI(DUZ,XMSUB,"^HLCS(870,HLD0,2,HLD1,1)",XMTO,.XMINSTR)
+8 ;-- Set message status to 'done'
+9 SET $PIECE(^HLCS(870,HLD0,2,HLD1,0),"^",2)="D"
+10 IF $GET(XMERR)
DO ERROR
+11 QUIT
ERROR ;-- send Mail Message indicating error
+1 IF '$GET(XMERR)
QUIT
+2 IF '$DATA(^TMP("XMERR",$JOB))
QUIT
+3 NEW HLX,HLY,HLZ,HLPARAM,XMSUB,XMTO,XMINSTR
+4 ; Want to make sure this message is sent. It won't be if DUZ is not a valid user.
NEW DUZ
DO DUZ^XUP(.5)
+5 KILL ^TMP($JOB,"HLERR")
+6 SET HLNXST="ERROR"
DO STATUS^HLCSMM1(HLNXST)
HANG 1
+7 SET HLPARAM=$$PARAM^HLCS2
SET XMTO("G."_$PIECE(HLPARAM,U,8))=""
SET XMTO(.5)=""
+8 SET (HLX,HLZ)=0
+9 FOR
SET HLX=$ORDER(^TMP("XMERR",$JOB,HLX))
IF 'HLX
QUIT
Begin DoDot:1
+10 SET HLZ=HLZ+1
SET ^TMP($JOB,"HLERR",HLZ)=""
+11 SET HLY=0
+12 FOR
SET HLY=$ORDER(^TMP("XMERR",$JOB,HLX,"TEXT",HLY))
IF 'HLY
QUIT
Begin DoDot:2
+13 SET HLZ=HLZ+1
SET ^TMP($JOB,"HLERR",HLZ)=$GET(^TMP("XMERR",$JOB,HLX,"TEXT",HLY))
End DoDot:2
+14 IF $DATA(^TMP("XMERR",$JOB,HLX,"PARAM","VALUE"))
SET HLZ=HLZ+1
SET ^TMP($JOB,"HLERR",HLZ)=^TMP("XMERR",$JOB,HLX,"PARAM","VALUE")
End DoDot:1
+15 SET HLZ=HLZ+1
SET ^TMP($JOB,"HLERR",HLZ)=""
+16 SET HLZ=HLZ+1
SET ^TMP($JOB,"HLERR",HLZ)="HL7 Logical Link: "_$GET(HLDAN)
+17 SET XMSUB="Error handing HL7 message off to Mailman"
+18 ; msg will appear new, nomatter who receives it.
SET XMINSTR("FROM")="POSTMASTER"
+19 DO SENDMSG^XMXAPI(DUZ,XMSUB,"^TMP($J,""HLERR"")",.XMTO,.XMINSTR)
+20 KILL ^TMP($JOB,"HLERR"),XMERR,^TMP("XMERR",$JOB)
+21 QUIT
