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

HLCSTCP4.m

Go to the documentation of this file. 
  1. HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/03/2011  13:29
  1.  ;;1.6;HEALTH LEVEL SEVEN;**109,122,140,157,174**;Oct 13,1995;Build 6
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  Q
  1.  ; SAC EXEMPTION 20200824-01 : Allows the use of the $ZA special variable
  1.  ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
  1.  ;
  1. RDERR ; Error during read process, decrement counter
  1.  D LLCNT^HLCSTCP(HLDP,4,1)
  1. ERROR ; Error trap
  1.  ; OPEN ERROR-retry.
  1.  ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
  1.  ;
  1.  ;**109**
  1.  ;I $G(HLMSG) L -^HLMA(HLMSG)
  1.  ;
  1.  ; patch HL*1.6*122 start
  1.  N STOP
  1.  S STOP=0
  1.  I $G(HLDP) S STOP=$$STOP^HLCSTCP
  1.  ; patch HL*1.6*140
  1.  S $ETRAP="D HALT^ZU" ;RWF
  1.  S HLTCP("$ZA\8192#2")=""
  1.  ;
  1.  ; patch HL*1.6*157 start
  1.  N HLOSYS
  1.  S HLOSYS=$$OS^%ZOSV
  1.  ; I (^%ZOSF("OS")["OpenM") D
  1.  I (HLOSYS["UNIX")!(HLOSYS["VMS") D
  1.  . ; patch HL*1.6*157 end
  1.  . S HLTCP("$ZA")=$ZA
  1.  . ; For TCP devices $ZA\8192#2: the device is currently in the
  1.  . ; Connected state talking to a remote host.
  1.  . S HLTCP("$ZA\8192#2")=$ZA\8192#2
  1.  ;
  1.  S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
  1.  ; 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
  1.  I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  G:STOP H2^XUSCLEAN Q
  1.  . D CC^HLCSTCP2("Op-err")
  1.  . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
  1.  . I STOP D  Q
  1.  .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
  1.  . I 'STOP D UNWIND^%ZTER
  1.  ; patch HL*1.6*140 start
  1.  ; I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
  1.  I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
  1.  . ; S:$G(HLPRIO)="I" HLERROR="108^Write Error"
  1.  . I $G(HLPRIO)="I" D  Q
  1.  .. S HLERROR="108^Write Error"
  1.  .. D CC^HLCSTCP2("Wr-err")
  1.  .. D UNWIND^%ZTER
  1.  . ;
  1.  . I STOP D  Q
  1.  .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
  1.  . E  D  Q
  1.  .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q
  1.  .. E  D  Q
  1.  ... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
  1.  ... D UNWIND^%ZTER
  1.  ;
  1.  ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
  1.  ; I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
  1.  I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
  1.  . ; S:$G(HLPRIO)="I" HLERROR="108^Read Error"
  1.  . I $G(HLPRIO)="I" D  Q
  1.  .. S HLERROR="108^Read Error"
  1.  .. D CC^HLCSTCP2("Rd-err")
  1.  .. D UNWIND^%ZTER
  1.  . ;
  1.  . I STOP D  Q
  1.  .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
  1.  . E  D  Q
  1.  .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q
  1.  .. E  D  Q
  1.  ... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
  1.  ... D UNWIND^%ZTER
  1.  ;
  1.  ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
  1.  ; S:$G(HLPRIO)="I" HLERROR="9^Error"
  1.  D ^%ZTER
  1.  I $G(HLPRIO)="I" D  Q
  1.  . S HLERROR="9^Error"
  1.  . D CC^HLCSTCP2("Error")
  1.  . D UNWIND^%ZTER
  1.  ;
  1.  I STOP D  Q
  1.  . D CC^HLCSTCP2("Shutdown: (with 'Error')")
  1.  . D H2^XUSCLEAN
  1.  ;
  1.  D CC^HLCSTCP2("Error")
  1.  ; patch HL*1.6*122 end
  1.  D H2^XUSCLEAN
  1.  ; patch HL*1.6*140 end
  1.  Q
  1.  ;
  1. PROXY ; set DUZ for application proxy user
  1.  ;
  1.  ; removed the execution: patch 122 TEST v2
  1.  Q
  1.  ;
  1.  ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
  1.  ;; S DUZ=HLDUZ
  1.  ;; D DUZ^XUP(DUZ)
  1.  ;; Q
  1.  ;
  1. HLDUZ ; compare DUZ and set DUZ to application proxy user
  1.  ;
  1.  ; removed the execution: patch 122 TEST v2
  1.  Q
  1.  ;
  1.  ;; I '$G(HLDUZ) D PROXY
  1.  ;
  1. HLDUZ2 ; compare DUZ and HLDUZ
  1.  I $G(DUZ)'=HLDUZ D
  1.  .S DUZ=HLDUZ
  1.  D DUZ^XUP(DUZ) ; HL*1.6*174 moves the call to DUZ^XUP out of the dot structure to ensure the DUZ() array is set up properly.
  1.  Q
  1.  ;
  1. CLEANVAR ; clean variables for server, called from HLCSTCP1
  1.  ;
  1.  ; clean variables except Kernel related variables
  1.  ; protect variables defined in HLCSTCP
  1.  N HLDP
  1.  N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
  1.  N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
  1.  ;
  1.  ; protect variables defined in LISTEN^HLCSTCP
  1.  ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
  1.  ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
  1.  N HLLSTN
  1.  ;
  1.  ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
  1.  N %
  1.  ; protect variables defined in this routine HLCSTCP1
  1.  N $ETRAP,$ESTACK
  1.  N HLMIEN,HLASTMSG
  1.  N HLTMBUF
  1.  N HLDUZ,DUZ
  1.  ; Kernel variables for single listener
  1.  N ZISOS,ZRULE
  1.  ;
  1.  D KILL^XUSCLEAN
  1.  Q
  1. MIEN ; sets HLIND1=ien in 773^ien in 772 for message
  1.  N HLMID,X
  1.  I HLIND1 D
  1.  . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
  1.  . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
  1.  ;msg. id is 10th of MSH & 11th for BSH or FSH
  1.  S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
  1.  ;if HLIND1 is set, kill old message, use HLIND1 for new
  1.  ;message, it means we never got end block for 1st msg.
  1.  I HLIND1 D  Q
  1.  . ;get pointer to 772, kill header
  1.  . ;
  1.  . ; patch HL*1.6*122: MPI-client/server
  1.  . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
  1.  . K ^HLMA(+HLIND1,"MSH")
  1.  . L -^HLMA(+HLIND1)
  1.  . ;
  1.  . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
  1.  . S X=$$MAID^HLTF(+HLIND1,HLMID)
  1.  . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
  1.  . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
  1.  D TCP^HLTF(.HLMID,.X,.HLDT)
  1.  S HLBUFF("IEN773")=X
  1.  I 'X D  Q
  1.  . ;error - record and reset array
  1.  . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
  1.  . D CLEAN^HLCSTCP1 K HLLSTN
  1.  . ;error 100=LLP could not en-queue the message, reset array
  1.  . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
  1.  ;HLIND1=ien in 773^ien in 772
  1.  S HLIND1=X_U_+$G(^HLMA(X,0))
  1.  S HLBUFF("HLIND1")=HLIND1
  1.  ;save MSH into 773
  1.  D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
  1.  Q
  1.  ;
  1. PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
  1.  N FS,I,L,L1,L2,X,Y
  1.  S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
  1.  F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
  1.  . S:L1=1 L=L+1
  1.  . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
  1.  . S L2=Y,Y=L
  1.  Q X
  1.  ;
  1. ERROR1 ;
  1.  ; moved from ERROR^HLCSTCP1
  1.  ; Error trap for disconnect error and return back to the read loop.
  1.  ; patch HL*1.6*122 start
  1.  ; patch HL*1.6*140
  1.  ; S $ETRAP="D HALT^ZU" ;RWF
  1.  S $ETRAP="H 1 D HALT^ZU" ;RWF
  1.  ; patch HL*1.6*157 start
  1.  N HLOSYS
  1.  S HLOSYS=$$OS^%ZOSV
  1.  ; I (^%ZOSF("OS")["OpenM") D
  1.  I (HLOSYS["UNIX")!(HLOSYS["VMS") D
  1.  . ; patch HL*1.6*157 end
  1.  . S HLTCP("$ZA")=$ZA
  1.  . ; For TCP devices $ZA\8192#2: the device is currently in the
  1.  . ; Connected state talking to a remote host.
  1.  . S HLTCP("$ZA\8192#2")=$ZA\8192#2
  1.  . ; patch HL*1.6*157 to include <DSCON>: disconnected by client
  1.  . ; I HLTCP("$ZA\8192#2")=0 D
  1.  . I (HLTCP("$ZA\8192#2")=0)!($$EC^%ZOSV["DSCON") D
  1.  .. ; decrement counter of multi-listener
  1.  .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
  1.  .. ; process terminated
  1.  .. D H2^XUSCLEAN
  1.  ; patch HL*1.6*140
  1.  ;S $ETRAP="D UNWIND^%ZTER" ;RWF
  1.  ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
  1.  I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
  1.  . ; if it is not a multi-listener
  1.  . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
  1.  . D UNWIND^%ZTER
  1.  I $$EC^%ZOSV["READ" D  Q
  1.  . ; if it is not a multi-listener
  1.  . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
  1.  . D UNWIND^%ZTER
  1.  ;
  1.  ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
  1.  I $$EC^%ZOSV["WRITE" D  Q
  1.  . ; if it is not a multi-listener
  1.  . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
  1.  . D UNWIND^%ZTER
  1.  ;
  1.  ; for GT.M
  1.  I $ECODE["UREAD" D  Q
  1.  . ; if it is not a multi-listener
  1.  . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
  1.  . D UNWIND^%ZTER
  1.  ;
  1.  ; S HLCSOUT=1 D ^%ZTER,CC("Error")
  1.  S HLCSOUT=1
  1.  D ^%ZTER
  1.  ; if it is not a multi-listener
  1.  I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
  1.  ; patch HL*1.6*122 end
  1.  ;
  1.  D UNWIND^%ZTER
  1.  Q
  1.  ;
  1. CLRMCNTR ;
  1.  ; clear the counter to set as "0 server" for multi-listener
  1.  ; HL*1.6*122 start
  1.  Q:'$G(HLDP)
  1.  Q:'$D(^HLCS(870,"E","M",HLDP))
  1.  S $P(^HLCS(870,HLDP,0),"^",4)="MS"
  1.  S $P(^HLCS(870,HLDP,0),U,5)="0 server"
  1.  Q
  1.  ;
  1. CREATUSR ;
  1.  ; patch HL*1.6*122 TEST v2: DUZ code removed
  1.  ; create application proxy users for listeners and incoming filer
  1.  ;; N HLTEMP
  1.  ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
  1.  Q