XML4CRC.m

XML4CRC ;(WASH ISC)/RFJ-Block Mode Protocol ;03/27/2002  15:47

 ;;8.0;MailMan;**45**;Jun 28, 2002;Build 9

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

XML4CRC   ;(WASH ISC)/RFJ-Block Mode Protocol ;03/27/2002  15:47

 +1       ;;8.0;MailMan;**45**;Jun 28, 2002;Build 9

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