XOBVSKT ;alb/mjk - VistaLink Socket Methods ;07/27/2002
;;1.6;VistALink;**3**;May 08, 2009;Build 17
;Per VHA Directive 6402, this routine should not be modified
Q
;
; ------------------------------------------------------------------------------------
; Methods for Read from/to TCP/IP Socket
; ------------------------------------------------------------------------------------
READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ;
N X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX,SAML
;
S STR="",EOT=$C(4),DONE=0,LINE=0,XOBOK=1,SAML=0
;
; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL
F R XOBX#XOBREAD:XOBTO S TOFLAG=$T D:XOBFIRST CHK D:'XOBSTOP!('DONE) Q:DONE
. ;
. ; -- if length of (new intake + current) is too large for buffer then store current
. I $L(STR)+$L(XOBX)>400 D ADD(STR) S STR=""
. S STR=STR_XOBX
. ;
. ; -- if end-of-text marker found then wrap up and quit
. I STR[EOT S STR=$P(STR,EOT) D ADD(STR) S DONE=1 Q
. ;
. ; -- M XML parser cannot handle an element name split across nodes
. S PIECES=$L(STR,">")
. I PIECES>1 D ADD($P(STR,">",1,PIECES-1)_">") S STR=$P(STR,">",PIECES,999)
.Q
;
K ^TMP($J,"SAML")
I $G(^XTMP($J,"SAML")) D
. S NC=2,NC1=1 F S NC=$O(^XTMP($J,"SAML",NC)) Q:$G(NC)'>0 S ^TMP($J,"SAML",NC1)=$G(^XTMP($J,"SAML",NC)),NC1=NC1+1
;
Q XOBOK
;
ADD(TXT) ; -- add new intake line
S LINE=LINE+1
S @XOBROOT@(LINE)=TXT
S:TXT["SAML"&($G(SAML)'=2) SAML=1 S:$G(SAML)=1&($G(TXT)["<soapenv:Envelope") SAML=2
S:TXT["]]" SAML=3
S:$G(SAML)=2 ^XTMP($J,"SAML",LINE)=$G(TXT)
S:$G(SAML)=3 ^XTMP($J,"SAML",LINE)=$P(TXT,"]]",1)_"]]"
Q
;
CHK ; -- check if first read and change timeout and chars to read
S XOBFIRST=0
;
; -- abort if time out occurred and nothing was read
I 'TOFLAG,$G(XOBX)="" S XOBSTOP=1,DONE=1,XOBOK=0 Q
;
; -- intercept for transport sinks
I $E(XOBX)'="<" D SINK
;
; -- set up for subsequent reads
S XOBREAD=200,XOBTO=1
Q
;
; ------------------------------------------------------------------------------------
; Execute Proprietary Format Reader
; ------------------------------------------------------------------------------------
SINK ;
; -- get size of sink indicator >> then get sink indicator >> load req handler
S XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR)
;
; -- execute proprietary stream reader
I $G(XOBHDLR(XOBHDLR)) X $G(XOBHDLR(XOBHDLR,"READER"))
;
S DONE=1
Q
;
; -- get string of length LEN from stream buffer
GETSTR(LEN,XOBUF) ;
N X
F Q:($L(XOBUF)'<LEN) D RMORE(LEN-$L(XOBUF),.XOBUF)
S X=$E(XOBUF,1,LEN)
S XOBUF=$E(XOBUF,LEN+1,999)
Q X
;
; -- read more from stream buffer but only needed amount
RMORE(LEN,XOBUF) ;
N X
R X#LEN:1 S XOBUF=XOBUF_X
Q
;
; ------------------------------------------------------------------------------------
; Methods for Opening and Closing Socket
; ------------------------------------------------------------------------------------
OPEN(XOBPARMS) ; -- Open tcp/ip socket
N I,POP
S POP=1
;
; -- set up os var
D OS
;
; -- preserve client io
D SAVDEV^%ZISUTL("XOB CLIENT")
;
F I=1:1:XOBPARMS("RETRIES") D CALL^%ZISTCP(XOBPARMS("ADDRESS"),XOBPARMS("PORT")) Q:'POP
; -- device open
I 'POP U IO Q 1
; -- device not open
Q 0
;
CLOSE(XOBPARMS) ; -- close tcp/ip socket
; -- tell server to Stop() connection if close message is needed to close
I $G(XOBPARMS("CLOSE MESSAGE"))]"" D
. D PRE
. D WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE"))
. D POST
;
D FINAL
D CLOSE^%ZISTCP
D USE^%ZISUTL("XOB CLIENT")
D RMDEV^%ZISUTL("XOB CLIENT")
Q
;
INIT ; -- set up variables needed in tcp/ip processing
K XOBNULL
;
; -- setup os var
D OS
;
; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true)
S XWBOS=XOBOS
;
; -- setup null device called "NULL"
S %ZIS="0H",IOP="NULL" D ^%ZIS
I 'POP D
. S XOBNULL=IO
. D SAVDEV^%ZISUTL("XOBNULL")
Q
;
OS ; -- os var
S XOBOS=$S(^%ZOSF("OS")["OpenM":"OpenM",^("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["MSM":"MSM",1:"")
Q
;
FINAL ; -- kill variables used in tcp/ip processing
;
; -- close null device
I $D(XOBNULL) D
. D USE^%ZISUTL("XOBNULL")
. D CLOSE^%ZISUTL("XOBNULL")
. K XOBNULL
;
K XOBOS,XWBOS
;
Q
;
; ------------------------------------------------------------------------------------
; Methods for Writing to TCP/IP Socket
; ------------------------------------------------------------------------------------
PRE ; -- prepare socket for writing
S $X=0
Q
;
WRITE(STR) ; -- Write a data string to socket
I XOBOS="MSM" W STR Q
;
; -- handle a short string
I $L(STR)<511 D:($X+$L(STR))>511 FLUSH W STR Q
;
; -- handle a long string
D FLUSH
F Q:'$L(STR) W $E(STR,1,511) D FLUSH S STR=$E(STR,512,99999)
;
Q
;
POST ; -- send eot and flush socket buffer
D WRITE($C(4))
D FLUSH
Q
;
FLUSH ; flush buffer
I XOBOS="OpenM" W ! Q
I XOBOS="DSM" W:$X>0 ! Q
;IF XOBOS="GTM" WRITE # QUIT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVSKT 5233 printed Dec 13, 2024@02:44:55 Page 2
XOBVSKT ;alb/mjk - VistaLink Socket Methods ;07/27/2002
+1 ;;1.6;VistALink;**3**;May 08, 2009;Build 17
+2 ;Per VHA Directive 6402, this routine should not be modified
+3 QUIT
+4 ;
+5 ; ------------------------------------------------------------------------------------
+6 ; Methods for Read from/to TCP/IP Socket
+7 ; ------------------------------------------------------------------------------------
READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ;
+1 NEW X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX,SAML
+2 ;
+3 SET STR=""
SET EOT=$CHAR(4)
SET DONE=0
SET LINE=0
SET XOBOK=1
SET SAML=0
+4 ;
+5 ; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL
+6 FOR
READ XOBX#XOBREAD:XOBTO
SET TOFLAG=$TEST
if XOBFIRST
DO CHK
if 'XOBSTOP!('DONE)
Begin DoDot:1
+7 ;
+8 ; -- if length of (new intake + current) is too large for buffer then store current
+9 IF $LENGTH(STR)+$LENGTH(XOBX)>400
DO ADD(STR)
SET STR=""
+10 SET STR=STR_XOBX
+11 ;
+12 ; -- if end-of-text marker found then wrap up and quit
+13 IF STR[EOT
SET STR=$PIECE(STR,EOT)
DO ADD(STR)
SET DONE=1
QUIT
+14 ;
+15 ; -- M XML parser cannot handle an element name split across nodes
+16 SET PIECES=$LENGTH(STR,">")
+17 IF PIECES>1
DO ADD($PIECE(STR,">",1,PIECES-1)_">")
SET STR=$PIECE(STR,">",PIECES,999)
+18 QUIT
End DoDot:1
if DONE
QUIT
+19 ;
+20 KILL ^TMP($JOB,"SAML")
+21 IF $GET(^XTMP($JOB,"SAML"))
Begin DoDot:1
+22 SET NC=2
SET NC1=1
FOR
SET NC=$ORDER(^XTMP($JOB,"SAML",NC))
if $GET(NC)'>0
QUIT
SET ^TMP($JOB,"SAML",NC1)=$GET(^XTMP($JOB,"SAML",NC))
SET NC1=NC1+1
End DoDot:1
+23 ;
+24 QUIT XOBOK
+25 ;
ADD(TXT) ; -- add new intake line
+1 SET LINE=LINE+1
+2 SET @XOBROOT@(LINE)=TXT
+3 if TXT["SAML"&($GET(SAML)'=2)
SET SAML=1
if $GET(SAML)=1&($GET(TXT)["<soapenv
SET SAML=2
+4 if TXT["]]"
SET SAML=3
+5 if $GET(SAML)=2
SET ^XTMP($JOB,"SAML",LINE)=$GET(TXT)
+6 if $GET(SAML)=3
SET ^XTMP($JOB,"SAML",LINE)=$PIECE(TXT,"]]",1)_"]]"
+7 QUIT
+8 ;
CHK ; -- check if first read and change timeout and chars to read
+1 SET XOBFIRST=0
+2 ;
+3 ; -- abort if time out occurred and nothing was read
+4 IF 'TOFLAG
IF $GET(XOBX)=""
SET XOBSTOP=1
SET DONE=1
SET XOBOK=0
QUIT
+5 ;
+6 ; -- intercept for transport sinks
+7 IF $EXTRACT(XOBX)'="<"
DO SINK
+8 ;
+9 ; -- set up for subsequent reads
+10 SET XOBREAD=200
SET XOBTO=1
+11 QUIT
+12 ;
+13 ; ------------------------------------------------------------------------------------
+14 ; Execute Proprietary Format Reader
+15 ; ------------------------------------------------------------------------------------
SINK ;
+1 ; -- get size of sink indicator >> then get sink indicator >> load req handler
+2 SET XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR)
+3 ;
+4 ; -- execute proprietary stream reader
+5 IF $GET(XOBHDLR(XOBHDLR))
XECUTE $GET(XOBHDLR(XOBHDLR,"READER"))
+6 ;
+7 SET DONE=1
+8 QUIT
+9 ;
+10 ; -- get string of length LEN from stream buffer
GETSTR(LEN,XOBUF) ;
+1 NEW X
+2 FOR
if ($LENGTH(XOBUF)'<LEN)
QUIT
DO RMORE(LEN-$LENGTH(XOBUF),.XOBUF)
+3 SET X=$EXTRACT(XOBUF,1,LEN)
+4 SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
+5 QUIT X
+6 ;
+7 ; -- read more from stream buffer but only needed amount
RMORE(LEN,XOBUF) ;
+1 NEW X
+2 READ X#LEN:1
SET XOBUF=XOBUF_X
+3 QUIT
+4 ;
+5 ; ------------------------------------------------------------------------------------
+6 ; Methods for Opening and Closing Socket
+7 ; ------------------------------------------------------------------------------------
OPEN(XOBPARMS) ; -- Open tcp/ip socket
+1 NEW I,POP
+2 SET POP=1
+3 ;
+4 ; -- set up os var
+5 DO OS
+6 ;
+7 ; -- preserve client io
+8 DO SAVDEV^%ZISUTL("XOB CLIENT")
+9 ;
+10 FOR I=1:1:XOBPARMS("RETRIES")
DO CALL^%ZISTCP(XOBPARMS("ADDRESS"),XOBPARMS("PORT"))
if 'POP
QUIT
+11 ; -- device open
+12 IF 'POP
USE IO
QUIT 1
+13 ; -- device not open
+14 QUIT 0
+15 ;
CLOSE(XOBPARMS) ; -- close tcp/ip socket
+1 ; -- tell server to Stop() connection if close message is needed to close
+2 IF $GET(XOBPARMS("CLOSE MESSAGE"))]""
Begin DoDot:1
+3 DO PRE
+4 DO WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE"))
+5 DO POST
End DoDot:1
+6 ;
+7 DO FINAL
+8 DO CLOSE^%ZISTCP
+9 DO USE^%ZISUTL("XOB CLIENT")
+10 DO RMDEV^%ZISUTL("XOB CLIENT")
+11 QUIT
+12 ;
INIT ; -- set up variables needed in tcp/ip processing
+1 KILL XOBNULL
+2 ;
+3 ; -- setup os var
+4 DO OS
+5 ;
+6 ; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true)
+7 SET XWBOS=XOBOS
+8 ;
+9 ; -- setup null device called "NULL"
+10 SET %ZIS="0H"
SET IOP="NULL"
DO ^%ZIS
+11 IF 'POP
Begin DoDot:1
+12 SET XOBNULL=IO
+13 DO SAVDEV^%ZISUTL("XOBNULL")
End DoDot:1
+14 QUIT
+15 ;
OS ; -- os var
+1 SET XOBOS=$SELECT(^%ZOSF("OS")["OpenM":"OpenM",^("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["MSM":"MSM",1:"")
+2 QUIT
+3 ;
FINAL ; -- kill variables used in tcp/ip processing
+1 ;
+2 ; -- close null device
+3 IF $DATA(XOBNULL)
Begin DoDot:1
+4 DO USE^%ZISUTL("XOBNULL")
+5 DO CLOSE^%ZISUTL("XOBNULL")
+6 KILL XOBNULL
End DoDot:1
+7 ;
+8 KILL XOBOS,XWBOS
+9 ;
+10 QUIT
+11 ;
+12 ; ------------------------------------------------------------------------------------
+13 ; Methods for Writing to TCP/IP Socket
+14 ; ------------------------------------------------------------------------------------
PRE ; -- prepare socket for writing
+1 SET $X=0
+2 QUIT
+3 ;
WRITE(STR) ; -- Write a data string to socket
+1 IF XOBOS="MSM"
WRITE STR
QUIT
+2 ;
+3 ; -- handle a short string
+4 IF $LENGTH(STR)<511
if ($X+$LENGTH(STR))>511
DO FLUSH
WRITE STR
QUIT
+5 ;
+6 ; -- handle a long string
+7 DO FLUSH
+8 FOR
if '$LENGTH(STR)
QUIT
WRITE $EXTRACT(STR,1,511)
DO FLUSH
SET STR=$EXTRACT(STR,512,99999)
+9 ;
+10 QUIT
+11 ;
POST ; -- send eot and flush socket buffer
+1 DO WRITE($CHAR(4))
+2 DO FLUSH
+3 QUIT
+4 ;
FLUSH ; flush buffer
+1 IF XOBOS="OpenM"
WRITE !
QUIT
+2 IF XOBOS="DSM"
if $X>0
WRITE !
QUIT
+3 ;IF XOBOS="GTM" WRITE # QUIT
+4 QUIT
+5 ;
