XWBTCPM2.m

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