HLMA2 ;AISC/SAW-Message Administration Module ;09/23/2005 17:45
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,64,65,76,82,91,94,109,120**;Oct 13, 1995;Build 12
; References to ^ORD(101) supported by IA# 1373.
;
SEND(EIDS,MTIEN,CLIENT,PRIORITY,MTIENS,LOGLINK) ;
;Entry point to create
;an entry in the Message Administrator and Message Text
;files for a message that is about to be sent to a recipient
;
;This is a subroutine call with parameter passing. It returns a value
;in the variable MTIENS with 1 to 3 pieces separated by uparrows
;as follows: MTIENS^error code^error description
;If no error occurs, only the first piece is returned equal to the IEN
;the entry created in the Message Text or Administration file.
;Otherwise, three pieces are returned with the first piece equal to 0
;
;All the following input parameters are required
; EIDS = The IEN from the Protocol file of the subscriber event
; MTIEN = The IEN from the Message Text file created when the
; GENERATE^HLMA or GENACK^HLMA1 entry points were invoked
; CLIENT = The IEN of the client (subscriber) application from
; the Application Parameter file
;PRIORITY = I for immediate or D for deferred
; MTIENS = The variable that will be returned to the calling
; application as described above
;Optional parameter
; LOGLINK = The IEN of the logical link from the Logical Link file
;
; ACK = 1 or 0 to indicate if original message or response-passed
; by ^HLCS
;
; Save passed parameters for restore... HL*1.6*94
N HL94P
;
; patch HL*1.6*120 start
; save the receiving facility from HLSUP("S") variable in routine ADD^HLCS2
I $G(MTIENS("REC-FACILITY"))]"" D
. S HLP("REC-FACILITY")=MTIENS("REC-FACILITY")
; F HL94P="CONTPTR","NAMESPACE","SECURITY","SUBSCRIBER" D
F HL94P="CONTPTR","NAMESPACE","SECURITY","SUBSCRIBER","PMOD","REC-FACILITY" D
. QUIT:'$D(HLP(HL94P)) ;->
. MERGE HL94P(HL94P)=HLP(HL94P)
; patch HL*1.6*120 end
;
;Check for required parameters
S MTIENS=""
I '$G(EIDS)!('$G(MTIEN))!('$G(CLIENT))!("ID"'[$E($G(PRIORITY))) S MTIENS="0^7^"_$G(^HL(771.7,7,0))_" at SEND^HLMA entry point" G EXIT
;Get message ID and Message Text IEN
N HLJ,HLHDRBLD,HLMIDS,HLDTS,HLDT1S,HLP,REPLYTO,SERVER,X
;
; Restore parameters if needed... HL*1.6*94
S HL94P=""
F S HL94P=$O(HL94P(HL94P)) Q:HL94P']"" D
. MERGE HLP(HL94P)=HL94P(HL94P)
;
;check if LL is TCP
I $G(LOGLINK) D Q:MTIENS!($G(HLERROR)]"")
. ;quit if it is not TCP
. Q:$P(^HLCS(870,LOGLINK,0),U,3)'=4
. ;create client in 773, MTIENS=ien in 773
. S (MTIENS,HLTCP)=$$MA^HLTF(MTIEN,.HLMIDS)
.;
.;**109
.; F L +^HLMA(MTIENS):1 Q:$T H 1
.;
. D MIDAR(HLMIDS)
. ;get info from parent (772)
. S X=^HL(772,MTIEN,0),HLTYPE=$P(X,U,14),SERVER=$P(X,U,2),REPLYTO=$P(X,U,7)
. ;get ack timeout override
. S:$P($G(^HL(772,MTIEN,"P")),U,7) HLP("ACKTIME")=+$P(^("P"),U,7)
. ;get message type and event type from protocol
. S X=$G(^ORD(101,EIDS,770)),HLP("MTYPE")=$P(X,U,11),HLP("EVENT")=$P(X,U,4),HLP("HLTCPI")=MTIENS
. S:$P(X,U,5) HLP("MTYPE_EVENT")=$P(X,U,5)
. ;update date in client (773)
. D UPDATE^HLTF0(MTIENS,"","O",EIDS,CLIENT,SERVER,"D",REPLYTO,"",.HLP)
. ;create header for message in 773
. I (HLTYPE="M") D HEADER^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
. I (HLTYPE'="M") D BHSHDR^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
. ;if error set status to ERROR DURING TRANSMISSION
. I ($G(HLERROR)'="") D Q
..;**109**
..; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIENS)
.. D STATUS^HLTF0(MTIENS,4,12,HLERROR)
..;
.. S MTIENS="0^12^"_$G(^HL(771.7,12,0))_" in HLCSHDR1"
.. Q
. ;do we still need MTIEN=ien of file 772
. S MTIEN=""
. ;update status of 773 to PENDING TRANSMISSION
. D STATUS^HLTF0(MTIENS,1)
. ;set header, HLHDR and Logical Link in 773
. K HLJ
. S X=MTIENS_",",HLJ(773,X,7)=LOGLINK,HLJ(773,X,200)="HLHDR"
. D FILE^HLDIE("","HLJ","","SEND","HLMA2") ;HL*1.6*109
.D ENQUE^HLCSREP(LOGLINK,"O",MTIENS)
.;
.;**109
.; L -^HLMA(MTIENS)
;
;if not TCP get msg. ID
S HLMIDS=$P($G(^HL(772,MTIEN,0)),"^",6)
;create child message
D CREATE^HLTF(.HLMIDS,.MTIENS,.HLDTS,.HLDT1S),MIDAR(HLMIDS)
;Link new Message Text file entry to MTIENG entry and update fields
;on zero node
D UPDATE^HLTF0(MTIENS,MTIEN,"O",EIDS,CLIENT,"",PRIORITY,"",$S($G(LOGLINK):LOGLINK,1:""))
EXIT Q
;
MIDAR(X) ;update HLMIDAR array with X=message id
Q:$G(X)=""
I 'HLMIDAR S HLMIDAR("N")=1,HLMIDAR=X Q
S HLMIDAR(HLMIDAR("N"))=X,HLMIDAR("N")=HLMIDAR("N")+1
Q
;
DC ;direct connect
N CLIENT,EIDS,HLMIDS,LOGLINK,MTIEN,MTIENS,POP,HLHDR,HLHDRO,HLMSA,REPLYTO,SERVER,X,HLTCPI
N HLCSOUT,HLDBACK,HLDBSIZE,HLDP,HLDREAD,HLDRETR,HLDWAIT,HLMSG,HLOS,HLPORT,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPO,HLTCPORT,HLRESP,HLTYPE,HLRETRA,HLRETRY,HLTCPRET
S (EIDS,LOGLINK)="",MTIEN=HLMTIEN
I $D(HLL("LINKS")) D
. S EIDS=$P(HLL("LINKS",1),U),LOGLINK=$P(HLL("LINKS",1),U,2)
. K HLL("LINKS")
. Q:EIDS="" I EIDS<1 S EIDS=$O(^ORD(101,"B",EIDS,0))
. Q:LOGLINK="" I LOGLINK<1 S LOGLINK=$O(^HLCS(870,"B",LOGLINK,0))
. S CLIENT=+$$PTR^HLUTIL2(EIDS)
I 'LOGLINK!'EIDS D
. S EIDS=+$O(^ORD(101,HLEID,775,0)) Q:'EIDS S EIDS=$P($G(^(EIDS,0)),U)
. S X=$$PTR^HLUTIL2(EIDS),CLIENT=$P(X,U),LOGLINK=$P(X,U,2)
I 'EIDS S HLERROR="15^Invalid Subscriber for Immediate connection" Q
I 'LOGLINK S HLERROR="15^Invalid Logical Link for Immediate connection" Q
I CLIENT<0 S HLERROR="15^Invalid Subscriber Protocol for Immediate connection" Q
;open connection
I '$$DCOPEN^HLCSTCP(LOGLINK) S HLERROR="15^Connection Failed" Q
;create client in 773
S HLDP=LOGLINK,(MTIENS,HLTCP,HLTCPI,HLMSG)=$$MA^HLTF(MTIEN,.HLMIDS)
;
; patch HL*1.6*120 start
S HLMIDAR("HLMID")=$G(HLMIDS)
S HLMIDAR("IEN773")=MTIENS
; patch HL*1.6*120 end
;
;**109**
;F L +^HLMA(MTIENS):1 Q:$T H 1
;
;get info from parent (772)
S X=^HL(772,MTIEN,0),HLTYPE=$P(X,U,14),SERVER=$P(X,U,2),REPLYTO=$P(X,U,7)
;get ack timeout override
S:$P($G(^HL(772,MTIEN,"P")),U,7) HLP("ACKTIME")=+$P(^("P"),U,7)
;get message type and event type from protocol
S X=$G(^ORD(101,EIDS,770)),HLP("MTYPE")=$P(X,U,11),HLP("EVENT")=$P(X,U,4),HLP("HLTCPI")=MTIENS
S:$P(X,U,5) HLP("MTYPE_EVENT")=$P(X,U,5)
;update date in client (773)
D UPDATE^HLTF0(MTIENS,"","O",EIDS,CLIENT,SERVER,"I",REPLYTO,"",.HLP)
;create header for message in 773
I (HLTYPE="M") D HEADER^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
I (HLTYPE'="M") D BHSHDR^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
;if error set status to ERROR DURING TRANSMISSION
I ($G(HLERROR)'="") D Q
.;
.;**109**
.; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIENS)
. D STATUS^HLTF0(MTIENS,4,12,HLERROR)
.;
. S MTIENS="0^12^"_$G(^HL(771.7,12,0))_" in HLCSHDR1"
.;
.;**109**
.; L -^HLMA(HLMSG) D MON^HLCSTCP("Idle")
. D MON^HLCSTCP("Idle")
.;
. Q
;set header, HLHDR and Logical Link in 773
K HLJ S X=MTIENS_",",HLJ(773,X,7)=LOGLINK,HLJ(773,X,200)="HLHDR"
;
D FILE^HLDIE("","HLJ","","DC","HLMA2") ; HL*1.6*109
;
;**109**
D LLCNT^HLCSTCP(LOGLINK,3)
;
D DCSEND^HLCSTCP2
G EXIT2:'$G(HLRESP)
;X=ien in 773^ien in 772 for response
S X=HLRESP D INIT^HLTP3A ;patch HL*1.6*109 - hltp3 routine split
D:'$G(HL) STATUS^HLTF0(HLMTIENS,3,,,1)
S HLMTIENR=HLMTIEN
D EXIT^HLTP3
EXIT2 ;
;**109**
;L -^HLMA(HLMSG)
Q
HLMA2 ;AISC/SAW-Message Administration Module ;09/23/2005 17:45
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,64,65,76,82,91,94,109,120**;Oct 13, 1995;Build 12
+2 ; References to ^ORD(101) supported by IA# 1373.
+3 ;
SEND(EIDS,MTIEN,CLIENT,PRIORITY,MTIENS,LOGLINK) ;
+1 ;Entry point to create
+2 ;an entry in the Message Administrator and Message Text
+3 ;files for a message that is about to be sent to a recipient
+4 ;
+5 ;This is a subroutine call with parameter passing. It returns a value
+6 ;in the variable MTIENS with 1 to 3 pieces separated by uparrows
+7 ;as follows: MTIENS^error code^error description
+8 ;If no error occurs, only the first piece is returned equal to the IEN
+9 ;the entry created in the Message Text or Administration file.
+10 ;Otherwise, three pieces are returned with the first piece equal to 0
+11 ;
+12 ;All the following input parameters are required
+13 ; EIDS = The IEN from the Protocol file of the subscriber event
+14 ; MTIEN = The IEN from the Message Text file created when the
+15 ; GENERATE^HLMA or GENACK^HLMA1 entry points were invoked
+16 ; CLIENT = The IEN of the client (subscriber) application from
+17 ; the Application Parameter file
+18 ;PRIORITY = I for immediate or D for deferred
+19 ; MTIENS = The variable that will be returned to the calling
+20 ; application as described above
+21 ;Optional parameter
+22 ; LOGLINK = The IEN of the logical link from the Logical Link file
+23 ;
+24 ; ACK = 1 or 0 to indicate if original message or response-passed
+25 ; by ^HLCS
+26 ;
+27 ; Save passed parameters for restore... HL*1.6*94
+28 NEW HL94P
+29 ;
+30 ; patch HL*1.6*120 start
+31 ; save the receiving facility from HLSUP("S") variable in routine ADD^HLCS2
+32 IF $GET(MTIENS("REC-FACILITY"))]""
Begin DoDot:1
+33 SET HLP("REC-FACILITY")=MTIENS("REC-FACILITY")
End DoDot:1
+34 ; F HL94P="CONTPTR","NAMESPACE","SECURITY","SUBSCRIBER" D
+35 FOR HL94P="CONTPTR","NAMESPACE","SECURITY","SUBSCRIBER","PMOD","REC-FACILITY"
Begin DoDot:1
+36 ;->
IF '$DATA(HLP(HL94P))
QUIT
+37 MERGE HL94P(HL94P)=HLP(HL94P)
End DoDot:1
+38 ; patch HL*1.6*120 end
+39 ;
+40 ;Check for required parameters
+41 SET MTIENS=""
+42 IF '$GET(EIDS)!('$GET(MTIEN))!('$GET(CLIENT))!("ID"'[$EXTRACT($GET(PRIORITY)))
SET MTIENS="0^7^"_$GET(^HL(771.7,7,0))_" at SEND^HLMA entry point"
GOTO EXIT
+43 ;Get message ID and Message Text IEN
+44 NEW HLJ,HLHDRBLD,HLMIDS,HLDTS,HLDT1S,HLP,REPLYTO,SERVER,X
+45 ;
+46 ; Restore parameters if needed... HL*1.6*94
+47 SET HL94P=""
+48 FOR
SET HL94P=$ORDER(HL94P(HL94P))
IF HL94P']""
QUIT
Begin DoDot:1
+49 MERGE HLP(HL94P)=HL94P(HL94P)
End DoDot:1
+50 ;
+51 ;check if LL is TCP
+52 IF $GET(LOGLINK)
Begin DoDot:1
+53 ;quit if it is not TCP
+54 IF $PIECE(^HLCS(870,LOGLINK,0),U,3)'=4
QUIT
+55 ;create client in 773, MTIENS=ien in 773
+56 SET (MTIENS,HLTCP)=$$MA^HLTF(MTIEN,.HLMIDS)
+57 ;
+58 ;**109
+59 ; F L +^HLMA(MTIENS):1 Q:$T H 1
+60 ;
+61 DO MIDAR(HLMIDS)
+62 ;get info from parent (772)
+63 SET X=^HL(772,MTIEN,0)
SET HLTYPE=$PIECE(X,U,14)
SET SERVER=$PIECE(X,U,2)
SET REPLYTO=$PIECE(X,U,7)
+64 ;get ack timeout override
+65 IF $PIECE($GET(^HL(772,MTIEN,"P")),U,7)
SET HLP("ACKTIME")=+$PIECE(^("P"),U,7)
+66 ;get message type and event type from protocol
+67 SET X=$GET(^ORD(101,EIDS,770))
SET HLP("MTYPE")=$PIECE(X,U,11)
SET HLP("EVENT")=$PIECE(X,U,4)
SET HLP("HLTCPI")=MTIENS
+68 IF $PIECE(X,U,5)
SET HLP("MTYPE_EVENT")=$PIECE(X,U,5)
+69 ;update date in client (773)
+70 DO UPDATE^HLTF0(MTIENS,"","O",EIDS,CLIENT,SERVER,"D",REPLYTO,"",.HLP)
+71 ;create header for message in 773
+72 IF (HLTYPE="M")
DO HEADER^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
+73 IF (HLTYPE'="M")
DO BHSHDR^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
+74 ;if error set status to ERROR DURING TRANSMISSION
+75 IF ($GET(HLERROR)'="")
Begin DoDot:2
+76 ;**109**
+77 ; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIENS)
+78 DO STATUS^HLTF0(MTIENS,4,12,HLERROR)
+79 ;
+80 SET MTIENS="0^12^"_$GET(^HL(771.7,12,0))_" in HLCSHDR1"
+81 QUIT
End DoDot:2
QUIT
+82 ;do we still need MTIEN=ien of file 772
+83 SET MTIEN=""
+84 ;update status of 773 to PENDING TRANSMISSION
+85 DO STATUS^HLTF0(MTIENS,1)
+86 ;set header, HLHDR and Logical Link in 773
+87 KILL HLJ
+88 SET X=MTIENS_","
SET HLJ(773,X,7)=LOGLINK
SET HLJ(773,X,200)="HLHDR"
+89 ;HL*1.6*109
DO FILE^HLDIE("","HLJ","","SEND","HLMA2")
+90 DO ENQUE^HLCSREP(LOGLINK,"O",MTIENS)
+91 ;
+92 ;**109
+93 ; L -^HLMA(MTIENS)
End DoDot:1
IF MTIENS!($GET(HLERROR)]"")
QUIT
+94 ;
+95 ;if not TCP get msg. ID
+96 SET HLMIDS=$PIECE($GET(^HL(772,MTIEN,0)),"^",6)
+97 ;create child message
+98 DO CREATE^HLTF(.HLMIDS,.MTIENS,.HLDTS,.HLDT1S)
DO MIDAR(HLMIDS)
+99 ;Link new Message Text file entry to MTIENG entry and update fields
+100 ;on zero node
+101 DO UPDATE^HLTF0(MTIENS,MTIEN,"O",EIDS,CLIENT,"",PRIORITY,"",$SELECT($GET(LOGLINK):LOGLINK,1:""))
EXIT QUIT
+1 ;
MIDAR(X) ;update HLMIDAR array with X=message id
+1 IF $GET(X)=""
QUIT
+2 IF 'HLMIDAR
SET HLMIDAR("N")=1
SET HLMIDAR=X
QUIT
+3 SET HLMIDAR(HLMIDAR("N"))=X
SET HLMIDAR("N")=HLMIDAR("N")+1
+4 QUIT
+5 ;
DC ;direct connect
+1 NEW CLIENT,EIDS,HLMIDS,LOGLINK,MTIEN,MTIENS,POP,HLHDR,HLHDRO,HLMSA,REPLYTO,SERVER,X,HLTCPI
+2 NEW HLCSOUT,HLDBACK,HLDBSIZE,HLDP,HLDREAD,HLDRETR,HLDWAIT,HLMSG,HLOS,HLPORT,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPO,HLTCPORT,HLRESP,HLTYPE,HLRETRA,HLRETRY,HLTCPRET
+3 SET (EIDS,LOGLINK)=""
SET MTIEN=HLMTIEN
+4 IF $DATA(HLL("LINKS"))
Begin DoDot:1
+5 SET EIDS=$PIECE(HLL("LINKS",1),U)
SET LOGLINK=$PIECE(HLL("LINKS",1),U,2)
+6 KILL HLL("LINKS")
+7 IF EIDS=""
QUIT
IF EIDS<1
SET EIDS=$ORDER(^ORD(101,"B",EIDS,0))
+8 IF LOGLINK=""
QUIT
IF LOGLINK<1
SET LOGLINK=$ORDER(^HLCS(870,"B",LOGLINK,0))
+9 SET CLIENT=+$$PTR^HLUTIL2(EIDS)
End DoDot:1
+10 IF 'LOGLINK!'EIDS
Begin DoDot:1
+11 SET EIDS=+$ORDER(^ORD(101,HLEID,775,0))
IF 'EIDS
QUIT
SET EIDS=$PIECE($GET(^(EIDS,0)),U)
+12 SET X=$$PTR^HLUTIL2(EIDS)
SET CLIENT=$PIECE(X,U)
SET LOGLINK=$PIECE(X,U,2)
End DoDot:1
+13 IF 'EIDS
SET HLERROR="15^Invalid Subscriber for Immediate connection"
QUIT
+14 IF 'LOGLINK
SET HLERROR="15^Invalid Logical Link for Immediate connection"
QUIT
+15 IF CLIENT<0
SET HLERROR="15^Invalid Subscriber Protocol for Immediate connection"
QUIT
+16 ;open connection
+17 IF '$$DCOPEN^HLCSTCP(LOGLINK)
SET HLERROR="15^Connection Failed"
QUIT
+18 ;create client in 773
+19 SET HLDP=LOGLINK
SET (MTIENS,HLTCP,HLTCPI,HLMSG)=$$MA^HLTF(MTIEN,.HLMIDS)
+20 ;
+21 ; patch HL*1.6*120 start
+22 SET HLMIDAR("HLMID")=$GET(HLMIDS)
+23 SET HLMIDAR("IEN773")=MTIENS
+24 ; patch HL*1.6*120 end
+25 ;
+26 ;**109**
+27 ;F L +^HLMA(MTIENS):1 Q:$T H 1
+28 ;
+29 ;get info from parent (772)
+30 SET X=^HL(772,MTIEN,0)
SET HLTYPE=$PIECE(X,U,14)
SET SERVER=$PIECE(X,U,2)
SET REPLYTO=$PIECE(X,U,7)
+31 ;get ack timeout override
+32 IF $PIECE($GET(^HL(772,MTIEN,"P")),U,7)
SET HLP("ACKTIME")=+$PIECE(^("P"),U,7)
+33 ;get message type and event type from protocol
+34 SET X=$GET(^ORD(101,EIDS,770))
SET HLP("MTYPE")=$PIECE(X,U,11)
SET HLP("EVENT")=$PIECE(X,U,4)
SET HLP("HLTCPI")=MTIENS
+35 IF $PIECE(X,U,5)
SET HLP("MTYPE_EVENT")=$PIECE(X,U,5)
+36 ;update date in client (773)
+37 DO UPDATE^HLTF0(MTIENS,"","O",EIDS,CLIENT,SERVER,"I",REPLYTO,"",.HLP)
+38 ;create header for message in 773
+39 IF (HLTYPE="M")
DO HEADER^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
+40 IF (HLTYPE'="M")
DO BHSHDR^HLCSHDR1(MTIENS,CLIENT,.HLERROR)
+41 ;if error set status to ERROR DURING TRANSMISSION
+42 IF ($GET(HLERROR)'="")
Begin DoDot:1
+43 ;
+44 ;**109**
+45 ; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIENS)
+46 DO STATUS^HLTF0(MTIENS,4,12,HLERROR)
+47 ;
+48 SET MTIENS="0^12^"_$GET(^HL(771.7,12,0))_" in HLCSHDR1"
+49 ;
+50 ;**109**
+51 ; L -^HLMA(HLMSG) D MON^HLCSTCP("Idle")
+52 DO MON^HLCSTCP("Idle")
+53 ;
+54 QUIT
End DoDot:1
QUIT
+55 ;set header, HLHDR and Logical Link in 773
+56 KILL HLJ
SET X=MTIENS_","
SET HLJ(773,X,7)=LOGLINK
SET HLJ(773,X,200)="HLHDR"
+57 ;
+58 ; HL*1.6*109
DO FILE^HLDIE("","HLJ","","DC","HLMA2")
+59 ;
+60 ;**109**
+61 DO LLCNT^HLCSTCP(LOGLINK,3)
+62 ;
+63 DO DCSEND^HLCSTCP2
+64 IF '$GET(HLRESP)
GOTO EXIT2
+65 ;X=ien in 773^ien in 772 for response
+66 ;patch HL*1.6*109 - hltp3 routine split
SET X=HLRESP
DO INIT^HLTP3A
+67 IF '$GET(HL)
DO STATUS^HLTF0(HLMTIENS,3,,,1)
+68 SET HLMTIENR=HLMTIEN
+69 DO EXIT^HLTP3
EXIT2 ;
+1 ;**109**
+2 ;L -^HLMA(HLMSG)
+3 QUIT
