XML4CRC1 ;(WASH ISC)/RFJ-Block Mode Protocol ;04/17/2002 10:57
;;8.0;MailMan;**45**;Jun 28, 2002;Build 8
OPEN D GET,OP
S:'$D(XMESC) XMESC=$C(126) S:'$D(XMFS) XMFS=255 S:'$D(XM) XM="" S (XMSSQ,XMRSQ)=1 Q
GET S X=XMCHAN,DIC="^DIC(3.4,",DIC(0)="Z" D ^DIC S XMCHAN=+Y
I '$D(^DIC(3.4,XMCHAN,0)) S ER=1,Y="Invalid channel" Q
G2 S XMPROT=$P(^DIC(3.4,XMCHAN,0),U,1)
F X=1:1:4 S @($P("XMSEN^XMREC^XMOPEN^XMCLOSE",U,X))=$S($D(^(X)):^(X),1:"Q")
Q
OP I $D(XMOPEN) X:$L(XMOPEN) XMOPEN
I '$D(XMQUIET) S X=255 X ^%ZOSF("RM")
Q
C X ^%ZOSF("EON")
I $D(XMCLOSE) X:$L(XMCLOSE) XMCLOSE
Q
SEND ;Sends XMSG, returns ER=0 or 1, and XMLER=number of "soft" errors
I $L(XMSG)>255 S XMLER=0,ER=1 G SRQ
I XMSG'?.ANP S X=XMSG,XMSG="" F %=1:1:$L(X) S:$E(X,%)'?1C!($A(X,%)=9) XMSG=XMSG_$E(X,%)
D SRINIT S X=XMSG,XMLCC=XMLCC+$L(XMSG) D SUM
SL S XMLER=XMLER+1 I (XMLER+1)>XMLMAXER D NEWSTRAT
I ER W XMLERR,$C(13) G SRQ
D BUFLUSH W XMSG,$C(13) W XMLINE,U,XMSUM,$C(13) R XMLX:XMLTIME G:XMLX=(XMLINE_U_XMLACK) SRQ
S XMLY=XMLX=(XMLINE_U_XMLNAK),XMLZ=0 D:'XMLY ENQ G SL:XMLY,SRQ
ENQ ;Assume the ACK/NAK was garbled by noise and try to re-establish contact
S XMLZ=XMLZ+1 I XMLZ>XMLMAXER S (ER,XMLY)=1 Q
D BUFLUSH W XMLENQ,$C(13) R XMLX:XMLTIME Q:XMLX=(XMLINE_U_XMLACK)
I XMLX[XMLACK!(XMLX[XMLNAK),+XMLX=XMLINE!(+XMLX=XMLINE-1) S XMLY=1 Q
H 1 G ENQ
REC ;Receives XMRG, returns ER=0 or 1, and XMLER=number of "soft" errors
D SRINIT S:'$D(XMLAN) XMLAN=XMLINE_U_XMLNAK
RL S XMLER=XMLER+1 I (XMLER+1)>XMLMAXER D NEWSTRAT I ER=1 G SRQ
R XMRG#255:$S($D(XMSTIME):XMSTIME,1:XMLTIME) S XMLCC=$S('$D(XMLCC):$L(XMRG),1:XMLCC+$L(XMRG)),XMLZ=$S('$T:-1,XMRG=XMLENQ:0,XMRG=XMLERR:2,1:1),%=2
S %=2 D PROG^XML4CRC I $D(XMLIN),XMLIN'<1 G REC^XML4CRC:XMRG["*"
S ER=XMLZ=2 G:XMLZ>1 SRQ I XMLZ<1 D BUFLUSH W XMLAN,$C(13) G RL
R XMLY:XMLTIME I +XMLY=XMLINE S X=XMRG D SUM S XMLZ=XMSUM=$P(XMLY,U,2) G RL2
S XMLZ=0 I +XMLY=(XMLINE-1),XMLINE'=1 D BUFLUSH W +XMLY,U,XMLACK,$C(13) G RL
RL2 D:$D(XMLBMER) KILL^XML4CRC S XMLAN=XMLINE_U_$S(XMLZ:XMLACK,1:XMLNAK) D BUFLUSH W XMLAN,$C(13)
G SRQ:XMLZ,RL
SRINIT ;Initialize variables for Send/Receive
I '$D(XMLBTST) S XMLBTST=+$H_","_($P($H,",",2)-.001),XMLCC=0 ;Time stamp when message started
S XMLINE=$S('$D(XMLINE):1,1:XMLINE+1),XMLACK="ACK",XMLNAK="NAK"
S XMLENQ=$C(9)_"ENQ"_$C(9),XMLERR=$C(9)_"ERROR"_$C(9)
S XMLER=-1 ;soft error count
S XMLMAXER=5 ;maximum allowable soft errors
S XMLTIME=10 ;length of READ time
S ER=0 ;non-recoverable error flag
Q
NEWSTRAT ;Select new strategy, one or both machines may be slow
I XMLMAXER=5 S ER=1 Q ;already tried new strategy, give up.
S XMTLER=$S('$D(XMTLER):XMLER,1:XMTLER+XMLER),XMLER=0 ;add to total
S XMLMAXER=5 ;reduce allowable soft errors
S XMLTIME=30 ;increase the READ time
Q
SRQ ;Exit from Send/Receive
S XMTLER=$S('$D(XMTLER):XMLER,1:XMTLER+XMLER) ;Total errors
K XMLACK,XMLNAK,XMLENQ,XMLERR,XMLMAXER,XMLTIME,XMLX,XMLY,XMLZ
Q
BUFLUSH ;Flush any characters out of the buffer
Q:'$D(XMBFLUSH)
X ^%ZOSF("TRMON") S X=$P($H,",",2) F %=1:1 R %:0 Q:'$T S %=$P($H,",",2) S:%<X %=%+86400 Q:%-X>15
X ^%ZOSF("TRMOFF") Q
SUM ;Calculate checksum, accounting also for the character's position
I '$D(XMOS) D LPC^XMLSWP0
I $D(XMOS(0)) X XMOS(0) Q
I XMOS["VAX DSM" X "S XMSUM=$ZC(%LPC,X)+$L(X)*$L(X)" Q
I XMOS["DSM" X "S XMSUM=$ZC(LPC,X)+$L(X)*$L(X)" Q
I XMOS["M/11"!(XMOS["M/VX") X "S XMSUM=$ZC(X)+$L(X)*$L(X)" Q
S XMSUM=0 F %=1:1:$L(X) S XMSUM=XMSUM+($A(X,%)*%)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXML4CRC1 3505 printed Dec 13, 2024@02:12:33 Page 2
XML4CRC1 ;(WASH ISC)/RFJ-Block Mode Protocol ;04/17/2002 10:57
+1 ;;8.0;MailMan;**45**;Jun 28, 2002;Build 8
OPEN DO GET
DO OP
+1 if '$DATA(XMESC)
SET XMESC=$CHAR(126)
if '$DATA(XMFS)
SET XMFS=255
if '$DATA(XM)
SET XM=""
SET (XMSSQ,XMRSQ)=1
QUIT
GET SET X=XMCHAN
SET DIC="^DIC(3.4,"
SET DIC(0)="Z"
DO ^DIC
SET XMCHAN=+Y
+1 IF '$DATA(^DIC(3.4,XMCHAN,0))
SET ER=1
SET Y="Invalid channel"
QUIT
G2 SET XMPROT=$PIECE(^DIC(3.4,XMCHAN,0),U,1)
+1 FOR X=1:1:4
SET @($PIECE("XMSEN^XMREC^XMOPEN^XMCLOSE",U,X))=$SELECT($DATA(^(X)):^(X),1:"Q")
+2 QUIT
OP IF $DATA(XMOPEN)
if $LENGTH(XMOPEN)
XECUTE XMOPEN
+1 IF '$DATA(XMQUIET)
SET X=255
XECUTE ^%ZOSF("RM")
+2 QUIT
C XECUTE ^%ZOSF("EON")
+1 IF $DATA(XMCLOSE)
if $LENGTH(XMCLOSE)
XECUTE XMCLOSE
+2 QUIT
SEND ;Sends XMSG, returns ER=0 or 1, and XMLER=number of "soft" errors
+1 IF $LENGTH(XMSG)>255
SET XMLER=0
SET ER=1
GOTO SRQ
+2 IF XMSG'?.ANP
SET X=XMSG
SET XMSG=""
FOR %=1:1:$LENGTH(X)
if $EXTRACT(X,%)'?1C!($ASCII(X,%)=9)
SET XMSG=XMSG_$EXTRACT(X,%)
+3 DO SRINIT
SET X=XMSG
SET XMLCC=XMLCC+$LENGTH(XMSG)
DO SUM
SL SET XMLER=XMLER+1
IF (XMLER+1)>XMLMAXER
DO NEWSTRAT
+1 IF ER
WRITE XMLERR,$CHAR(13)
GOTO SRQ
+2 DO BUFLUSH
WRITE XMSG,$CHAR(13)
WRITE XMLINE,U,XMSUM,$CHAR(13)
READ XMLX:XMLTIME
if XMLX=(XMLINE_U_XMLACK)
GOTO SRQ
+3 SET XMLY=XMLX=(XMLINE_U_XMLNAK)
SET XMLZ=0
if 'XMLY
DO ENQ
if XMLY
GOTO SL
GOTO SRQ
ENQ ;Assume the ACK/NAK was garbled by noise and try to re-establish contact
+1 SET XMLZ=XMLZ+1
IF XMLZ>XMLMAXER
SET (ER,XMLY)=1
QUIT
+2 DO BUFLUSH
WRITE XMLENQ,$CHAR(13)
READ XMLX:XMLTIME
if XMLX=(XMLINE_U_XMLACK)
QUIT
+3 IF XMLX[XMLACK!(XMLX[XMLNAK)
IF +XMLX=XMLINE!(+XMLX=XMLINE-1)
SET XMLY=1
QUIT
+4 HANG 1
GOTO ENQ
REC ;Receives XMRG, returns ER=0 or 1, and XMLER=number of "soft" errors
+1 DO SRINIT
if '$DATA(XMLAN)
SET XMLAN=XMLINE_U_XMLNAK
RL SET XMLER=XMLER+1
IF (XMLER+1)>XMLMAXER
DO NEWSTRAT
IF ER=1
GOTO SRQ
+1 READ XMRG#255:$SELECT($DATA(XMSTIME):XMSTIME,1:XMLTIME)
SET XMLCC=$SELECT('$DATA(XMLCC):$LENGTH(XMRG),1:XMLCC+$LENGTH(XMRG))
SET XMLZ=$SELECT('$TEST:-1,XMRG=XMLENQ:0,XMRG=XMLERR:2,1:1)
SET %=2
+2 SET %=2
DO PROG^XML4CRC
IF $DATA(XMLIN)
IF XMLIN'<1
if XMRG["*"
GOTO REC^XML4CRC
+3 SET ER=XMLZ=2
if XMLZ>1
GOTO SRQ
IF XMLZ<1
DO BUFLUSH
WRITE XMLAN,$CHAR(13)
GOTO RL
+4 READ XMLY:XMLTIME
IF +XMLY=XMLINE
SET X=XMRG
DO SUM
SET XMLZ=XMSUM=$PIECE(XMLY,U,2)
GOTO RL2
+5 SET XMLZ=0
IF +XMLY=(XMLINE-1)
IF XMLINE'=1
DO BUFLUSH
WRITE +XMLY,U,XMLACK,$CHAR(13)
GOTO RL
RL2 if $DATA(XMLBMER)
DO KILL^XML4CRC
SET XMLAN=XMLINE_U_$SELECT(XMLZ:XMLACK,1:XMLNAK)
DO BUFLUSH
WRITE XMLAN,$CHAR(13)
+1 if XMLZ
GOTO SRQ
GOTO RL
SRINIT ;Initialize variables for Send/Receive
+1 ;Time stamp when message started
IF '$DATA(XMLBTST)
SET XMLBTST=+$HOROLOG_","_($PIECE($HOROLOG,",",2)-.001)
SET XMLCC=0
+2 SET XMLINE=$SELECT('$DATA(XMLINE):1,1:XMLINE+1)
SET XMLACK="ACK"
SET XMLNAK="NAK"
+3 SET XMLENQ=$CHAR(9)_"ENQ"_$CHAR(9)
SET XMLERR=$CHAR(9)_"ERROR"_$CHAR(9)
+4 ;soft error count
SET XMLER=-1
+5 ;maximum allowable soft errors
SET XMLMAXER=5
+6 ;length of READ time
SET XMLTIME=10
+7 ;non-recoverable error flag
SET ER=0
+8 QUIT
NEWSTRAT ;Select new strategy, one or both machines may be slow
+1 ;already tried new strategy, give up.
IF XMLMAXER=5
SET ER=1
QUIT
+2 ;add to total
SET XMTLER=$SELECT('$DATA(XMTLER):XMLER,1:XMTLER+XMLER)
SET XMLER=0
+3 ;reduce allowable soft errors
SET XMLMAXER=5
+4 ;increase the READ time
SET XMLTIME=30
+5 QUIT
SRQ ;Exit from Send/Receive
+1 ;Total errors
SET XMTLER=$SELECT('$DATA(XMTLER):XMLER,1:XMTLER+XMLER)
+2 KILL XMLACK,XMLNAK,XMLENQ,XMLERR,XMLMAXER,XMLTIME,XMLX,XMLY,XMLZ
+3 QUIT
BUFLUSH ;Flush any characters out of the buffer
+1 if '$DATA(XMBFLUSH)
QUIT
+2 XECUTE ^%ZOSF("TRMON")
SET X=$PIECE($HOROLOG,",",2)
FOR %=1:1
READ %:0
if '$TEST
QUIT
SET %=$PIECE($HOROLOG,",",2)
if %<X
SET %=%+86400
if %-X>15
QUIT
+3 XECUTE ^%ZOSF("TRMOFF")
QUIT
SUM ;Calculate checksum, accounting also for the character's position
+1 IF '$DATA(XMOS)
DO LPC^XMLSWP0
+2 IF $DATA(XMOS(0))
XECUTE XMOS(0)
QUIT
+3 IF XMOS["VAX DSM"
XECUTE "S XMSUM=$ZC(%LPC,X)+$L(X)*$L(X)"
QUIT
+4 IF XMOS["DSM"
XECUTE "S XMSUM=$ZC(LPC,X)+$L(X)*$L(X)"
QUIT
+5 IF XMOS["M/11"!(XMOS["M/VX")
XECUTE "S XMSUM=$ZC(X)+$L(X)*$L(X)"
QUIT
+6 SET XMSUM=0
FOR %=1:1:$LENGTH(X)
SET XMSUM=XMSUM+($ASCII(X,%)*%)
+7 QUIT
