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

HLCSTCP2.m

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