- XWBTCPM2 ;ISF/RWF - BROKER Other Service ;06/28/2012
- ;;1.1;RPC BROKER;**43,45,53,59**;Mar 28, 1997;Build 9
- ;Per VHA Directive 2004-038, this routine should not be modified
- ;
- Q
- ;
- OTH ;Check if some other special service.
- ; ZEXCEPT: XWB - set prior to call from CONNTYPE^XWBTCPM
- S $ETRAP="D ERR^XWBTCPM2"
- I XWB="~EAC~" G EAC
- I XWB="~BSE~" G BSE
- I XWB="~SVR~" G SVR
- D LOG("In 0TH^XWBTCPM2 - Prefix not known: "_XWB)
- Q
- ;
- SVR ;Handle
- Q
- EAC ;Enterprise Access
- Q
- ;
- BSE ;Broker Security Enhancement
- D LOG("BSE msg")
- N L,HDL,RET,XWBSBUF
- S XWBSBUF="",RET="",HDL=""
- S L=$$BREAD^XWBRW(3) I L S HDL=$$BREAD^XWBRW(L)
- I $E(HDL,1,3)="PUT" D
- . ;D RPUT^XUSBSE1(.RET,HDL) ;p59(REM)-RPUT^XUSBSE1 does not exsist.
- . Q
- ;Check IT
- I $E(HDL,1,3)'="PUT" D GETVISIT^XUSBSE1(.RET,HDL)
- D WRITE(RET),WBF
- Q
- ;
- ERR ;Error Trap
- D ^%ZTER
- G H2^XUSCLEAN
- ;
- LOG(%) ;Link to logger
- Q:'$G(XWBDEBUG)
- D LOG^XWBTCPM(%)
- Q
- ;
- WRITE(M,F) ;Write
- N L S L="" I '$G(F) S L=$E(1000+$L(M),2,4)
- D WRITE^XWBRW(L_M)
- Q
- WBF ;Buffer Flush
- D WBF^XWBRW
- Q
- ;
- OPEN(P1,P2) ;Open the device and set the variables
- D CALL^%ZISTCP(P1,P2) Q:POP
- S XWBTDEV=IO
- Q
- ;
- CALLBSE(SERVER,PORT,TOKEN,STN) ;Special Broker service
- N XWBDEBUG,XWBOS,XWBRBUF,XWBSBUF,XWBT,XWBTIME,IO
- N DEMOSTR,XWBTDEV,RET,X,POP
- S IO(0)=$P
- D INIT^XWBTCPM,LOG("CALLBSE")
- D OPEN(SERVER,PORT)
- ; if initial failure try to get web address
- I POP,$G(STN)'="" S SERVER=$$WEBADDRS^XUSBSE1(STN) I SERVER'="" D OPEN(SERVER,PORT)
- I POP Q "Didn't open connection."
- S XWBSBUF="",XWBRBUF=""
- U XWBTDEV
- D WRITE("~BSE~",1),WRITE(TOKEN),WBF^XWBRW
- S X=$$BREAD^XWBRW(3),RET="No Response" I X S RET=$$BREAD^XWBRW(X)
- D CLOSE^%ZISTCP,LOG("FINISH")
- Q RET
- XWBTCPM2 ;ISF/RWF - BROKER Other Service ;06/28/2012
- +1 ;;1.1;RPC BROKER;**43,45,53,59**;Mar 28, 1997;Build 9
- +2 ;Per VHA Directive 2004-038, this routine should not be modified
- +3 ;
- +4 QUIT
- +5 ;
- OTH ;Check if some other special service.
- +1 ; ZEXCEPT: XWB - set prior to call from CONNTYPE^XWBTCPM
- +2 SET $ETRAP="D ERR^XWBTCPM2"
- +3 IF XWB="~EAC~"
- GOTO EAC
- +4 IF XWB="~BSE~"
- GOTO BSE
- +5 IF XWB="~SVR~"
- GOTO SVR
- +6 DO LOG("In 0TH^XWBTCPM2 - Prefix not known: "_XWB)
- +7 QUIT
- +8 ;
- SVR ;Handle
- +1 QUIT
- EAC ;Enterprise Access
- +1 QUIT
- +2 ;
- BSE ;Broker Security Enhancement
- +1 DO LOG("BSE msg")
- +2 NEW L,HDL,RET,XWBSBUF
- +3 SET XWBSBUF=""
- SET RET=""
- SET HDL=""
- +4 SET L=$$BREAD^XWBRW(3)
- IF L
- SET HDL=$$BREAD^XWBRW(L)
- +5 IF $EXTRACT(HDL,1,3)="PUT"
- Begin DoDot:1
- +6 ;D RPUT^XUSBSE1(.RET,HDL) ;p59(REM)-RPUT^XUSBSE1 does not exsist.
- +7 QUIT
- End DoDot:1
- +8 ;Check IT
- +9 IF $EXTRACT(HDL,1,3)'="PUT"
- DO GETVISIT^XUSBSE1(.RET,HDL)
- +10 DO WRITE(RET)
- DO WBF
- +11 QUIT
- +12 ;
- ERR ;Error Trap
- +1 DO ^%ZTER
- +2 GOTO H2^XUSCLEAN
- +3 ;
- LOG(%) ;Link to logger
- +1 IF '$GET(XWBDEBUG)
- QUIT
- +2 DO LOG^XWBTCPM(%)
- +3 QUIT
- +4 ;
- WRITE(M,F) ;Write
- +1 NEW L
- SET L=""
- IF '$GET(F)
- SET L=$EXTRACT(1000+$LENGTH(M),2,4)
- +2 DO WRITE^XWBRW(L_M)
- +3 QUIT
- WBF ;Buffer Flush
- +1 DO WBF^XWBRW
- +2 QUIT
- +3 ;
- OPEN(P1,P2) ;Open the device and set the variables
- +1 DO CALL^%ZISTCP(P1,P2)
- IF POP
- QUIT
- +2 SET XWBTDEV=IO
- +3 QUIT
- +4 ;
- CALLBSE(SERVER,PORT,TOKEN,STN) ;Special Broker service
- +1 NEW XWBDEBUG,XWBOS,XWBRBUF,XWBSBUF,XWBT,XWBTIME,IO
- +2 NEW DEMOSTR,XWBTDEV,RET,X,POP
- +3 SET IO(0)=$PRINCIPAL
- +4 DO INIT^XWBTCPM
- DO LOG("CALLBSE")
- +5 DO OPEN(SERVER,PORT)
- +6 ; if initial failure try to get web address
- +7 IF POP
- IF $GET(STN)'=""
- SET SERVER=$$WEBADDRS^XUSBSE1(STN)
- IF SERVER'=""
- DO OPEN(SERVER,PORT)
- +8 IF POP
- QUIT "Didn't open connection."
- +9 SET XWBSBUF=""
- SET XWBRBUF=""
- +10 USE XWBTDEV
- +11 DO WRITE("~BSE~",1)
- DO WRITE(TOKEN)
- DO WBF^XWBRW
- +12 SET X=$$BREAD^XWBRW(3)
- SET RET="No Response"
- IF X
- SET RET=$$BREAD^XWBRW(X)
- +13 DO CLOSE^%ZISTCP
- DO LOG("FINISH")
- +14 QUIT RET
