- 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 Feb 19, 2025@00:11:26 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 ;
