BGUTCPH ; IHS/OIT/MJL - Service TCP Messages ; [ 04/14/2008 4:48 PM ]
;;1.5;BGU;**2,4**;MAY 26, 2005
EN(BGUIP,BGUSKT) ; EP-- MAIN entry point (usually jobbed)
; params: BGUIP := address of client requiring connection
; BGUSKT := client socket to call
;
; Activity time out default value is 3600 seconds and is set by the
; SERVER TIMEOUT field in the BGU SITE PARAMETER file.
IP ;
Q:BGUIP'?1.3N1"."1.3N1"."1.3N1"."1.3N S BGUSKT=$G(BGUSKT,8000)
;N BGUTBUF,BGUTLEN,BGUTLEN1,BGUTLEN2,BGUTREF,BGUTRTN,BGUTYPE,X,BGUDATA
S XWBCLMAN=$G(XWBCLMAN)
S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
N BGUMSM S BGUMSM=$S(XWBOS["MSM":1,1:0)
;IF $$NEWERR^%ZTER S $ETRAP="D ^%ZTER H"
;E S X="^%ZTER",@^%ZOSF("TRAP")
K XRTL IF XWBOS="DSM" S XRTL=1 ;log response time data for DSM
S XWBTIME=1
;call client on new port
;IF XWBOS="DSM" O XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
;IF XWBOS="MSM"!(XWBOS="UNIX") O 56 U 56::"TCP" W /SOCKET(XWBTIP,XWBTSKT)
;IF XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(XWBTIP:XWBTSKT:"ST":$C(13,10):512:512) ;RWF
;Use Kernel to open the connection back to the client
S XWBTIP=BGUIP,XWBTSKT=BGUSKT
IF XWBOS'="OpenM" D CALL^%ZISTCP(XWBTIP,XWBTSKT) Q:POP S XWBTDEV=IO,IO(0)=IO
IF XWBOS="OpenM" S XWBTDEV=$P
;S XWBTDEV="|TCP|"_BGUSKT
;O XWBTDEV:(BGUIP:BGUSKT:"S"::512:512):5 Q:'$T
;setup null device "NULL"
;D OPEN^%ZISUTL("XWBNULL","NULL","0") ;Need to suppress HOME device
;S XWBNULL=IO
IF XWBOS="DSM" S XWBNULL="_NLA0:" O XWBNULL S (IO,IO(0))=XWBNULL,IOT="TRM",IOST="P-OTHER",IOST(0)=0
ELSE S IOP="NULL" D ^%ZIS S XWBNULL=IO
;change process name
;D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT)
D INIT
;O 56 U 56::"TCP"
;W /SOCKET(BGUIP,BGUSKT) ; -- connect to client
;S $ZTRAP="ETRAP^BGUTCPH" ; -- set error trap
;S X="ETRAP^BGUTCPH",@^%ZOSF("TRAP") ; -- set error trap
;
RESTART ;IF ERROR OCCURRED CAPTURE ERROR AND COME BACK TO HERE
IF $$NEWERR^%ZTER N $ESTACK,$ETRAP S $ETRAP="D ETRAP^BGUTCPH H"
E S X="ETRAP^BGUTCPH",@^%ZOSF("TRAP")
S DIQUIET=1,U="^" D DT^DICRW
U XWBTDEV D TCP
;Turn off the error for the exit
IF $$NEWERR^%ZTER S $ETRAP=""
E S X="",@^%ZOSF("TRAP")
I $G(DUZ) D LOGOUT^XUSRB
K XWBR,XWBARY
C XWBTDEV
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
Q
;
TCP ; -- TCP PROCESSING LOOP
I 'BGUMSM N BGUTBUF,BGUTLEN,BGUTLEN1,BGUTLEN2,BGUTREF,BGUTRTN,BGUTYPE,X,BGUDATA,BGUWEB S BGUWEB="" ;,$ZTRAP="ETRAP^BGUTCPH"
F D Q:BGUTBUF="#BYE#"
.I 'BGUMSM U XWBTDEV
.; -- read client request
.;Get the first 2 length bytes
.R *BGUTLEN1:BGUDTIME I '$T S BGUTBUF="#BYE#" Q
.R *BGUTLEN2:BGUDTIME I '$T S BGUTBUF="#BYE#" Q
.;Calculate the length
.S BGUTLEN=BGUTLEN1+(256*BGUTLEN2)
.I 'BGUTLEN S BGUTBUF="#BYE#" Q
.R BGUTBUF#BGUTLEN:BGUDTIME
.I BGUTBUF="#BYE#" D LOGOUT W "#BYE#",$C(4,13,10) Q ; -- clean disconnect
.I '$D(DUZ),$P(BGUTBUF,"^")'="BGU AVLOGON" S BGUTBUF="#BYE#" W "#BYE#",$C(4,13,10) Q ;-- disconnect if no DUZ or the message is not for a logon
.;
.; -- if statistics is turned on
.; -- if running interactively in debug mode
.D MAIN
;I BGUMSM C 56
;E C BGUIOC
;C 56
Q
;
WEB ;
S BGUWEB=1,BGUIP="",BGUERR=""
S BGUHTMLS="<INPUT TYPE=""HIDDEN"" NAME=""RESULT"" VALUE="" "">"
D INIT,MAIN
Q
;
INIT ;
S U="^",BGUDTIME=$P($G(^BGUSP(1,0)),U,6) S:'BGUDTIME BGUDTIME=3600
S BGUWEB=""
Q
;
MAIN ;
;
; -- set up for routine call
K X,BGUDATA N DIQUIET,BGUGUI
S BGUTREF=$O(^XWB(8994,"B",$P(BGUTBUF,"^"),0))
I BGUTREF="" D Q
.S BGUDATA(1)=-1,BGUDATA(2)="NO MESSAGE HEADER DEFINED! ("_BGUTBUF_")",BGUTYPE=2
.D PGHDR:BGUWEB,RESULT,PGFTR:BGUWEB
S BGUITYPE=$P($G(^XWB(8994,BGUTREF,9999999)),"^",1)
S BGUTREF=$G(^XWB(8994,BGUTREF,0))
S BGUTRTN=$P(BGUTREF,"^",2,3)_"(.BGUDATA"
S BGUTYPE=$P(BGUTREF,"^",4)
;S (BGULGM,BGUMSG)=BGUTBUF,BGUTBUF=$P(BGUTBUF,"^",2,999)
S BGUMSG=BGUTBUF,BGUTBUF=$P(BGUTBUF,"^",2,999)
I BGUTBUF'="" D
.I BGUITYPE S BGUTRTN=BGUTRTN_",.BGUTBUF" Q
.F I=1:1:$L(BGUTBUF,"^") S X(I)=$P(BGUTBUF,"^",I) S:X(I)[$C(26) X(I)=$TR(X(I),$C(26),"^") S BGUTRTN=BGUTRTN_",X("_I_")"
S BGUTBUF=""
S BGUTRTN=BGUTRTN_")" S (DIQUIET,BGUGUI)=1 D @BGUTRTN ; -- call routine
D:$S($P(BGUMSG,"TRACE=",2)'="":1,$D(BGUTRACE):1,$P($G(^BGUSP(1,0)),"^",2)="Y":1,1:$D(^BGUSP(1,1,"B",$J))) ^BGUTRACE
; -- if statistics is on, logs data
;I $D(DUZ),$P(BGULGM,"^")="BGU AVLOGON",$P($G(^BGUSP(1,0)),"^",3)="Y" S BGUETH=$P(BGULGM,U,4),BGUAPP=$P(BGULGM,U,5),BGUPRM=$P(BGULGM,U,6),BGUSEC=$$LOG^BGUGUTL(DUZ,BGUIP,BGUSKT,BGUETH,BGUAPP,BGUPRM)
;I $P($G(^BGUSP(1,0)),"^",3)="Y" S:'$D(BGUSTAT($P(BGULGM,"^"))) BGUSTAT($P(BGULGM,"^"))=0 S BGUSTAT($P(BGULGM,"^"))=BGUSTAT($P(BGULGM,"^"))+1
I $D(DUZ),$P(BGUMSG,"^")="BGU AVLOGON",$P($G(^BGUSP(1,0)),"^",3)="Y" S BGUETH=$P(BGUMSG,U,4),BGUAPP=$P(BGUMSG,U,5),BGUPRM=$P(BGUMSG,U,6),BGUSEC=$$LOG^BGUGUTL(DUZ,BGUIP,BGUSKT,BGUETH,BGUAPP,BGUPRM)
I $P($G(^BGUSP(1,0)),"^",3)="Y" S:'$D(BGUSTAT($P(BGUMSG,"^"))) BGUSTAT($P(BGUMSG,"^"))=0 S BGUSTAT($P(BGUMSG,"^"))=BGUSTAT($P(BGUMSG,"^"))+1
D PGHDR:BGUWEB,RESULT,PGFTR:BGUWEB
K BGUMSG
Q
;
RESULT ;
; -- write returned data (in BGUDATA) to client
; BGUTYPE =
; 1 -- single value
; 2 -- table delimited by RS
; 3 -- word processing
; 4 -- global array type
; 5 -- raw buffer string
D
.I BGUTYPE=1 D WRITE(BGUDATA) Q
.I "23"[BGUTYPE D Q
..S BGURS=$S(BGUTYPE=2:$C(30),1:$C(13,10)),I="" F S I=$O(BGUDATA(I)) Q:I="" D WRITE(BGUDATA(I))
.Q:$G(BGUDATA)=""
.S BGUI=BGUDATA,BGUCK=$P(BGUI,")",1)_",",BGUCKL=$L(BGUCK) D:$D(@BGUI)#2 WRITE(@BGUI)
.F S BGUI=$Q(@BGUI) Q:$E(BGUI,1,BGUCKL)'=BGUCK D WRITE(@BGUI)
.K @BGUDATA
W:BGUIP'="" $C(4,13,10) W:'BGUMSM !
Q
;
WRITE(BGUX) ;
I '$G(BGUWEB) W BGUX,BGURS Q
S BGUX1=BGUHTMLS,$E(BGUX1,43)=BGUX W BGUX1
Q
;
PGHDR ;
W "<HTML><HEAD>"
W "<SCRIPT LANGUAGE=""VBScript"">"
W "<!--",!
W "Sub Window_OnLoad()",!
W "document.frmInfo.submit",!
W "End Sub",!
W "-->"
W "</SCRIPT>"
W "<TITLE>LOGIN RESULTS</TITLE></HEAD>"
W "<BODY" W:BGUBGRND'="" " BACKGROUND=""",BGUBGRND,"""" W ">"
W "<FORM NAME=""frmInfo"" METHOD=""POST"" ACTION="""_BGUASP_""">"
Q
;
PGFTR ;
W "</FORM></BODY></HTML>"
Q
;
OLDETRAP ; -- on trapped error, send error info to client
;I BGUTLEN U 56 W "-1",$C(30),"SERVER ERROR=",$$EC^%ZOSV_" LAST REF="_$$LGR^%ZOSV,$C(4,13,10)
;D ERR^ZU
;D ^%ZTER U 56
;G TCP
;
;ETRAP -- on trapped error, send error info to client
;N XWBERC,XWBERR
;S XWBERC=$$EC^%ZOSV
;G:XWBERC["<WRITE>" RESTART
;G:XWBERC["<READ>" RESTART
;S XWBERR="-1"_$C(30)_"M ERROR="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
;S XWBERR=$C(24)_"M ERROR="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
;Turn off trapping during trap.
;IF $$NEWERR^%ZTER S $ETRAP=""
;E S X="",@^%ZOSF("TRAP")
;U XWBTDEV
;D ^%ZTER ;%ZTER clears $ZE and $ZCODE
;U XWBTDEV
;IF XWBOS="MSM"!(XWBOS="OpenM") W XWBERR,! G RESTART
;IF XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN,XWBERR'["SYSTEM-F" D SNDERR W XWBERR,!
;IF XWBOS'="DSM" D
;. D SNDERR W XWBERR,!
;I (XWBERR["READERR")!(XWBERR["DISCON")!(XWBERR["SYSTEM-F") D:$G(DUZ) LOGOUT^XUSRB HALT
;I '$$NEWERR^%ZTER G RESTART
;S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^BGUTCPH",$ECODE=",U99,"
;
;Q
ETRAP ; -- on trapped error, send error info to client
N XWBERC,XWBERR
;Change trapping during trap.
S $ETRAP="D ^%ZTER H"
;S $ETRAP="G RESTART^BGUTCPH"
S XWBERC=$$EC^%ZOSV,XWBERR=$C(24)_"M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
D ^%ZTER ;%ZTER clears $ZE and $ECODE
I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D:$G(DUZ) LOGOUT^XUSRB HALT
U XWBTDEV
I XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN D SNDERR,WRITE(XWBERR) W:$X !
I XWBOS'="DSM" D
. D SNDERR,WRITE(XWBERR) W:$X !
;S $ETRAP="G RESTART^BGUTCPH"
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^BGUTCPH"
G RESTART
Q
;
SNDERR ;send error information
;XWBSEC is the security packet, XWBERROR is application packet
N X
S X=$G(XWBSEC)
W $C($L(X))_X W:($X+$L(X)+1)>512 !
S X=$G(XWBERROR)
W $C($L(X))_X W:($X+$L(X)+1)>512 !
S XWBERROR="" ;clears parameters
Q
;
LOGOUT ;
Q:'$D(BGUSEC)
S $P(^BGUSEC(BGUSEC,0),"^",4)=$$NOW^XLFDT K ^BGUSEC("CUR",DUZ,BGUSEC)
Q:$P($G(^BGUSP(1,0)),"^",3)'="Y"
Q:'$D(^BGUSEC(BGUSEC,0))
S:'$D(^BGUSEC(BGUSEC,20,0)) ^(0)="^90062.11A^0^0"
S X="" F I=1:1 S X=$O(BGUSTAT(X)) Q:X="" S Y=X_U_BGUSTAT(X),^BGUSEC(BGUSEC,20,I,0)=$E(Y,1,255)
S $P(^BGUSEC(BGUSEC,20,0),"^",3,4)=I_"^"_I
Q
BGUTCPH ; IHS/OIT/MJL - Service TCP Messages ; [ 04/14/2008 4:48 PM ]
+1 ;;1.5;BGU;**2,4**;MAY 26, 2005
EN(BGUIP,BGUSKT) ; EP-- MAIN entry point (usually jobbed)
+1 ; params: BGUIP := address of client requiring connection
+2 ; BGUSKT := client socket to call
+3 ;
+4 ; Activity time out default value is 3600 seconds and is set by the
+5 ; SERVER TIMEOUT field in the BGU SITE PARAMETER file.
IP ;
+1 IF BGUIP'?1.3N1"."1.3N1"."1.3N1"."1.3N
QUIT
SET BGUSKT=$GET(BGUSKT,8000)
+2 ;N BGUTBUF,BGUTLEN,BGUTLEN1,BGUTLEN2,BGUTREF,BGUTRTN,BGUTYPE,X,BGUDATA
+3 SET XWBCLMAN=$GET(XWBCLMAN)
+4 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
+5 NEW BGUMSM
SET BGUMSM=$SELECT(XWBOS["MSM":1,1:0)
+6 ;IF $$NEWERR^%ZTER S $ETRAP="D ^%ZTER H"
+7 ;E S X="^%ZTER",@^%ZOSF("TRAP")
+8 ;log response time data for DSM
KILL XRTL
IF XWBOS="DSM"
SET XRTL=1
+9 SET XWBTIME=1
+10 ;call client on new port
+11 ;IF XWBOS="DSM" O XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
+12 ;IF XWBOS="MSM"!(XWBOS="UNIX") O 56 U 56::"TCP" W /SOCKET(XWBTIP,XWBTSKT)
+13 ;IF XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(XWBTIP:XWBTSKT:"ST":$C(13,10):512:512) ;RWF
+14 ;Use Kernel to open the connection back to the client
+15 SET XWBTIP=BGUIP
SET XWBTSKT=BGUSKT
+16 IF XWBOS'="OpenM"
DO CALL^%ZISTCP(XWBTIP,XWBTSKT)
IF POP
QUIT
SET XWBTDEV=IO
SET IO(0)=IO
+17 IF XWBOS="OpenM"
SET XWBTDEV=$PRINCIPAL
+18 ;S XWBTDEV="|TCP|"_BGUSKT
+19 ;O XWBTDEV:(BGUIP:BGUSKT:"S"::512:512):5 Q:'$T
+20 ;setup null device "NULL"
+21 ;D OPEN^%ZISUTL("XWBNULL","NULL","0") ;Need to suppress HOME device
+22 ;S XWBNULL=IO
+23 IF XWBOS="DSM"
SET XWBNULL="_NLA0:"
OPEN XWBNULL
SET (IO,IO(0))=XWBNULL
SET IOT="TRM"
SET IOST="P-OTHER"
SET IOST(0)=0
+24 IF '$TEST
SET IOP="NULL"
DO ^%ZIS
SET XWBNULL=IO
+25 ;change process name
+26 ;D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT)
+27 DO INIT
+28 ;O 56 U 56::"TCP"
+29 ;W /SOCKET(BGUIP,BGUSKT) ; -- connect to client
+30 ;S $ZTRAP="ETRAP^BGUTCPH" ; -- set error trap
+31 ;S X="ETRAP^BGUTCPH",@^%ZOSF("TRAP") ; -- set error trap
+32 ;
RESTART ;IF ERROR OCCURRED CAPTURE ERROR AND COME BACK TO HERE
+1 IF $$NEWERR^%ZTER
NEW $ESTACK,$ETRAP
SET $ETRAP="D ETRAP^BGUTCPH H"
+2 IF '$TEST
SET X="ETRAP^BGUTCPH"
SET @^%ZOSF("TRAP")
+3 SET DIQUIET=1
SET U="^"
DO DT^DICRW
+4 USE XWBTDEV
DO TCP
+5 ;Turn off the error for the exit
+6 IF $$NEWERR^%ZTER
SET $ETRAP=""
+7 IF '$TEST
SET X=""
SET @^%ZOSF("TRAP")
+8 IF $GET(DUZ)
DO LOGOUT^XUSRB
+9 KILL XWBR,XWBARY
+10 CLOSE XWBTDEV
+11 DO USE^%ZISUTL("XWBNULL")
DO CLOSE^%ZISUTL("XWBNULL")
+12 QUIT
+13 ;
TCP ; -- TCP PROCESSING LOOP
+1 ;,$ZTRAP="ETRAP^BGUTCPH"
IF 'BGUMSM
NEW BGUTBUF,BGUTLEN,BGUTLEN1,BGUTLEN2,BGUTREF,BGUTRTN,BGUTYPE,X,BGUDATA,BGUWEB
SET BGUWEB=""
+2 FOR
Begin DoDot:1
+3 IF 'BGUMSM
USE XWBTDEV
+4 ; -- read client request
+5 ;Get the first 2 length bytes
+6 READ *BGUTLEN1:BGUDTIME
IF '$TEST
SET BGUTBUF="#BYE#"
QUIT
+7 READ *BGUTLEN2:BGUDTIME
IF '$TEST
SET BGUTBUF="#BYE#"
QUIT
+8 ;Calculate the length
+9 SET BGUTLEN=BGUTLEN1+(256*BGUTLEN2)
+10 IF 'BGUTLEN
SET BGUTBUF="#BYE#"
QUIT
+11 READ BGUTBUF#BGUTLEN:BGUDTIME
+12 ; -- clean disconnect
IF BGUTBUF="#BYE#"
DO LOGOUT
WRITE "#BYE#",$CHAR(4,13,10)
QUIT
+13 ;-- disconnect if no DUZ or the message is not for a logon
IF '$DATA(DUZ)
IF $PIECE(BGUTBUF,"^")'="BGU AVLOGON"
SET BGUTBUF="#BYE#"
WRITE "#BYE#",$CHAR(4,13,10)
QUIT
+14 ;
+15 ; -- if statistics is turned on
+16 ; -- if running interactively in debug mode
+17 DO MAIN
End DoDot:1
IF BGUTBUF="#BYE#"
QUIT
+18 ;I BGUMSM C 56
+19 ;E C BGUIOC
+20 ;C 56
+21 QUIT
+22 ;
WEB ;
+1 SET BGUWEB=1
SET BGUIP=""
SET BGUERR=""
+2 SET BGUHTMLS="<INPUT TYPE=""HIDDEN"" NAME=""RESULT"" VALUE="" "">"
+3 DO INIT
DO MAIN
+4 QUIT
+5 ;
INIT ;
+1 SET U="^"
SET BGUDTIME=$PIECE($GET(^BGUSP(1,0)),U,6)
IF 'BGUDTIME
SET BGUDTIME=3600
+2 SET BGUWEB=""
+3 QUIT
+4 ;
MAIN ;
+1 ;
+2 ; -- set up for routine call
+3 KILL X,BGUDATA
NEW DIQUIET,BGUGUI
+4 SET BGUTREF=$ORDER(^XWB(8994,"B",$PIECE(BGUTBUF,"^"),0))
+5 IF BGUTREF=""
Begin DoDot:1
+6 SET BGUDATA(1)=-1
SET BGUDATA(2)="NO MESSAGE HEADER DEFINED! ("_BGUTBUF_")"
SET BGUTYPE=2
+7 IF BGUWEB
DO PGHDR
DO RESULT
IF BGUWEB
DO PGFTR
End DoDot:1
QUIT
+8 SET BGUITYPE=$PIECE($GET(^XWB(8994,BGUTREF,9999999)),"^",1)
+9 SET BGUTREF=$GET(^XWB(8994,BGUTREF,0))
+10 SET BGUTRTN=$PIECE(BGUTREF,"^",2,3)_"(.BGUDATA"
+11 SET BGUTYPE=$PIECE(BGUTREF,"^",4)
+12 ;S (BGULGM,BGUMSG)=BGUTBUF,BGUTBUF=$P(BGUTBUF,"^",2,999)
+13 SET BGUMSG=BGUTBUF
SET BGUTBUF=$PIECE(BGUTBUF,"^",2,999)
+14 IF BGUTBUF'=""
Begin DoDot:1
+15 IF BGUITYPE
SET BGUTRTN=BGUTRTN_",.BGUTBUF"
QUIT
+16 FOR I=1:1:$LENGTH(BGUTBUF,"^")
SET X(I)=$PIECE(BGUTBUF,"^",I)
IF X(I)[$CHAR(26)
SET X(I)=$TRANSLATE(X(I),$CHAR(26),"^")
SET BGUTRTN=BGUTRTN_",X("_I_")"
End DoDot:1
+17 SET BGUTBUF=""
+18 ; -- call routine
SET BGUTRTN=BGUTRTN_")"
SET (DIQUIET,BGUGUI)=1
DO @BGUTRTN
+19 IF $SELECT($PIECE(BGUMSG,"TRACE=",2)'=""
DO ^BGUTRACE
+20 ; -- if statistics is on, logs data
+21 ;I $D(DUZ),$P(BGULGM,"^")="BGU AVLOGON",$P($G(^BGUSP(1,0)),"^",3)="Y" S BGUETH=$P(BGULGM,U,4),BGUAPP=$P(BGULGM,U,5),BGUPRM=$P(BGULGM,U,6),BGUSEC=$$LOG^BGUGUTL(DUZ,BGUIP,BGUSKT,BGUETH,BGUAPP,BGUPRM)
+22 ;I $P($G(^BGUSP(1,0)),"^",3)="Y" S:'$D(BGUSTAT($P(BGULGM,"^"))) BGUSTAT($P(BGULGM,"^"))=0 S BGUSTAT($P(BGULGM,"^"))=BGUSTAT($P(BGULGM,"^"))+1
+23 IF $DATA(DUZ)
IF $PIECE(BGUMSG,"^")="BGU AVLOGON"
IF $PIECE($GET(^BGUSP(1,0)),"^",3)="Y"
SET BGUETH=$PIECE(BGUMSG,U,4)
SET BGUAPP=$PIECE(BGUMSG,U,5)
SET BGUPRM=$PIECE(BGUMSG,U,6)
SET BGUSEC=$$LOG^BGUGUTL(DUZ,BGUIP,BGUSKT,BGUETH,BGUAPP,BGUPRM)
+24 IF $PIECE($GET(^BGUSP(1,0)),"^",3)="Y"
IF '$DATA(BGUSTAT($PIECE(BGUMSG,"^")))
SET BGUSTAT($PIECE(BGUMSG,"^"))=0
SET BGUSTAT($PIECE(BGUMSG,"^"))=BGUSTAT($PIECE(BGUMSG,"^"))+1
+25 IF BGUWEB
DO PGHDR
DO RESULT
IF BGUWEB
DO PGFTR
+26 KILL BGUMSG
+27 QUIT
+28 ;
RESULT ;
+1 ; -- write returned data (in BGUDATA) to client
+2 ; BGUTYPE =
+3 ; 1 -- single value
+4 ; 2 -- table delimited by RS
+5 ; 3 -- word processing
+6 ; 4 -- global array type
+7 ; 5 -- raw buffer string
+8 Begin DoDot:1
+9 IF BGUTYPE=1
DO WRITE(BGUDATA)
QUIT
+10 IF "23"[BGUTYPE
Begin DoDot:2
+11 SET BGURS=$SELECT(BGUTYPE=2:$CHAR(30),1:$CHAR(13,10))
SET I=""
FOR
SET I=$ORDER(BGUDATA(I))
IF I=""
QUIT
DO WRITE(BGUDATA(I))
End DoDot:2
QUIT
+12 IF $GET(BGUDATA)=""
QUIT
+13 SET BGUI=BGUDATA
SET BGUCK=$PIECE(BGUI,")",1)_","
SET BGUCKL=$LENGTH(BGUCK)
IF $DATA(@BGUI)#2
DO WRITE(@BGUI)
+14 FOR
SET BGUI=$QUERY(@BGUI)
IF $EXTRACT(BGUI,1,BGUCKL)'=BGUCK
QUIT
DO WRITE(@BGUI)
+15 KILL @BGUDATA
End DoDot:1
+16 IF BGUIP'=""
WRITE $CHAR(4,13,10)
IF 'BGUMSM
WRITE !
+17 QUIT
+18 ;
WRITE(BGUX) ;
+1 IF '$GET(BGUWEB)
WRITE BGUX,BGURS
QUIT
+2 SET BGUX1=BGUHTMLS
SET $EXTRACT(BGUX1,43)=BGUX
WRITE BGUX1
+3 QUIT
+4 ;
PGHDR ;
+1 WRITE "<HTML><HEAD>"
+2 WRITE "<SCRIPT LANGUAGE=""VBScript"">"
+3 WRITE "<!--",!
+4 WRITE "Sub Window_OnLoad()",!
+5 WRITE "document.frmInfo.submit",!
+6 WRITE "End Sub",!
+7 WRITE "-->"
+8 WRITE "</SCRIPT>"
+9 WRITE "<TITLE>LOGIN RESULTS</TITLE></HEAD>"
+10 WRITE "<BODY"
IF BGUBGRND'=""
WRITE " BACKGROUND=""",BGUBGRND,""""
WRITE ">"
+11 WRITE "<FORM NAME=""frmInfo"" METHOD=""POST"" ACTION="""_BGUASP_""">"
+12 QUIT
+13 ;
PGFTR ;
+1 WRITE "</FORM></BODY></HTML>"
+2 QUIT
+3 ;
OLDETRAP ; -- on trapped error, send error info to client
+1 ;I BGUTLEN U 56 W "-1",$C(30),"SERVER ERROR=",$$EC^%ZOSV_" LAST REF="_$$LGR^%ZOSV,$C(4,13,10)
+2 ;D ERR^ZU
+3 ;D ^%ZTER U 56
+4 ;G TCP
+5 ;
+6 ;ETRAP -- on trapped error, send error info to client
+7 ;N XWBERC,XWBERR
+8 ;S XWBERC=$$EC^%ZOSV
+9 ;G:XWBERC["<WRITE>" RESTART
+10 ;G:XWBERC["<READ>" RESTART
+11 ;S XWBERR="-1"_$C(30)_"M ERROR="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
+12 ;S XWBERR=$C(24)_"M ERROR="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
+13 ;Turn off trapping during trap.
+14 ;IF $$NEWERR^%ZTER S $ETRAP=""
+15 ;E S X="",@^%ZOSF("TRAP")
+16 ;U XWBTDEV
+17 ;D ^%ZTER ;%ZTER clears $ZE and $ZCODE
+18 ;U XWBTDEV
+19 ;IF XWBOS="MSM"!(XWBOS="OpenM") W XWBERR,! G RESTART
+20 ;IF XWBOS="DSM" D
+21
*** ERROR ***
+22 ;IF XWBOS'="DSM" D
+23 ;. D SNDERR W XWBERR,!
+24 ;I (XWBERR["READERR")!(XWBERR["DISCON")!(XWBERR["SYSTEM-F") D:$G(DUZ) LOGOUT^XUSRB HALT
+25 ;I '$$NEWERR^%ZTER G RESTART
+26 ;S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^BGUTCPH",$ECODE=",U99,"
+27 ;
+28 ;Q
ETRAP ; -- on trapped error, send error info to client
+1 NEW XWBERC,XWBERR
+2 ;Change trapping during trap.
+3 SET $ETRAP="D ^%ZTER H"
+4 ;S $ETRAP="G RESTART^BGUTCPH"
+5 SET XWBERC=$$EC^%ZOSV
SET XWBERR=$CHAR(24)_"M ERROR="_XWBERC_$CHAR(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
+6 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
+7 ;%ZTER clears $ZE and $ECODE
DO ^%ZTER
+8 IF (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")
IF $GET(DUZ)
DO LOGOUT^XUSRB
HALT
+9 USE XWBTDEV
+10 IF XWBOS="DSM"
Begin DoDot:1
+11 IF $DATA(XWBTLEN)
IF XWBTLEN
DO SNDERR
DO WRITE(XWBERR)
IF $X
WRITE !
End DoDot:1
+12 IF XWBOS'="DSM"
Begin DoDot:1
+13 DO SNDERR
DO WRITE(XWBERR)
IF $X
WRITE !
End DoDot:1
+14 ;S $ETRAP="G RESTART^BGUTCPH"
+15 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^BGUTCPH"
+16 GOTO RESTART
+17 QUIT
+18 ;
SNDERR ;send error information
+1 ;XWBSEC is the security packet, XWBERROR is application packet
+2 NEW X
+3 SET X=$GET(XWBSEC)
+4 WRITE $CHAR($LENGTH(X))_X
IF ($X+$LENGTH(X)+1)>512
WRITE !
+5 SET X=$GET(XWBERROR)
+6 WRITE $CHAR($LENGTH(X))_X
IF ($X+$LENGTH(X)+1)>512
WRITE !
+7 ;clears parameters
SET XWBERROR=""
+8 QUIT
+9 ;
LOGOUT ;
+1 IF '$DATA(BGUSEC)
QUIT
+2 SET $PIECE(^BGUSEC(BGUSEC,0),"^",4)=$$NOW^XLFDT
KILL ^BGUSEC("CUR",DUZ,BGUSEC)
+3 IF $PIECE($GET(^BGUSP(1,0)),"^",3)'="Y"
QUIT
+4 IF '$DATA(^BGUSEC(BGUSEC,0))
QUIT
+5 IF '$DATA(^BGUSEC(BGUSEC,20,0))
SET ^(0)="^90062.11A^0^0"
+6 SET X=""
FOR I=1:1
SET X=$ORDER(BGUSTAT(X))
IF X=""
QUIT
SET Y=X_U_BGUSTAT(X)
SET ^BGUSEC(BGUSEC,20,I,0)=$EXTRACT(Y,1,255)
+7 SET $PIECE(^BGUSEC(BGUSEC,20,0),"^",3,4)=I_"^"_I
+8 QUIT
