XMRPCTS ;(KC-VAMC)/XXX-Steal TWIX's from PCTS Host [RCVR] ;03/18/2002 09:10
;;8.0;MailMan;;Jun 28, 2002
; Entry points used by MailMan options (not covered by DBIA):
; PCTS XMNET-TWIX-SEND
PCTS ;
S %=$$DSP("==>STARTING PCTS DIALOGUE<=="),XMRPCTS("R")=0
S XMCOUNT=0
ST I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XMRPCTSA"
E S X="ERR^XMRPCTSA",@^%ZOSF("TRAP")
D INIT^XMRPCTSA
S %=$$DSP("==>Handshaking with PCTS - This make take a while<==")
F I=1:1:3 R X:5 Q:$T
I X["MREQ" R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET!(XMMN'?1N.N) EXIT S %=$$DSP("==>MREQ") G MAK1
I X["MAOK" S %=$$DSP("==>MAOK") D ^XMRPCTS0 G EXIT ; We can send stuff here
I X["MEND"!(X[XMET) S %=$$DSP("==>MENDing<==") G EXIT
;S %=$$DSP("===>'"_X_"' Received / Not Understood !!!")
S XMCOUNT=XMCOUNT+1 G ST:XMCOUNT<3,EXIT
;
MAK1 W "MAK1",XMCR,XMLF,XMMN,XMCR,XMLF,XMET,XMCR S %=$$DSP("<==MAK1/"_XMMN),%=0
;
S XMCOUNT=0
MDTA F I=1:1:3 R X:5 Q:$T
I X["MDTA" R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET EXIT S %=$$DSP("==>MDTA, AMS Message #"_XMMN),XMSUB="PCTS==> AMS Message Number: "_XMMN G SH
I X["MEND"!(X[XMET) S %=$$DSP("==>MENDing<==") G EXIT
;S %=$$DSP("===>'"_X_"' Received & Not Understood !!!")
S XMCOUNT=XMCOUNT+1 G MDTA:XMCOUNT<3,EXIT
;
SH R X:5 G:'$T EXIT S XMHDR=$P(X,XMSH,2) S %=$$DSP("==>"_XMHDR),^TMP($J,1,0)=XMHDR,XMLPC=$$CSUM($C(XMLPC)_XMHDR_XMCR)
TT S X1="" F I=2:1 R X:5 Q:'$T D
.I X1["NNNN"&(($A($E(X,1)=10))&($A($E(X,2)=25))) R X2:5 Q
.S XMLPC=$$CSUM($C(XMLPC)_X_XMCR),X=$$STRLF(X),X1=X
.S ^TMP($J,I,0)=X,%=$$DSP("==>"_X)
I X1["NNNN" S ^TMP($J,I,0)="------ End of PCTS Message ------",%=$$DSP("==>NNNN Received") D CHKSUM(X) D XM^XMRPCTSA,REPLY^XMRPCTSA K X1 G ST
I X1'["NNNN" S %=$$DSP("==>No 'NNNN', End of Message Found") K X1 G EXIT
CHKSUM(X) ;Verify the Checksum, We MUST agree.
S XMLPC=$$CSUM($C(XMLPC)_XMLF) ;Add in that last LineFeed
S XMLPC=$E(XMDH,XMLPC\16+1)_$E(XMDH,XMLPC#16+1) ;The Magic Code
;U IO R X:5 S X=$P(X,$C(25),2) ;Em is 25
;S XMLPC=$S(X=XMLPC:1,1:0) ;Do the checksums match ?
;Hardwire checksum evaluation to be true
S XMLPC=1
S %=$$DSP("==>CHECKSUM "_$S(XMLPC:"OK",1:"FAILED")_"<==")
Q
DSP(XMTRAN) D TRAN^XMC1
Q "" ;Show us what is going on
;
EXIT X ^%ZOSF("TRMOFF")
K XMCR,XMLF,XMET,XMSH,XMLPC,XMLMN,XMMN,XMDH
S %=$$DSP("==>ENDING PCTS DIALOGUE & RETURNING TO MAILMAN SCRIPT<==")
F %="R","S" S XMCNT(%)=$S($G(XMRPCTS(%)):XMRPCTS(%),1:0)
Q
;
STRLF(X) ;Remove leading LineFeed(s) from String
N I F I=1:1:$L(X) Q:X'[$C(10) I $A(X)=10 S X=$E(X,2,$L(X))
Q (X)
CSUM(X) ;Calculate Checksum
N Y X ^%ZOSF("LPC") Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRPCTS 2621 printed Apr 09, 2024@21:14:18 Page 2
XMRPCTS ;(KC-VAMC)/XXX-Steal TWIX's from PCTS Host [RCVR] ;03/18/2002 09:10
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Entry points used by MailMan options (not covered by DBIA):
+3 ; PCTS XMNET-TWIX-SEND
PCTS ;
+1 SET %=$$DSP("==>STARTING PCTS DIALOGUE<==")
SET XMRPCTS("R")=0
+2 SET XMCOUNT=0
ST IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^XMRPCTSA"
+1 IF '$TEST
SET X="ERR^XMRPCTSA"
SET @^%ZOSF("TRAP")
+2 DO INIT^XMRPCTSA
+3 SET %=$$DSP("==>Handshaking with PCTS - This make take a while<==")
+4 FOR I=1:1:3
READ X:5
if $TEST
QUIT
+5 IF X["MREQ"
READ X:3
SET XMMN=$PIECE(X,XMLF,2)
if X[XMET!(XMMN'?1N.N)
GOTO EXIT
SET %=$$DSP("==>MREQ")
GOTO MAK1
+6 ; We can send stuff here
IF X["MAOK"
SET %=$$DSP("==>MAOK")
DO ^XMRPCTS0
GOTO EXIT
+7 IF X["MEND"!(X[XMET)
SET %=$$DSP("==>MENDing<==")
GOTO EXIT
+8 ;S %=$$DSP("===>'"_X_"' Received / Not Understood !!!")
+9 SET XMCOUNT=XMCOUNT+1
if XMCOUNT<3
GOTO ST
GOTO EXIT
+10 ;
MAK1 WRITE "MAK1",XMCR,XMLF,XMMN,XMCR,XMLF,XMET,XMCR
SET %=$$DSP("<==MAK1/"_XMMN)
SET %=0
+1 ;
+2 SET XMCOUNT=0
MDTA FOR I=1:1:3
READ X:5
if $TEST
QUIT
+1 IF X["MDTA"
READ X:3
SET XMMN=$PIECE(X,XMLF,2)
if X[XMET
GOTO EXIT
SET %=$$DSP("==>MDTA, AMS Message #"_XMMN)
SET XMSUB="PCTS==> AMS Message Number: "_XMMN
GOTO SH
+2 IF X["MEND"!(X[XMET)
SET %=$$DSP("==>MENDing<==")
GOTO EXIT
+3 ;S %=$$DSP("===>'"_X_"' Received & Not Understood !!!")
+4 SET XMCOUNT=XMCOUNT+1
if XMCOUNT<3
GOTO MDTA
GOTO EXIT
+5 ;
SH READ X:5
if '$TEST
GOTO EXIT
SET XMHDR=$PIECE(X,XMSH,2)
SET %=$$DSP("==>"_XMHDR)
SET ^TMP($JOB,1,0)=XMHDR
SET XMLPC=$$CSUM($CHAR(XMLPC)_XMHDR_XMCR)
TT SET X1=""
FOR I=2:1
READ X:5
if '$TEST
QUIT
Begin DoDot:1
+1 IF X1["NNNN"&(($ASCII($EXTRACT(X,1)=10))&($ASCII($EXTRACT(X,2)=25)))
READ X2:5
QUIT
+2 SET XMLPC=$$CSUM($CHAR(XMLPC)_X_XMCR)
SET X=$$STRLF(X)
SET X1=X
+3 SET ^TMP($JOB,I,0)=X
SET %=$$DSP("==>"_X)
End DoDot:1
+4 IF X1["NNNN"
SET ^TMP($JOB,I,0)="------ End of PCTS Message ------"
SET %=$$DSP("==>NNNN Received")
DO CHKSUM(X)
DO XM^XMRPCTSA
DO REPLY^XMRPCTSA
KILL X1
GOTO ST
+5 IF X1'["NNNN"
SET %=$$DSP("==>No 'NNNN', End of Message Found")
KILL X1
GOTO EXIT
CHKSUM(X) ;Verify the Checksum, We MUST agree.
+1 ;Add in that last LineFeed
SET XMLPC=$$CSUM($CHAR(XMLPC)_XMLF)
+2 ;The Magic Code
SET XMLPC=$EXTRACT(XMDH,XMLPC\16+1)_$EXTRACT(XMDH,XMLPC#16+1)
+3 ;U IO R X:5 S X=$P(X,$C(25),2) ;Em is 25
+4 ;S XMLPC=$S(X=XMLPC:1,1:0) ;Do the checksums match ?
+5 ;Hardwire checksum evaluation to be true
+6 SET XMLPC=1
+7 SET %=$$DSP("==>CHECKSUM "_$SELECT(XMLPC:"OK",1:"FAILED")_"<==")
+8 QUIT
DSP(XMTRAN) DO TRAN^XMC1
+1 ;Show us what is going on
QUIT ""
+2 ;
EXIT XECUTE ^%ZOSF("TRMOFF")
+1 KILL XMCR,XMLF,XMET,XMSH,XMLPC,XMLMN,XMMN,XMDH
+2 SET %=$$DSP("==>ENDING PCTS DIALOGUE & RETURNING TO MAILMAN SCRIPT<==")
+3 FOR %="R","S"
SET XMCNT(%)=$SELECT($GET(XMRPCTS(%)):XMRPCTS(%),1:0)
+4 QUIT
+5 ;
STRLF(X) ;Remove leading LineFeed(s) from String
+1 NEW I
FOR I=1:1:$LENGTH(X)
if X'[$CHAR(10)
QUIT
IF $ASCII(X)=10
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 QUIT (X)
CSUM(X) ;Calculate Checksum
+1 NEW Y
XECUTE ^%ZOSF("LPC")
QUIT Y
