HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006  13:31
 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4
 ;Per VHA Directive 2004-038, this routine should not be modified.
 ;
 Q
 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
 ;
RDERR ; Error during read process, decrement counter
 D LLCNT^HLCSTCP(HLDP,4,1)
ERROR ; Error trap
 ; OPEN ERROR-retry.
 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
 ;
 ;**109**
 ;I $G(HLMSG) L -^HLMA(HLMSG)
 ;
 S $ETRAP="D UNWIND^%ZTER"
 ; patch HL*1.6*122
 S HLTCPERR("$P")=$P
 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
 ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
 . D CC^HLCSTCP2("Op-err")
 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
 . D UNWIND^%ZTER
 I $$EC^%ZOSV["WRITE" D  Q  ;HL*1.6*77 modifications start here
 .  D CC^HLCSTCP2("Wr-err")
 .  S:$G(HLPRIO)="I" HLERROR="108^Write Error"
 .  D UNWIND^%ZTER ;HL*1.6*77 modifications end here
 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
 I $$EC^%ZOSV["READ" D  Q
 . D CC^HLCSTCP2("Rd-err")
 . S:$G(HLPRIO)="I" HLERROR="108^Read Error"
 . D UNWIND^%ZTER
 S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
 S:$G(HLPRIO)="I" HLERROR="9^Error"
 D UNWIND^%ZTER
 Q
 ;
PROXY ; set DUZ for application proxy user
 S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
 S DUZ=HLDUZ
 D DUZ^XUP(DUZ)
 Q
 ;
HLDUZ ; compare DUZ and set DUZ to application proxy user
 I '$G(HLDUZ) D PROXY
 I $G(DUZ)'=HLDUZ D
 . S DUZ=HLDUZ
 . D DUZ^XUP(DUZ)
 Q
 ;
CLEANVAR ; clean variables for server, called from HLCSTCP1
 ;
 ; clean variables except Kernel related variables
 ; protect variables defined in HLCSTCP
 N HLDP
 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
 N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
 ;
 ; protect variables defined in LISTEN^HLCSTCP
 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
 N HLLSTN
 ;
 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
 N %
 ; protect variables defined in this routine HLCSTCP1
 N $ETRAP,$ESTACK
 N HLMIEN,HLASTMSG
 N HLTMBUF
 N HLDUZ,DUZ
 ; Kernel variables for single listener
 N ZISOS,ZRULE
 ;
 D KILL^XUSCLEAN
 Q
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
 N HLMID,X
 I HLIND1 D
 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
 ;msg. id is 10th of MSH & 11th for BSH or FSH
 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
 ;if HLIND1 is set, kill old message, use HLIND1 for new
 ;message, it means we never got end block for 1st msg.
 I HLIND1 D  Q
 . ;get pointer to 772, kill header
 . K ^HLMA(+HLIND1,"MSH")
 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
 . S X=$$MAID^HLTF(+HLIND1,HLMID)
 . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
 D TCP^HLTF(.HLMID,.X,.HLDT)
 S HLBUFF("IEN773")=X
 I 'X D  Q
 . ;error - record and reset array
 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
 . D CLEAN^HLCSTCP1 K HLLSTN
 . ;error 100=LLP Could not Enqueue the Message, reset array
 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
 ;HLIND1=ien in 773^ien in 772
 S HLIND1=X_U_+$G(^HLMA(X,0))
 S HLBUFF("HLIND1")=HLIND1
 ;save MSH into 773
 D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
 Q
 ;
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
 N FS,I,L,L1,L2,X,Y
 S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
 . S:L1=1 L=L+1
 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
 . S L2=Y,Y=L
 Q X
 ;