source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m@ 1006

Last change on this file since 1006 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 3.8 KB
Line 
1HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006 13:31
2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
7 ;
8RDERR ; Error during read process, decrement counter
9 D LLCNT^HLCSTCP(HLDP,4,1)
10ERROR ; Error trap
11 ; OPEN ERROR-retry.
12 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
13 ;
14 ;**109**
15 ;I $G(HLMSG) L -^HLMA(HLMSG)
16 ;
17 S $ETRAP="D UNWIND^%ZTER"
18 ; patch HL*1.6*122
19 S HLTCPERR("$P")=$P
20 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
21 ; 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
22 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q
23 . D CC^HLCSTCP2("Op-err")
24 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
25 . D UNWIND^%ZTER
26 I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications start here
27 . D CC^HLCSTCP2("Wr-err")
28 . S:$G(HLPRIO)="I" HLERROR="108^Write Error"
29 . D UNWIND^%ZTER ;HL*1.6*77 modifications end here
30 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
31 I $$EC^%ZOSV["READ" D Q
32 . D CC^HLCSTCP2("Rd-err")
33 . S:$G(HLPRIO)="I" HLERROR="108^Read Error"
34 . D UNWIND^%ZTER
35 S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
36 S:$G(HLPRIO)="I" HLERROR="9^Error"
37 D UNWIND^%ZTER
38 Q
39 ;
40PROXY ; set DUZ for application proxy user
41 S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
42 S DUZ=HLDUZ
43 D DUZ^XUP(DUZ)
44 Q
45 ;
46HLDUZ ; compare DUZ and set DUZ to application proxy user
47 I '$G(HLDUZ) D PROXY
48 I $G(DUZ)'=HLDUZ D
49 . S DUZ=HLDUZ
50 . D DUZ^XUP(DUZ)
51 Q
52 ;
53CLEANVAR ; clean variables for server, called from HLCSTCP1
54 ;
55 ; clean variables except Kernel related variables
56 ; protect variables defined in HLCSTCP
57 N HLDP
58 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
59 N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
60 ;
61 ; protect variables defined in LISTEN^HLCSTCP
62 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
63 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
64 N HLLSTN
65 ;
66 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
67 N %
68 ; protect variables defined in this routine HLCSTCP1
69 N $ETRAP,$ESTACK
70 N HLMIEN,HLASTMSG
71 N HLTMBUF
72 N HLDUZ,DUZ
73 ; Kernel variables for single listener
74 N ZISOS,ZRULE
75 ;
76 D KILL^XUSCLEAN
77 Q
78MIEN ; sets HLIND1=ien in 773^ien in 772 for message
79 N HLMID,X
80 I HLIND1 D
81 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
82 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
83 ;msg. id is 10th of MSH & 11th for BSH or FSH
84 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
85 ;if HLIND1 is set, kill old message, use HLIND1 for new
86 ;message, it means we never got end block for 1st msg.
87 I HLIND1 D Q
88 . ;get pointer to 772, kill header
89 . K ^HLMA(+HLIND1,"MSH")
90 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
91 . S X=$$MAID^HLTF(+HLIND1,HLMID)
92 . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
93 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
94 D TCP^HLTF(.HLMID,.X,.HLDT)
95 S HLBUFF("IEN773")=X
96 I 'X D Q
97 . ;error - record and reset array
98 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
99 . D CLEAN^HLCSTCP1 K HLLSTN
100 . ;error 100=LLP Could not Enqueue the Message, reset array
101 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
102 ;HLIND1=ien in 773^ien in 772
103 S HLIND1=X_U_+$G(^HLMA(X,0))
104 S HLBUFF("HLIND1")=HLIND1
105 ;save MSH into 773
106 D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
107 Q
108 ;
109PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
110 N FS,I,L,L1,L2,X,Y
111 S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
112 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
113 . S:L1=1 L=L+1
114 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
115 . S L2=Y,Y=L
116 Q X
117 ;
Note: See TracBrowser for help on using the repository browser.