XML4CRC ;(WASH ISC)/RFJ-Block Mode Protocol ;03/27/2002 15:47
;;8.0;MailMan;**45**;Jun 28, 2002;Build 8
SEND ;Sender
S %=1 D PROG G SEND^XML4CRC1:'$D(XMBLOCK)!'$D(J),SEND^XML4CRC1:J<1
S:'$D(XMLBTSUM) XMLBTSUM=0,XML4S(0)=0 I '$D(XML4S)!'$D(XMLBCHR) D SINIT Q:ER S XMLBER=0
I XMSG'?.ANP S X=XMSG,XMSG="" F %=1:1:$L(X) S:$E(X,%)'?1C!($A(X,%)=9) XMSG=XMSG_$E(X,%)
S XMSG=XMSG_XMLBCHR,X=XMSG D SUM,BUFLUSH
W XMSG,$C(13)
S XMLBTSUM=XMLBTSUM+XMSUM,XMLINE=XMLINE+1,XMLCC=XMLCC+$L(XMSG)
I XMLINE#4=0 H 1
D PAUSE S %=1,XML4S(0)=XML4S(0)+1 I $S(XML4S(0)#XML4S=0:1,'$D(XML4END):0,XMS0AJ'<XML4END:1,1:0) S %=1 D STAT,SCHECK S XMLBTSUM=0,XML4S(0)=0 Q
I '$D(XML4END) S XMLBVAR=$O(^XMB(3.9,XMZ,2,XMS0AJ)) I XMLBVAR<1 D SCHECK S XMLBTSUM=0,XML4S(0)=0
Q
SINIT ;
D BLSIZE,LAST I '$D(XMLCC) S XMLCC=0
S XMLBPAUS=1,XMLBNAK="NAK",XMLBACK="ACK",XMLBCHR=$C(42),XMLBCHR1=$C(42)_$C(126),XMLBMER=4,XMLBTIME=90,XMLBTSUM=0,ER=0,XMLBER=0,XMLBCHR2=$C(126)_$C(42)_$C(126),XMLBSTRT="0^0",X="HELO BMP"_U_XMLBMER D SUM
SBLSZ S XMLINE=XMLINE+1 W X,XMLBCHR1,XMSUM,$C(13) R %:XMLBTIME
I %[XMLBACK S X=% Q
D SBERROR S XMLBPAUS=XMLBPAUS+10 G SBLSZ:XMLBPAUS<1000 S X=% G ER
SCHECK ;Sender check block sum
S XMLINE=XMLINE+1,XMTRAN="Sent Checksum" D T W XMLBCHR2,U,J,U,XMLBTSUM,U,XMLINE,$C(13) R X:XMLBTIME E G ER
I X[XMLBACK S XMLBER=0,XMLBSTRT=XMS0AJ_U_J D BLSIZE Q
I X[XMLBNAK D ERROR Q:ER S XMS0AJ=+XMLBSTRT,J=+$P(XMLBSTRT,U,2),XMTRAN="Rec'd NAK" D T S:XML4S>2 XML4S=XML4S\2 Q
ER D ER1 Q
ER1 N % S %=0
ER2 S XMTRAN="Rec'd "_$G(X) D T R X:9 I $T S %=$G(%)+1 I %<99 G ER2:$T
S ER=1 K XMBLOCK Q
SBERROR ;
N X D ERROR Q
REC ;Receiver
I '$D(XMLBMER) D RINIT S XMLIN=0 Q
I XMLBCHR2_"^"=$E(XMRG,1,4) S %=2 D STAT,RCHECK S XMLBTSUM=0 Q
S X=XMRG D SUM S XMLBTSUM=XMLBTSUM+XMSUM,XMRG=$E(XMRG,1,($L(XMRG)-1)),XMLBMSG=XMRG Q
RINIT ;
S XMLBPAUS=0,XMLBER=0,XMLBMER=4,XMLBTIME=15,XMLBNAK="NAK",XMLBACK="ACK",XMLBCHR=$C(42),XMLBCHR1=$C(42)_$C(126),XMLBCHR2=$C(126)_$C(42)_$C(126),XMLBLINE=XMLIN,XMLBTSUM=0,XMLBMSG="",XMLBSTRT=XMLIN-1,XML4S(0)=0,XML4S=0
S X=$P(XMRG,XMLBCHR1,1) D SUM I XMSUM=$P(XMRG,XMLBCHR1,2) S XMLBMER=$P(X,U,2),XMLBER=0 W XMLBACK,$C(13) Q
W XMLBNAK,$C(13) D ERROR K XMLBMER Q
RCHECK ;Check block sum
I XMLBTSUM=0,XML4S(0)=0 G REC^XML4CRC1
S XMLINE=$P(XMRG,U,4),XMLIN=XMLIN-1,XMRG=$P(XMRG,U,2,3),X=XMLIN_U_XMLBTSUM I XMRG=X W XMLBACK,$C(13) S XMLBER=0,XMRG=XMLBMSG,XMLBSTRT=XMLIN Q
W XMLBNAK,$C(13) S XMLIN=XMLBSTRT,XMRG=$S($D(^XMB(3.9,XMZ,2,XMLIN,0)):^(0),1:""),XMTRAN="NAK'd block" D ERROR,T Q
ERROR ;Log error, new delay factor
D BUFLUSH S XMLBER=XMLBER+1,XMTLER=XMTLER+1 S:XMTLER#XMLBMER=0 XMLBPAUS=XMLBPAUS*2 D:XMLBPAUS>1000 END 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
PAUSE ;Delay
F %=1:1:XMLBPAUS
Q
PROG ;Statistics
S %1=$S(%=1:$S('$D(XMSG):0,1:$L(XMSG)),1:$S($D(XMRG):$L(XMRG),1:0)),XMLCT=$S($D(XMLCT):XMLCT+%1,1:%1)
Q
STAT Q:$S('$D(XMINST):1,'$L(XMINST):1,1:0)
S %1=$H_U_$S($D(XMZ):XMZ,1:"")_U_XMLINE_U_$S($D(XMTLER):XMTLER+XMLER-1,1:XMLER-1)_U_$J(XMLCC/($H-XMLBTST*86400+($P($H,",",2)-$P(XMLBTST,",",2))),0,2)_U_IO_" "_XMPROT
S %0=$S($D(^XMBS(4.2999,XMINST,3))#10:^(3),1:""),$P(%0,U,1,6)=%1,^(3)=%0,XMLCT=0,XMLL=XMLINE,XMLT=$P($H,",",2)
K %,%1,%0 Q
BLSIZE ;block size
S XML4S=$S($D(XML4S)#10=0:100,XML4S*2<100:XML4S*2,1:100),XML4S(0)=0 Q
LAST ;FIND LAST LINE
K XML4END S %=$P(^XMB(3.9,XMZ,2,0),U,3) I '% S %=^(0,0,99999999),%=$P(%,U,$L(%,U)-1)
Q:'$D(^XMB(3.9,XMZ,2,%)) F %=%-1:0 S Y=$O(^(%)) Q:Y="" S %=Y
S XML4END=% Q
SUM ;Calculate Checksum
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 Q
KILL ;Kill variables
K XMBLOCK,XMLBTSUM,XML4S,XMLBER,XMLBCHR,XMLBCHR1,XMLBCHR2,XMLBVAR,XMLBPAUS,XMLBNAK,XMLBACK,XMLBMER,XMLBTIME,XMLBSTRT,XMLBLINE,XMLBMSG Q
END ;Errors/Quit.
G ER
T D TRAN^XMC1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXML4CRC 4121 printed Jan 18, 2025@03:13:34 Page 2
XML4CRC ;(WASH ISC)/RFJ-Block Mode Protocol ;03/27/2002 15:47
+1 ;;8.0;MailMan;**45**;Jun 28, 2002;Build 8
SEND ;Sender
+1 SET %=1
DO PROG
if '$DATA(XMBLOCK)!'$DATA(J)
GOTO SEND^XML4CRC1
if J<1
GOTO SEND^XML4CRC1
+2 if '$DATA(XMLBTSUM)
SET XMLBTSUM=0
SET XML4S(0)=0
IF '$DATA(XML4S)!'$DATA(XMLBCHR)
DO SINIT
if ER
QUIT
SET XMLBER=0
+3 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,%)
+4 SET XMSG=XMSG_XMLBCHR
SET X=XMSG
DO SUM
DO BUFLUSH
+5 WRITE XMSG,$CHAR(13)
+6 SET XMLBTSUM=XMLBTSUM+XMSUM
SET XMLINE=XMLINE+1
SET XMLCC=XMLCC+$LENGTH(XMSG)
+7 IF XMLINE#4=0
HANG 1
+8 DO PAUSE
SET %=1
SET XML4S(0)=XML4S(0)+1
IF $SELECT(XML4S(0)#XML4S=0:1,'$DATA(XML4END):0,XMS0AJ'<XML4END:1,1:0)
SET %=1
DO STAT
DO SCHECK
SET XMLBTSUM=0
SET XML4S(0)=0
QUIT
+9 IF '$DATA(XML4END)
SET XMLBVAR=$ORDER(^XMB(3.9,XMZ,2,XMS0AJ))
IF XMLBVAR<1
DO SCHECK
SET XMLBTSUM=0
SET XML4S(0)=0
+10 QUIT
SINIT ;
+1 DO BLSIZE
DO LAST
IF '$DATA(XMLCC)
SET XMLCC=0
+2 SET XMLBPAUS=1
SET XMLBNAK="NAK"
SET XMLBACK="ACK"
SET XMLBCHR=$CHAR(42)
SET XMLBCHR1=$CHAR(42)_$CHAR(126)
SET XMLBMER=4
SET XMLBTIME=90
SET XMLBTSUM=0
SET ER=0
SET XMLBER=0
SET XMLBCHR2=$CHAR(126)_$CHAR(42)_$CHAR(126)
SET XMLBSTRT="0^0"
SET X="HELO BMP"_U_XMLBMER
DO SUM
SBLSZ SET XMLINE=XMLINE+1
WRITE X,XMLBCHR1,XMSUM,$CHAR(13)
READ %:XMLBTIME
+1 IF %[XMLBACK
SET X=%
QUIT
+2 DO SBERROR
SET XMLBPAUS=XMLBPAUS+10
if XMLBPAUS<1000
GOTO SBLSZ
SET X=%
GOTO ER
SCHECK ;Sender check block sum
+1 SET XMLINE=XMLINE+1
SET XMTRAN="Sent Checksum"
DO T
WRITE XMLBCHR2,U,J,U,XMLBTSUM,U,XMLINE,$CHAR(13)
READ X:XMLBTIME
IF '$TEST
GOTO ER
+2 IF X[XMLBACK
SET XMLBER=0
SET XMLBSTRT=XMS0AJ_U_J
DO BLSIZE
QUIT
+3 IF X[XMLBNAK
DO ERROR
if ER
QUIT
SET XMS0AJ=+XMLBSTRT
SET J=+$PIECE(XMLBSTRT,U,2)
SET XMTRAN="Rec'd NAK"
DO T
if XML4S>2
SET XML4S=XML4S\2
QUIT
ER DO ER1
QUIT
ER1 NEW %
SET %=0
ER2 SET XMTRAN="Rec'd "_$GET(X)
DO T
READ X:9
IF $TEST
SET %=$GET(%)+1
IF %<99
if $TEST
GOTO ER2
+1 SET ER=1
KILL XMBLOCK
QUIT
SBERROR ;
+1 NEW X
DO ERROR
QUIT
REC ;Receiver
+1 IF '$DATA(XMLBMER)
DO RINIT
SET XMLIN=0
QUIT
+2 IF XMLBCHR2_"^"=$EXTRACT(XMRG,1,4)
SET %=2
DO STAT
DO RCHECK
SET XMLBTSUM=0
QUIT
+3 SET X=XMRG
DO SUM
SET XMLBTSUM=XMLBTSUM+XMSUM
SET XMRG=$EXTRACT(XMRG,1,($LENGTH(XMRG)-1))
SET XMLBMSG=XMRG
QUIT
RINIT ;
+1 SET XMLBPAUS=0
SET XMLBER=0
SET XMLBMER=4
SET XMLBTIME=15
SET XMLBNAK="NAK"
SET XMLBACK="ACK"
SET XMLBCHR=$CHAR(42)
SET XMLBCHR1=$CHAR(42)_$CHAR(126)
SET XMLBCHR2=$CHAR(126)_$CHAR(42)_$CHAR(126)
SET XMLBLINE=XMLIN
SET XMLBTSUM=0
SET XMLBMSG=""
SET XMLBSTRT=XMLIN-1
SET XML4S(0)=0
SET XML4S=0
+2 SET X=$PIECE(XMRG,XMLBCHR1,1)
DO SUM
IF XMSUM=$PIECE(XMRG,XMLBCHR1,2)
SET XMLBMER=$PIECE(X,U,2)
SET XMLBER=0
WRITE XMLBACK,$CHAR(13)
QUIT
+3 WRITE XMLBNAK,$CHAR(13)
DO ERROR
KILL XMLBMER
QUIT
RCHECK ;Check block sum
+1 IF XMLBTSUM=0
IF XML4S(0)=0
GOTO REC^XML4CRC1
+2 SET XMLINE=$PIECE(XMRG,U,4)
SET XMLIN=XMLIN-1
SET XMRG=$PIECE(XMRG,U,2,3)
SET X=XMLIN_U_XMLBTSUM
IF XMRG=X
WRITE XMLBACK,$CHAR(13)
SET XMLBER=0
SET XMRG=XMLBMSG
SET XMLBSTRT=XMLIN
QUIT
+3 WRITE XMLBNAK,$CHAR(13)
SET XMLIN=XMLBSTRT
SET XMRG=$SELECT($DATA(^XMB(3.9,XMZ,2,XMLIN,0)):^(0),1:"")
SET XMTRAN="NAK'd block"
DO ERROR
DO T
QUIT
ERROR ;Log error, new delay factor
+1 DO BUFLUSH
SET XMLBER=XMLBER+1
SET XMTLER=XMTLER+1
if XMTLER#XMLBMER=0
SET XMLBPAUS=XMLBPAUS*2
if XMLBPAUS>1000
DO END
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
PAUSE ;Delay
+1 FOR %=1:1:XMLBPAUS
+2 QUIT
PROG ;Statistics
+1 SET %1=$SELECT(%=1:$SELECT('$DATA(XMSG):0,1:$LENGTH(XMSG)),1:$SELECT($DATA(XMRG):$LENGTH(XMRG),1:0))
SET XMLCT=$SELECT($DATA(XMLCT):XMLCT+%1,1:%1)
+2 QUIT
STAT if $SELECT('$DATA(XMINST)
QUIT
+1 SET %1=$HOROLOG_U_$SELECT($DATA(XMZ):XMZ,1:"")_U_XMLINE_U_$SELECT($DATA(XMTLER):XMTLER+XMLER-1,1:XMLER-1)_U_$JUSTIFY(XMLCC/($HOROLOG-XMLBTST*86400+($PIECE($HOROLOG,",",2)-$PIECE(XMLBTST,",",2))),0,2)_U_IO_" "_XMPROT
+2 SET %0=$SELECT($DATA(^XMBS(4.2999,XMINST,3))#10:^(3),1:"")
SET $PIECE(%0,U,1,6)=%1
SET ^(3)=%0
SET XMLCT=0
SET XMLL=XMLINE
SET XMLT=$PIECE($HOROLOG,",",2)
+3 KILL %,%1,%0
QUIT
BLSIZE ;block size
+1 SET XML4S=$SELECT($DATA(XML4S)#10=0:100,XML4S*2<100:XML4S*2,1:100)
SET XML4S(0)=0
QUIT
LAST ;FIND LAST LINE
+1 KILL XML4END
SET %=$PIECE(^XMB(3.9,XMZ,2,0),U,3)
IF '%
SET %=^(0,0,99999999)
SET %=$PIECE(%,U,$LENGTH(%,U)-1)
+2 if '$DATA(^XMB(3.9,XMZ,2,%))
QUIT
FOR %=%-1:0
SET Y=$ORDER(^(%))
if Y=""
QUIT
SET %=Y
+3 SET XML4END=%
QUIT
SUM ;Calculate Checksum
+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
QUIT
KILL ;Kill variables
+1 KILL XMBLOCK,XMLBTSUM,XML4S,XMLBER,XMLBCHR,XMLBCHR1,XMLBCHR2,XMLBVAR,XMLBPAUS,XMLBNAK,XMLBACK,XMLBMER,XMLBTIME,XMLBSTRT,XMLBLINE,XMLBMSG
QUIT
END ;Errors/Quit.
+1 GOTO ER
T DO TRAN^XMC1
QUIT
