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

HLZTCP.m

Go to the documentation of this file. 
  1. HLZTCP ;MILW/JMC - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;5/18/99  15:42 [ 04/02/2003   8:37 AM ]
  1.  ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
  1.  ;;1.5;HEALTH LEVEL SEVEN;;JUL 09, 1993
  1.  ;
  1. INIT ;Initialize Variables
  1.  ;REDIRECTED BY FROM HLLP IF IOT IS A CHANNEL DEVICE 08/19/02
  1.  ;I.E. TERMINAL TYPE = CHAN
  1.  N HLZIO,HLZOS,HLZSTATE
  1.  ;S HLZOS=^%ZPSF("OS")
  1.  ;BEGIN IHS MODE **1004** IHS/ITSC/TPF
  1.  S HLZOS=$$VERSION^%ZOSV(1)   ;e.g. Cache for Windows NT (Intel)
  1.  ;                                  MSM for RedHat Linux
  1.  ;END IHS MOD **1004**
  1.  ;
  1.  ;I $D(ZTQUEUED) S ZTREQ="@"
  1.  ;
  1.  I $$NEWERR^%ZTER N $ETRAP S $ETRAP=""
  1.  S X="ERR^HLZTCP",@^%ZOSF("TRAP")
  1.  ;
  1.  I '$D(HLION) D  Q:POP
  1.  . D HOME^%ZIS
  1.  . I POP Q
  1.  . S HLION=$S(ION']"":"UNKNOWN",1:ION)
  1.  ;
  1.  S HLZIO(0)=IO
  1.  ;
  1.  ; Figure out type of connection: 1=Server, 2=Client.
  1.  I HLZOS["DSM" S HLZTCP=$S(IOPAR["ADDRESS":2,1:1)
  1.  I HLZOS["Cache" D
  1.  . N IP
  1.  . S IP=$P(IOPAR,"""",2) ; Extract IP address
  1.  . S HLZTCP=$S(IP?1.3N1P1.3N1P1.3N1P1.3N:2,1:1)
  1.  ;
  1.  ;BEGIN IHS MODE **1004** CHECK FOR MSM SYSTEM  IHS/ITSC/TPF 08/19/02
  1.  I HLZOS["MSM" D
  1.  .S IOP=HLION
  1.  .S %ZIS="N"  ;TROUBLE GETTING 'NO OPEN' TO WORK.
  1.  .D ^%ZIS
  1.  .D ^%ZISC    ;DEVICE 56 STILL OPENED SO HAD TO CLOSE
  1.  .;USE 'USE PARAMETERS' IN DEVICE FILE TO PARSE IP AND PORT
  1.  .S IP=$TR($P($P(IOUPAR,"(",2),","),"""")
  1.  .S PORT=$P($P(IOUPAR,")"),",",2)
  1.  .D CALL^%ZISTCP(IP,PORT,30)
  1.  ;END IHS MOD **1004**
  1.  ;
  1.  S IOP="NULL DEVICE" D ^%ZIS
  1.  I POP G EXIT
  1.  S HLZIO=IO K IOP
  1.  ;
  1.  S HLTIME=$$NOW^XLFDT
  1.  ;
  1.  ;U HLZIO(0)
  1.  ; If TCP client, send a "space" to initiate connection.
  1.  ;I HLZTCP=2 W " ",!
  1.  ;BEGIN IHS MOD **1004** REPLACES THREE LINES ABOVE
  1.  ;IHS/ITSC/TPF 08/19/02 I FOUND THE FOLLOWING THREE LINES
  1.  ;NOT NEEDED FOR MSM CONNECTION
  1.  I HLZOS'["MSM" D
  1.  .U HLZIO(0)
  1.  .; If TCP client, send a "space" to initiate connection.
  1.  .I HLZTCP=2 W " ",!
  1.  ;END IHS MOD **1004**
  1.  ;
  1.  K %,%H,%I,X
  1.  S DTIME=$P($G(HLNDAP0),"^",9),HLTRIES=$P($G(HLNDAP0),"^",5)
  1.  S:DTIME'>0 DTIME=60 S:HLTRIES'>0 HLTRIES=3
  1.  S HLLPC=^%ZOSF("LPC")
  1.  ;
  1.  ;
  1. LOOP ; Infinite loop to check for HL7 messages to send/receive
  1.  F  D  I $$S^%ZTLOAD S ZTSTOP=1 Q
  1.  . S HLLOG=$S($D(^HL(770,"ALOG",HLION)):1,1:0)
  1.  . D CHKREC,CHKSEND
  1. EXIT Q
  1.  ;
  1. ERR ; Trap error
  1.  ; Reset current device to "NULL DEVICE".
  1.  U:$G(HLZIO)'="" HLZIO
  1.  ; Reschedule task.
  1.  I $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ") D
  1.  . N ZTDTH,ZTSK
  1.  . S ZTSK=ZTQUEUED,ZTDTH="60S",ZTREQ=""
  1.  . D REQ^%ZTLOAD ; Requeue task in 60 seconds.
  1.  K HLL(1),^TMP("HLR",$J),^TMP("HLS",$J)
  1.  Q
  1.  ;
  1. CHKREC ; Check if there are HL7 messages to receive
  1.  ; Set flag to receive state.
  1.  S HLZSTATE="recv"
  1.  D REC
  1.  ; Received "NAK" message don't know what it goes to.
  1.  I $G(HLZNAK) K HLERR Q 
  1.  I '$D(HLDTOUT),'HLERR D SENDNAK G CHKREC
  1.  I '$D(HLDTOUT) U HLZIO K HLERR D ^HLCHK
  1.  U HLZIO
  1.  Q
  1.  ;
  1. CHKSEND ; Check if there are HL7 messages to send
  1.  ; Set flag to send state.
  1.  S HLZSTATE="send"
  1.  Q:'$D(HLNDAP)
  1.  I '$D(HLNDAP0) S HLNDAP0=$G(^HL(770,HLNDAP,0))
  1.  S HLDA=+$O(^HL(772,"AC","O",+$P(HLNDAP0,U,12),0)) G:'HLDA EX
  1.  S HLDA0=$G(^HL(772,HLDA,0)) G:HLDA0']"" EX
  1.  S HLXMZ=+$P(HLDA0,"^",5)
  1.  I 'HLXMZ D  G EX
  1.  . D STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
  1.  I '$D(^XMB(3.9,HLXMZ)) D  G EX
  1.  . D STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
  1.  I '$O(^XMB(3.9,HLXMZ,2,0)) D  G EX
  1.  . D STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
  1.  S (HLI,HLTRIED)=0,HLSDT=+HLDA0
  1.  F HLJ=1:1 S HLI=$O(^XMB(3.9,HLXMZ,2,HLI)) Q:HLI'>0  S ^TMP("HLS",$J,HLSDT,HLJ)=$G(^XMB(3.9,HLXMZ,2,HLI,0))
  1. CS1 ;
  1.  S HLTRIED=HLTRIED+1
  1.  K ^TMP("HLR",$J),HLSDATA
  1.  D SEND
  1.  ; Set flag to awaiting acknowledgement state.
  1.  S HLZSTATE="awaiting ack"
  1.  D REC
  1.  I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:HLZNAK
  1.  G EX:$D(HLDTOUT)
  1.  I HLZNAK D  G EX
  1.  . S HLAC=4,HLMSG="Lower Level Protocol Error - "_$S($E(HLL(1))="X":"Checksum",1:"Character Count")_" Did Not Match"
  1.  . D STATUS^HLTF0(HLDA,HLAC,HLMSG)
  1.  I $S('$D(HLL(1)):1,"BHS,MSH"'[$E(HLL(1),1,3):1,1:0) D  G EX
  1.  . S HLAC=4,HLMSG="Application Level error - Header Segment Missing"
  1.  . D STATUS^HLTF0(HLDA,HLAC,HLMSG)
  1.  K HLXMZ
  1.  U HLZIO
  1.  D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
  1.  ;
  1. EX K HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,HLSDATA,HLSDT,HLTRIED
  1.  K ^TMP("HLS",$J),^TMP("HLR",$J)
  1.  Q
  1.  ;
  1. CSUM ;Calculate Checksum
  1.  S HLC1=HLC1+$L(X),X=X_HLC2 X HLLPC S HLC2=$C(Y)
  1.  Q
  1.  ;
  1. REC ;Receive a Message
  1.  S %=$$NOW^XLFDT
  1.  I HLTIME<% S HLTIME=%
  1.  E  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  I HLLOG F  Q:'$D(^TMP("HL",HLION,HLTIME))  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  K HLL,^TMP("HLR",$J)
  1.  S (HLC2,X0)="",(HLC1,HLI,HLK,HLZEB,HLZNAK)=0
  1.  U HLZIO(0)
  1.  F  R X1#1:DTIME Q:X1=$C(11)  I '$T S HLDTOUT=1 Q
  1.  ; Did not find "Start of block" character.
  1.  I X1'=$C(11) Q
  1.  S X0=X1,HLZLEN=1
  1. REC1 ;
  1.  U HLZIO(0) K HLDTOUT
  1.  R X1#1:DTIME I '$T S HLDTOUT=1
  1.  ; Timed out and buffer empty.
  1.  I $G(HLDTOUT),'$L(X1) Q
  1.  ;
  1.  S X0=X0_X1,HLZLEN=HLZLEN+1
  1.  ; Set "NAK" block type flag.
  1.  I X1="N",HLZLEN=2 S HLZNAK=1
  1.  ; Set "End Block" flag.
  1.  I X1=$C(28) S HLZEB=1
  1.  I X1'=$C(13) G REC1
  1.  I HLZEB,HLZNAK D RECNAK Q
  1.  ;
  1.  ; Process "End Block" if not a "NAK" record.
  1.  I HLZEB S HLC=+$E(X0,6,8),HLB=+$E(X0,1,5),X0=""
  1.  I $L(X0) D
  1.  . I HLLOG D  ;Record Incoming Transmission in Log
  1.  . . S HLII=X0 S:$P(X0,$E(X0,5))="MSH" $P(X0,$E(X0,5),8)=""
  1.  . . S HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=$TR(X0,$C(11,13)),X0=HLII
  1.  . I HLK,HLK'>2 S HLL(HLK)=$TR(X0,$C(11,13))
  1.  . I HLK S ^TMP("HLR",$J,HLTIME,HLK)=$TR(X0,$C(11,13))
  1.  . S HLK=HLK+1,X=X0 D CSUM
  1.  . S X0=""
  1.  I 'HLZEB G REC1
  1.  S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
  1.  I HLLOG S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
  1.  Q
  1.  ;
  1. RECNAK ; Process Received "NAK" message.
  1.  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  S HLC=+$E(X0,7,9),HLB=+$E(X0,2,6),X=$E(X0,1) D CSUM
  1.  S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
  1.  S HLL(1)=$TR(X0,$C(11,13,28)),^TMP("HLR",$J,HLTIME,1)=HLL(1)
  1.  I HLLOG D
  1.  . S ^TMP("HL",HLION,HLTIME,"REC",1)=HLL(1)
  1.  . S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
  1.  Q
  1.  ;
  1. SEND ;Send a Message
  1.  N X,Y
  1.  S %=$$NOW^XLFDT
  1.  I HLTIME<% S HLTIME=%
  1.  E  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  I HLLOG F  Q:'$D(^TMP("HL",HLION,HLTIME))  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  S (HLI,HLC1)=0,HLC2=""
  1.  D WRITE($C(11)_"D21"_$C(13))
  1.  I '$D(HLSDT) F  S HLI=$O(HLSDATA(HLI)) Q:HLI=""  D WRITE(HLSDATA(HLI)_$C(13))
  1.  I $D(HLSDT) F  S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI=""  S HLSDATA=^(HLI) D WRITE(HLSDATA_$C(13))
  1.  D FLUSH
  1.  Q
  1.  ;
  1. SENDNAK ; Send a "NAK" message.
  1.  S (HLC1,HLI)=0,HLC2="",HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
  1.  D WRITE($C(11)_"N21"_$C(13)_HLERR)
  1.  D FLUSH
  1.  K HLSDATA,HLERR
  1.  Q
  1.  ;
  1. WRITE(X) ; Write data in buffer.
  1.  U HLZIO(0)
  1.  W X,!
  1.  I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$TR(X,$C(11,13))
  1.  D CSUM
  1.  Q
  1.  ;
  1. FLUSH ; Write checksum and flush buffer.
  1.  S X=HLC2 X HLLPC S X=$E("0000",1,(5-$L(HLC1)))_HLC1_$E("00",1,(3-$L(Y)))_Y_$C(28)_$C(13)
  1.  U HLZIO(0)
  1.  ; Do final write for this block and flush buffer.
  1.  W X,!
  1.  I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$TR(X,$C(11,13,28))
  1.  Q