118 lines
3.8 KiB
Mathematica
118 lines
3.8 KiB
Mathematica
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
|
|
;
|