INHUVUTX ; cmi/flag/maw - DGH,FRW,CHEM,WAB 06 Aug 1999 14:39 Generic TCP/IP socket utilities ; [ 05/14/2002 1:26 PM ]
;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002
;COPYRIGHT 1991-2000 SAIC
;
;
NEXT(INDEST,INPRI,INHOR,INPEND) ;Return next transaction in the queue for destination
Q $$NEXT^INHUVUT3(INDEST,.INPRI,.INHOR,.INPEND)
;
SEND(INUIF,INIPPO,INIP) ;Send a message from INTHU to a socket
;More Generic 16-Apr-99 because it
;1) includes INIP variables for message framing.
;2) encrypts outgoing messages if the encryption flag is on.
;INPUT:
; INTHU=entry in ^INTHU
; INIPPO=socket
; INIP=array containing parameters (PBR). Key parameters are:
; INIP("SOM")= start of message
; INIP("EOL")=end of line (end of segment)
; INIP("EOM")=end of message
; INIP("CRYPT")=encryption flag
; INIP("DESKEY")=DES key
;OUTPUT:
;0 if successful, 1 if error
N %,LCT,LINE,EOL,I,INDELIM,INBUF,INCRYPT,INFIRST,INLAST
S EOL=INIP("EOL"),INDELIM=$$FIELD^INHUT(),INFIRST=1
;Set maximum string length dependent upon whether encryption is on
S INMAX=$S('INIP("CRYPT"):508,1:328),INBUF=""
;Write message
;;NOTE: APCOTS requested we concatenate "^" to end of segment.
S (%,LCT)=0 F D GETLINE^INHOU(INUIF,.LCT,.LINE) Q:'$D(LINE) D
.I $D(LINE)<10 D
..;remove control characters if they exist
..I LINE?.E1C.E S LINE=$$NOCTRL^INHUTIL(LINE)
..S LINE=LINE_INDELIM
.;copy main line
.S X=$$PACK^INCRYP(LINE,INMAX,.INBUF)
.;Don't send unless X has length
.I $L(X) D
..S %=%+1
..I INIP("CRYPT") D
... S INLAST=$S($D(LINE)>9:0,$D(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
... D ENCRYPT^INCRYPT(X,.INCRYPT,$L(X),INFIRST,INLAST)
... S X=INCRYPT,INFIRST=0
..;SOM needed for first packet
..S:%=1 X=INIP("SOM")_X
..D SEND^%INET(X,INIPPO,1)
..;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
.;Copy overflow nodes
.F I=1:1 Q:'$D(LINE(I)) D
..;remove control characters if they exist
..I LINE(I)?.E1C.E S LINE(I)=$$NOCTRL^INHUTIL(LINE(I))
..;If no line following set delim at end
..I '$D(LINE(I+1)) S LINE(I)=LINE(I)_INDELIM
..S X=$$PACK^INCRYP(LINE(I),INMAX,.INBUF)
..;don't send unless X has length
..Q:'$L(X)
..S %=%+1
..I INIP("CRYPT") D
... S INLAST=$S($D(LINE(I+1)):0,$D(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
... D ENCRYPT^INCRYPT(X,.INCRYPT,$L(X),INFIRST,INLAST)
... S X=INCRYPT,INFIRST=0
..S:%=1 X=INIP("SOM")_X
..D SEND^%INET(X,INIPPO,1)
..;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
.;Add segment terminator to this line
.S X=$$PACK^INCRYP(INIP("EOL"),INMAX,.INBUF)
.Q:'$L(X)
.S %=%+1
.I INIP("CRYPT") D
.. S INLAST=$S($D(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
.. D ENCRYPT^INCRYPT(X,.INCRYPT,$L(X),INFIRST,INLAST)
.. S X=INCRYPT,INFIRST=0
.S:%=1 X=INIP("SOM")_X
.D SEND^%INET(X,INIPPO,1)
.;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
;If there's no encryption, send what's in buffer and quit
S X=INBUF
S:$L(X) %=%+1
I $L(X),INIP("CRYPT") D
. D ENCRYPT^INCRYPT(X,.INCRYPT,$L(X),INFIRST,1)
. S X=INCRYPT,INFIRST=0
S X=$S(%=1:INIP("SOM"),1:"")_X_INIP("EOM")_INIP("EOL")
D SEND^%INET(X,INIPPO,1)
;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
D:$G(INDEBUG) LOG^INHVCRA1("Message "_$G(INUIF)_" sent.",5)
Q 0
;
SENDSTR(STR,INIPPO) ;Sends a initiation string to socket
;INPUT:
; STR = initiation string (such as $C(11))
; INIPPO=socket
;Write initiation
D SEND^%INET(STR,INIPPO,1)
;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
Q
;
;Tags OPEN, ADDR, PORT are used to find and open a socket
OPEN(INBPN,INCHNL,INERR,INMEM) ;Open socket for destination
;INPUT:
; INBPN = background process file
; INCHNL=channel opened (1st param)
; INMEM=memory location (2nd)
; INERR=error array
;
N INOUT
S INOUT=$$OPEN^INHUVUT2(INBPN,.INCHNL,.INERR,.INMEM)
Q INOUT
;
;---tags RECEIVE, PARSE, R2 read entries from socket
RECEIVE(INV,INCHNL,INIP,INERR,INMEM) ;Read socket
;16-Apr-1999 Added support for decryption of incoming messages
;if the encryption flag is set.
;INPUT
; INV=Location to store message, pass by reference
; INCHNL=socket
; INIP=array of parameters, PBR
; INERR=error array, PBR
; INMEM=not used (placeholder. %INET secondary memory)
;OUTPUT
;0=ok, 1=no response at all, 2=failure in middle of receive
;3=remote system disconnected
; Note: the check for remote system disconnect is based on a string
; match from utility routine %INET. If that utility is changed, this
; must also be changed.
;
N NULLREAD,NORESP,RTO,AP,APDONE,API,APREC,X,REM,INSMIN,REC,INERRREC,INSOM,INEOM,INMS,INREC
S RTO=INIP("RTO"),INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)
;Set defaults
S INDEBUG=1 ;cmi/maw turned debug on
S INSOM=INIP("SOM"),INEOM=INIP("EOM")
;;Following must change for X12
S INDELIM=$$FIELD^INHUT()
D:$G(INDEBUG) LOG^INHVCRA1("Receiving from socket.",5)
; load socket input into INREC (or into ^UTILITY("INREC")
S (APDONE,APREC,AP)="",(NULLREAD,NORESP)=0,INREC="REC"
K @INREC
F D Q:APDONE!NORESP
.D RECV^%INET(.APREC,.INCHNL,RTO,1)
.;D RECV^%INET(.APREC,.INCHNL,RTO,1,$G(INBPN)) ;maw cache
.I 'AP,$L(APREC),INIP("NOSOM"),APREC'[INSOM S AP=1 ;S APREC=INSOM_APREC ;FOR APCOTS NAKS
. I $G(APREC)="VQACK" S APREC=INSOM_APREC S APDONE=1 ;cmi/maw added for X12
.;check for remote disconnect
.I $G(APREC(0))["Remote end disconnect" S APDONE=3 Q
.;Check for SOM at start of message.
.I 'AP,$L(APREC),APREC'[INSOM D
..S INERRREC=$$CLEAN(APREC),APREC=""
..S INMS="Data Fragmentation error, no SOM. Ignored: "_$E(INERRREC,1,196)
..D ENR^INHE(INBPN,INMS) D:$G(INDEBUG) LOG^INHVCRA1(INMS,3)
.;Check for multiple SOM's after 1st msg (socket read).
.I AP,APREC[INSOM D
..N X S X=$L(APREC,INSOM),AP=AP+1,@INREC@(AP)=$$CLEAN($P(APREC,INSOM,1,X-1))
..S APREC=INSOM_$P(APREC,INSOM,X)
..K INMS S INMS(1)="Data Fragmentation error, Multiple SOMs. Ignored: "
..S INMS(2)=APREC
..D ENR^INHE(INBPN,.INMS) D:$G(INDEBUG) LOG^INHVCRA1(.INMS,3)
..K @INREC,INMS S AP=0
.;Check for multiple SOM's in 1st msg.
.I 'AP,$L(APREC,INSOM)>2 D
..N X S X=$L(APREC,INSOM)
..S INERRREC=$$CLEAN($P(APREC,INSOM,1,X-1)),APREC=INSOM_$P(APREC,INSOM,X)
..S INMS="Data Fragmentation error, mult SOM. Ignored: "_$E(INERRREC,1,196)
..D ENR^INHE(INBPN,INMS) D:$G(INDEBUG) LOG^INHVCRA1(INMS,3)
.;Use AP as flag, not a true counter.
.I 'AP,APREC[INSOM S AP=1 D:$E(APREC)'=INSOM ;
..S INERRREC=$$CLEAN($P(APREC,INSOM)),APREC=INSOM_$P(APREC,INSOM,2)
..S INMS="Data Fragmentation error, data before SOM. Ignored: "_$E(INERRREC,1,196)
..D ENR^INHE(INBPN,INMS) D:$G(INDEBUG) LOG^INHVCRA1(INMS,3)
.;Check for data after EOM
.I APREC[INEOM D
..S INERRREC=$P(APREC,INEOM,2,$L(APREC,INEOM)),APREC=$P(APREC,INEOM)_INEOM
..Q:(INERRREC=INIP("EOL"))!'$L(INERRREC) S INERRREC=$$CLEAN(INERRREC)
..S INMS="Data Fragmentation error, data past EOM. Ignored string: "_$E(INERRREC,1,196)
..D ENR^INHE(INBPN,INMS) D:$G(INDEBUG) LOG^INHVCRA1(INMS,3)
.I APREC=""!(APREC[INEOM) S APDONE=1
.;Remove message framing characters from packet
.S APREC=$TR(APREC,INSOM_INEOM)
.;Check for no response from remote system after NNN tries
.I '$L(APREC) D Q
..D WAIT^INHUVUT2(INBPN,INIP("RHNG"),"Reading socket",.NORESP) Q:NORESP
..S NULLREAD=NULLREAD+1 S:NULLREAD>INIP("RTRY") NORESP=1
.;If encryption is on, call decryption
.I $G(INIP("CRYPT")) D
..D DECRYPT^INCRYPT(APREC,.X,$L(APREC),$S(AP=1:1,1:0),$S(APDONE:1,1:0))
..S APREC=X
.I $S<INSMIN D
..Q:INREC["^"
..K ^UTILITY("INREC",$J)
..M ^UTILITY("INREC",$J)=@INREC K @INREC S INREC="^UTILITY(""INREC"","_$J_")"
.S AP=AP+1,@INREC@(AP)=APREC
;If remote end disconnected
I APDONE=3 S INERR=$G(APREC(0)) Q APDONE
;If No message was received
I 'AP S INERR="No message received from remote system on receiver "_$P($G(^INTHPC(INBPN,0)),U) Q 1
;If remote system timed-out log error
I NORESP S INERR="Remote system on "_$P($G(^INTHPC(INBPN,0)),U)_" timed out during transmission of message "_$P($G(@INREC@(1)),$G(INDELIM),10) Q 2
D PARSE^INHUVUT1
K @INREC
Q 0
;
PARSE ;Parse INREC array (raw message) into ING array (HL7 segments).
;PARSE tag moved to INHUVUT1 because routine size is too large
D PARSE^INHUVUT1 Q
;
INIT(INBPN,INIP) ; Intialize parameters
D INIT^INHUVUT1(INBPN,.INIP)
Q
;
ASCII(X) ;Converts a string into an ASCII string
Q $$ASCII^INHUVUT1(X)
;
ADDR(INBPN,INIPADIE,INERR) ;Get next IP address from Background Proc file
Q $$ADDR^INHUVUT2(.INBPN,.INIPADIE,.INERR)
;
CPORT(INBPN,INIPADIE,INIPPOIE) ;Get next client port from Background Proc. file
Q $$CPORT^INHUVUT2(.INBPN,.INIPADIE,.INIPPOIE)
;
SPORT(INBPN,INIPADIE,INERR) ;Get next server port from Background Prc. file
Q $$SPORT^INHUVUT2(.INBPN,.INIPADIE,.INERR)
;
WAIT(INBPN,HNG,STAT,STOP) ;Hang function which periodically checks ^INRHB
D WAIT^INHUVUT2(.INBPN,.HNG,.STAT,.STOP) ; Called by INHV*
Q
CLEAN(X) ; Clean out control characters
N I,Y S Y=""
F I=1:1:$L(X) D Q:$L(Y)>234
.I $A(X,I)<32!($A(X,I)>127) S Y=Y_"["_$A(X,I)_"]" Q
.S Y=Y_$E(X,I)
Q Y
DB() ;
Q 0
INHUVUTX ; cmi/flag/maw - DGH,FRW,CHEM,WAB 06 Aug 1999 14:39 Generic TCP/IP socket utilities ; [ 05/14/2002 1:26 PM ]
+1 ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ;
NEXT(INDEST,INPRI,INHOR,INPEND) ;Return next transaction in the queue for destination
+1 QUIT $$NEXT^INHUVUT3(INDEST,.INPRI,.INHOR,.INPEND)
+2 ;
SEND(INUIF,INIPPO,INIP) ;Send a message from INTHU to a socket
+1 ;More Generic 16-Apr-99 because it
+2 ;1) includes INIP variables for message framing.
+3 ;2) encrypts outgoing messages if the encryption flag is on.
+4 ;INPUT:
+5 ; INTHU=entry in ^INTHU
+6 ; INIPPO=socket
+7 ; INIP=array containing parameters (PBR). Key parameters are:
+8 ; INIP("SOM")= start of message
+9 ; INIP("EOL")=end of line (end of segment)
+10 ; INIP("EOM")=end of message
+11 ; INIP("CRYPT")=encryption flag
+12 ; INIP("DESKEY")=DES key
+13 ;OUTPUT:
+14 ;0 if successful, 1 if error
+15 NEW %,LCT,LINE,EOL,I,INDELIM,INBUF,INCRYPT,INFIRST,INLAST
+16 SET EOL=INIP("EOL")
SET INDELIM=$$FIELD^INHUT()
SET INFIRST=1
+17 ;Set maximum string length dependent upon whether encryption is on
+18 SET INMAX=$SELECT('INIP("CRYPT"):508,1:328)
SET INBUF=""
+19 ;Write message
+20 ;;NOTE: APCOTS requested we concatenate "^" to end of segment.
+21 SET (%,LCT)=0
FOR
DO GETLINE^INHOU(INUIF,.LCT,.LINE)
IF '$DATA(LINE)
QUIT
Begin DoDot:1
+22 IF $DATA(LINE)<10
Begin DoDot:2
+23 ;remove control characters if they exist
+24 IF LINE?.E1C.E
SET LINE=$$NOCTRL^INHUTIL(LINE)
+25 SET LINE=LINE_INDELIM
End DoDot:2
+26 ;copy main line
+27 SET X=$$PACK^INCRYP(LINE,INMAX,.INBUF)
+28 ;Don't send unless X has length
+29 IF $LENGTH(X)
Begin DoDot:2
+30 SET %=%+1
+31 IF INIP("CRYPT")
Begin DoDot:3
+32 SET INLAST=$SELECT($DATA(LINE)>9:0,$DATA(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
+33 DO ENCRYPT^INCRYPT(X,.INCRYPT,$LENGTH(X),INFIRST,INLAST)
+34 SET X=INCRYPT
SET INFIRST=0
End DoDot:3
+35 ;SOM needed for first packet
+36 IF %=1
SET X=INIP("SOM")_X
+37 DO SEND^%INET(X,INIPPO,1)
+38 ;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
End DoDot:2
+39 ;Copy overflow nodes
+40 FOR I=1:1
IF '$DATA(LINE(I))
QUIT
Begin DoDot:2
+41 ;remove control characters if they exist
+42 IF LINE(I)?.E1C.E
SET LINE(I)=$$NOCTRL^INHUTIL(LINE(I))
+43 ;If no line following set delim at end
+44 IF '$DATA(LINE(I+1))
SET LINE(I)=LINE(I)_INDELIM
+45 SET X=$$PACK^INCRYP(LINE(I),INMAX,.INBUF)
+46 ;don't send unless X has length
+47 IF '$LENGTH(X)
QUIT
+48 SET %=%+1
+49 IF INIP("CRYPT")
Begin DoDot:3
+50 SET INLAST=$SELECT($DATA(LINE(I+1)):0,$DATA(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
+51 DO ENCRYPT^INCRYPT(X,.INCRYPT,$LENGTH(X),INFIRST,INLAST)
+52 SET X=INCRYPT
SET INFIRST=0
End DoDot:3
+53 IF %=1
SET X=INIP("SOM")_X
+54 DO SEND^%INET(X,INIPPO,1)
+55 ;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
End DoDot:2
+56 ;Add segment terminator to this line
+57 SET X=$$PACK^INCRYP(INIP("EOL"),INMAX,.INBUF)
+58 IF '$LENGTH(X)
QUIT
+59 SET %=%+1
+60 IF INIP("CRYPT")
Begin DoDot:2
+61 SET INLAST=$SELECT($DATA(^INTHU(INUIF,3,LCT+1,0)):0,1:1)
+62 DO ENCRYPT^INCRYPT(X,.INCRYPT,$LENGTH(X),INFIRST,INLAST)
+63 SET X=INCRYPT
SET INFIRST=0
End DoDot:2
+64 IF %=1
SET X=INIP("SOM")_X
+65 DO SEND^%INET(X,INIPPO,1)
+66 ;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
End DoDot:1
+67 ;If there's no encryption, send what's in buffer and quit
+68 SET X=INBUF
+69 IF $LENGTH(X)
SET %=%+1
+70 IF $LENGTH(X)
IF INIP("CRYPT")
Begin DoDot:1
+71 DO ENCRYPT^INCRYPT(X,.INCRYPT,$LENGTH(X),INFIRST,1)
+72 SET X=INCRYPT
SET INFIRST=0
End DoDot:1
+73 SET X=$SELECT(%=1:INIP("SOM"),1:"")_X_INIP("EOM")_INIP("EOL")
+74 DO SEND^%INET(X,INIPPO,1)
+75 ;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
+76 IF $GET(INDEBUG)
DO LOG^INHVCRA1("Message "_$GET(INUIF)_" sent.",5)
+77 QUIT 0
+78 ;
SENDSTR(STR,INIPPO) ;Sends a initiation string to socket
+1 ;INPUT:
+2 ; STR = initiation string (such as $C(11))
+3 ; INIPPO=socket
+4 ;Write initiation
+5 DO SEND^%INET(STR,INIPPO,1)
+6 ;D SEND^%INET(X,INIPPO,1,$G(INBPN)) ;maw cache
+7 QUIT
+8 ;
+9 ;Tags OPEN, ADDR, PORT are used to find and open a socket
OPEN(INBPN,INCHNL,INERR,INMEM) ;Open socket for destination
+1 ;INPUT:
+2 ; INBPN = background process file
+3 ; INCHNL=channel opened (1st param)
+4 ; INMEM=memory location (2nd)
+5 ; INERR=error array
+6 ;
+7 NEW INOUT
+8 SET INOUT=$$OPEN^INHUVUT2(INBPN,.INCHNL,.INERR,.INMEM)
+9 QUIT INOUT
+10 ;
+11 ;---tags RECEIVE, PARSE, R2 read entries from socket
RECEIVE(INV,INCHNL,INIP,INERR,INMEM) ;Read socket
+1 ;16-Apr-1999 Added support for decryption of incoming messages
+2 ;if the encryption flag is set.
+3 ;INPUT
+4 ; INV=Location to store message, pass by reference
+5 ; INCHNL=socket
+6 ; INIP=array of parameters, PBR
+7 ; INERR=error array, PBR
+8 ; INMEM=not used (placeholder. %INET secondary memory)
+9 ;OUTPUT
+10 ;0=ok, 1=no response at all, 2=failure in middle of receive
+11 ;3=remote system disconnected
+12 ; Note: the check for remote system disconnect is based on a string
+13 ; match from utility routine %INET. If that utility is changed, this
+14 ; must also be changed.
+15 ;
+16 NEW NULLREAD,NORESP,RTO,AP,APDONE,API,APREC,X,REM,INSMIN,REC,INERRREC,INSOM,INEOM,INMS,INREC
+17 SET RTO=INIP("RTO")
SET INSMIN=$SELECT($PIECE($GET(^INRHSITE(1,0)),U,14):$PIECE(^(0),U,14),1:2500)
+18 ;Set defaults
+19 ;cmi/maw turned debug on
SET INDEBUG=1
+20 SET INSOM=INIP("SOM")
SET INEOM=INIP("EOM")
+21 ;;Following must change for X12
+22 SET INDELIM=$$FIELD^INHUT()
+23 IF $GET(INDEBUG)
DO LOG^INHVCRA1("Receiving from socket.",5)
+24 ; load socket input into INREC (or into ^UTILITY("INREC")
+25 SET (APDONE,APREC,AP)=""
SET (NULLREAD,NORESP)=0
SET INREC="REC"
+26 KILL @INREC
+27 FOR
Begin DoDot:1
+28 DO RECV^%INET(.APREC,.INCHNL,RTO,1)
+29 ;D RECV^%INET(.APREC,.INCHNL,RTO,1,$G(INBPN)) ;maw cache
+30 ;S APREC=INSOM_APREC ;FOR APCOTS NAKS
IF 'AP
IF $LENGTH(APREC)
IF INIP("NOSOM")
IF APREC'[INSOM
SET AP=1
+31 ;cmi/maw added for X12
IF $GET(APREC)="VQACK"
SET APREC=INSOM_APREC
SET APDONE=1
+32 ;check for remote disconnect
+33 IF $GET(APREC(0))["Remote end disconnect"
SET APDONE=3
QUIT
+34 ;Check for SOM at start of message.
+35 IF 'AP
IF $LENGTH(APREC)
IF APREC'[INSOM
Begin DoDot:2
+36 SET INERRREC=$$CLEAN(APREC)
SET APREC=""
+37 SET INMS="Data Fragmentation error, no SOM. Ignored: "_$EXTRACT(INERRREC,1,196)
+38 DO ENR^INHE(INBPN,INMS)
IF $GET(INDEBUG)
DO LOG^INHVCRA1(INMS,3)
End DoDot:2
+39 ;Check for multiple SOM's after 1st msg (socket read).
+40 IF AP
IF APREC[INSOM
Begin DoDot:2
+41 NEW X
SET X=$LENGTH(APREC,INSOM)
SET AP=AP+1
SET @INREC@(AP)=$$CLEAN($PIECE(APREC,INSOM,1,X-1))
+42 SET APREC=INSOM_$PIECE(APREC,INSOM,X)
+43 KILL INMS
SET INMS(1)="Data Fragmentation error, Multiple SOMs. Ignored: "
+44 SET INMS(2)=APREC
+45 DO ENR^INHE(INBPN,.INMS)
IF $GET(INDEBUG)
DO LOG^INHVCRA1(.INMS,3)
+46 KILL @INREC,INMS
SET AP=0
End DoDot:2
+47 ;Check for multiple SOM's in 1st msg.
+48 IF 'AP
IF $LENGTH(APREC,INSOM)>2
Begin DoDot:2
+49 NEW X
SET X=$LENGTH(APREC,INSOM)
+50 SET INERRREC=$$CLEAN($PIECE(APREC,INSOM,1,X-1))
SET APREC=INSOM_$PIECE(APREC,INSOM,X)
+51 SET INMS="Data Fragmentation error, mult SOM. Ignored: "_$EXTRACT(INERRREC,1,196)
+52 DO ENR^INHE(INBPN,INMS)
IF $GET(INDEBUG)
DO LOG^INHVCRA1(INMS,3)
End DoDot:2
+53 ;Use AP as flag, not a true counter.
+54 ;
IF 'AP
IF APREC[INSOM
SET AP=1
IF $EXTRACT(APREC)'=INSOM
Begin DoDot:2
+55 SET INERRREC=$$CLEAN($PIECE(APREC,INSOM))
SET APREC=INSOM_$PIECE(APREC,INSOM,2)
+56 SET INMS="Data Fragmentation error, data before SOM. Ignored: "_$EXTRACT(INERRREC,1,196)
+57 DO ENR^INHE(INBPN,INMS)
IF $GET(INDEBUG)
DO LOG^INHVCRA1(INMS,3)
End DoDot:2
+58 ;Check for data after EOM
+59 IF APREC[INEOM
Begin DoDot:2
+60 SET INERRREC=$PIECE(APREC,INEOM,2,$LENGTH(APREC,INEOM))
SET APREC=$PIECE(APREC,INEOM)_INEOM
+61 IF (INERRREC=INIP("EOL"))!'$LENGTH(INERRREC)
QUIT
SET INERRREC=$$CLEAN(INERRREC)
+62 SET INMS="Data Fragmentation error, data past EOM. Ignored string: "_$EXTRACT(INERRREC,1,196)
+63 DO ENR^INHE(INBPN,INMS)
IF $GET(INDEBUG)
DO LOG^INHVCRA1(INMS,3)
End DoDot:2
+64 IF APREC=""!(APREC[INEOM)
SET APDONE=1
+65 ;Remove message framing characters from packet
+66 SET APREC=$TRANSLATE(APREC,INSOM_INEOM)
+67 ;Check for no response from remote system after NNN tries
+68 IF '$LENGTH(APREC)
Begin DoDot:2
+69 DO WAIT^INHUVUT2(INBPN,INIP("RHNG"),"Reading socket",.NORESP)
IF NORESP
QUIT
+70 SET NULLREAD=NULLREAD+1
IF NULLREAD>INIP("RTRY")
SET NORESP=1
End DoDot:2
QUIT
+71 ;If encryption is on, call decryption
+72 IF $GET(INIP("CRYPT"))
Begin DoDot:2
+73 DO DECRYPT^INCRYPT(APREC,.X,$LENGTH(APREC),$SELECT(AP=1:1,1:0),$SELECT(APDONE:1,1:0))
+74 SET APREC=X
End DoDot:2
+75 IF $STORAGE<INSMIN
Begin DoDot:2
+76 IF INREC["^"
QUIT
+77 KILL ^UTILITY("INREC",$JOB)
+78 MERGE ^UTILITY("INREC",$JOB)=@INREC
KILL @INREC
SET INREC="^UTILITY(""INREC"","_$JOB_")"
End DoDot:2
+79 SET AP=AP+1
SET @INREC@(AP)=APREC
End DoDot:1
IF APDONE!NORESP
QUIT
+80 ;If remote end disconnected
+81 IF APDONE=3
SET INERR=$GET(APREC(0))
QUIT APDONE
+82 ;If No message was received
+83 IF 'AP
SET INERR="No message received from remote system on receiver "_$PIECE($GET(^INTHPC(INBPN,0)),U)
QUIT 1
+84 ;If remote system timed-out log error
+85 IF NORESP
SET INERR="Remote system on "_$PIECE($GET(^INTHPC(INBPN,0)),U)_" timed out during transmission of message "_$PIECE($GET(@INREC@(1)),$GET(INDELIM),10)
QUIT 2
+86 DO PARSE^INHUVUT1
+87 KILL @INREC
+88 QUIT 0
+89 ;
PARSE ;Parse INREC array (raw message) into ING array (HL7 segments).
+1 ;PARSE tag moved to INHUVUT1 because routine size is too large
+2 DO PARSE^INHUVUT1
QUIT
+3 ;
INIT(INBPN,INIP) ; Intialize parameters
+1 DO INIT^INHUVUT1(INBPN,.INIP)
+2 QUIT
+3 ;
ASCII(X) ;Converts a string into an ASCII string
+1 QUIT $$ASCII^INHUVUT1(X)
+2 ;
ADDR(INBPN,INIPADIE,INERR) ;Get next IP address from Background Proc file
+1 QUIT $$ADDR^INHUVUT2(.INBPN,.INIPADIE,.INERR)
+2 ;
CPORT(INBPN,INIPADIE,INIPPOIE) ;Get next client port from Background Proc. file
+1 QUIT $$CPORT^INHUVUT2(.INBPN,.INIPADIE,.INIPPOIE)
+2 ;
SPORT(INBPN,INIPADIE,INERR) ;Get next server port from Background Prc. file
+1 QUIT $$SPORT^INHUVUT2(.INBPN,.INIPADIE,.INERR)
+2 ;
WAIT(INBPN,HNG,STAT,STOP) ;Hang function which periodically checks ^INRHB
+1 ; Called by INHV*
DO WAIT^INHUVUT2(.INBPN,.HNG,.STAT,.STOP)
+2 QUIT
CLEAN(X) ; Clean out control characters
+1 NEW I,Y
SET Y=""
+2 FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+3 IF $ASCII(X,I)<32!($ASCII(X,I)>127)
SET Y=Y_"["_$ASCII(X,I)_"]"
QUIT
+4 SET Y=Y_$EXTRACT(X,I)
End DoDot:1
IF $LENGTH(Y)>234
QUIT
+5 QUIT Y
DB() ;
+1 QUIT 0
