- 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 Feb 18, 2025@23:39:13 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
