- XML ;(WASH ISC)/THM/GJL-MailMan Physical link ;06/04/2002 08:26
- ;;8.0;MailMan;;Jun 28, 2002
- ; Entry points (DBIA 1283):
- ; GET - Set up variables for communications protocol in file 3.4
- ;
- ; Entry points used by MailMan options (not covered by DBIA):
- ; C XMDXPROT
- OPEN ;
- N Y
- I $G(XMCHAN)="" S XMCHAN="SCP"
- D GET Q:ER
- D OP Q:ER
- S:'$D(XMESC) XMESC="~"
- S:'$D(XMFS) XMFS=255
- S:'$D(XM) XM=""
- Q
- GET ; Set up variables for communications protocol in file 3.4
- ; In:
- ; XMCHAN - Name of the communications protocol
- ; Out:
- ; XMCHAN - IEN of the communications protocol
- ; XMPROT - Name of the communications protocol
- ; XMSEN - Xecute this variable to send a line
- ; XMREC - Xecute this variable to receive a line
- ; XMOPEN - Xecute this variable to open the channel
- ; XMCLOSE - Xecute this variable to close the channel
- ; XMOS - Operating System, used in ^XMLTCP
- N DIC,X
- S X=XMCHAN,DIC="^DIC(3.4,",DIC(0)="FO"
- D ^DIC I Y<0 D Q
- . D ERTRAN^XMC1(42244,XMCHAN) ;Invalid Communications Protocol: '|1|'
- . S Y=XMTRAN
- S XMCHAN=+Y,XMPROT=$P(Y,U,2)
- S XMSEN=$G(^DIC(3.4,XMCHAN,1),"Q"),XMREC=$G(^(2),"Q"),XMOPEN=$G(^(3),"Q"),XMCLOSE=$G(^(4),"Q")
- S XMOS=^%ZOSF("OS")
- I XMOS["MSM" D
- . S XMOS("MSMVER")=$P($ZV," 4.0.",2)
- . S:+XMOS("MSMVER")=0 XMOS("MSMVER")=8
- Q
- OP ;
- I "Q"'[$G(XMOPEN) X XMOPEN
- I 'XMC("BATCH"),'$D(XMQUIET) S X=255 X ^%ZOSF("RM")
- Q
- C X ^%ZOSF("EON")
- I $D(XMCLOSE) X:$L(XMCLOSE) XMCLOSE
- Q
- ; The following has nothing to do with the above.
- ; These are used by the SCP Communications Protocol in file 3.4.
- 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 F %=1:1:$L(XMSG) I $E(XMSG,%)?1C,$A(XMSG,%)'=9 S XMSG=$E(XMSG,1,%-1)_$E(XMSG,%+1,999) Q:XMSG?.ANP S %=%-1
- D SRINIT S X=XMSG D SUM
- I $G(XMINST) D XMTSTAT^XMTDR(XMINST,"S",XMSG,0)
- 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 ; ACK/NAK garbled - 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
- I $D(XMRG),$G(XMINST) D XMTSTAT^XMTDR(XMINST,"R",XMRG,0)
- 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 XMLZ=$S('$T:-1,XMRG=XMLENQ:0,XMRG=XMLERR:2,1:1)
- S ER=XMLZ=2 G:XMLZ>1 SRQ I 'XMLZ 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 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
- 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=30 ;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 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
- S XMSUM=0 F %=1:1:$L(X) S XMSUM=XMSUM+($A(X,%)*%)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXML 4121 printed Jan 18, 2025@03:13:32 Page 2
- XML ;(WASH ISC)/THM/GJL-MailMan Physical link ;06/04/2002 08:26
- +1 ;;8.0;MailMan;;Jun 28, 2002
- +2 ; Entry points (DBIA 1283):
- +3 ; GET - Set up variables for communications protocol in file 3.4
- +4 ;
- +5 ; Entry points used by MailMan options (not covered by DBIA):
- +6 ; C XMDXPROT
- OPEN ;
- +1 NEW Y
- +2 IF $GET(XMCHAN)=""
- SET XMCHAN="SCP"
- +3 DO GET
- if ER
- QUIT
- +4 DO OP
- if ER
- QUIT
- +5 if '$DATA(XMESC)
- SET XMESC="~"
- +6 if '$DATA(XMFS)
- SET XMFS=255
- +7 if '$DATA(XM)
- SET XM=""
- +8 QUIT
- GET ; Set up variables for communications protocol in file 3.4
- +1 ; In:
- +2 ; XMCHAN - Name of the communications protocol
- +3 ; Out:
- +4 ; XMCHAN - IEN of the communications protocol
- +5 ; XMPROT - Name of the communications protocol
- +6 ; XMSEN - Xecute this variable to send a line
- +7 ; XMREC - Xecute this variable to receive a line
- +8 ; XMOPEN - Xecute this variable to open the channel
- +9 ; XMCLOSE - Xecute this variable to close the channel
- +10 ; XMOS - Operating System, used in ^XMLTCP
- +11 NEW DIC,X
- +12 SET X=XMCHAN
- SET DIC="^DIC(3.4,"
- SET DIC(0)="FO"
- +13 DO ^DIC
- IF Y<0
- Begin DoDot:1
- +14 ;Invalid Communications Protocol: '|1|'
- DO ERTRAN^XMC1(42244,XMCHAN)
- +15 SET Y=XMTRAN
- End DoDot:1
- QUIT
- +16 SET XMCHAN=+Y
- SET XMPROT=$PIECE(Y,U,2)
- +17 SET XMSEN=$GET(^DIC(3.4,XMCHAN,1),"Q")
- SET XMREC=$GET(^(2),"Q")
- SET XMOPEN=$GET(^(3),"Q")
- SET XMCLOSE=$GET(^(4),"Q")
- +18 SET XMOS=^%ZOSF("OS")
- +19 IF XMOS["MSM"
- Begin DoDot:1
- +20 SET XMOS("MSMVER")=$PIECE($ZV," 4.0.",2)
- +21 if +XMOS("MSMVER")=0
- SET XMOS("MSMVER")=8
- End DoDot:1
- +22 QUIT
- OP ;
- +1 IF "Q"'[$GET(XMOPEN)
- XECUTE XMOPEN
- +2 IF 'XMC("BATCH")
- IF '$DATA(XMQUIET)
- SET X=255
- XECUTE ^%ZOSF("RM")
- +3 QUIT
- C XECUTE ^%ZOSF("EON")
- +1 IF $DATA(XMCLOSE)
- if $LENGTH(XMCLOSE)
- XECUTE XMCLOSE
- +2 QUIT
- +3 ; The following has nothing to do with the above.
- +4 ; These are used by the SCP Communications Protocol in file 3.4.
- 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
- FOR %=1:1:$LENGTH(XMSG)
- IF $EXTRACT(XMSG,%)?1C
- IF $ASCII(XMSG,%)'=9
- SET XMSG=$EXTRACT(XMSG,1,%-1)_$EXTRACT(XMSG,%+1,999)
- if XMSG?.ANP
- QUIT
- SET %=%-1
- +3 DO SRINIT
- SET X=XMSG
- DO SUM
- +4 IF $GET(XMINST)
- DO XMTSTAT^XMTDR(XMINST,"S",XMSG,0)
- 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 ; ACK/NAK garbled - 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
- +2 IF $DATA(XMRG)
- IF $GET(XMINST)
- DO XMTSTAT^XMTDR(XMINST,"R",XMRG,0)
- 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)
- +2 SET XMLZ=$SELECT('$TEST:-1,XMRG=XMLENQ:0,XMRG=XMLERR:2,1:1)
- +3 SET ER=XMLZ=2
- if XMLZ>1
- GOTO SRQ
- IF 'XMLZ
- DO BUFLUSH
- WRITE XMLAN,$CHAR(13)
- GOTO RL
- +4 READ XMLY:XMLTIME
- +5 IF +XMLY=XMLINE
- SET X=XMRG
- DO SUM
- SET XMLZ=XMSUM=$PIECE(XMLY,U,2)
- GOTO RL2
- +6 SET XMLZ=0
- IF +XMLY=(XMLINE-1)
- IF XMLINE'=1
- DO BUFLUSH
- WRITE +XMLY,U,XMLACK,$CHAR(13)
- GOTO RL
- RL2 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 SET XMLINE=$SELECT('$DATA(XMLINE):1,1:XMLINE+1)
- SET XMLACK="ACK"
- SET XMLNAK="NAK"
- +2 SET XMLENQ=$CHAR(9)_"ENQ"_$CHAR(9)
- SET XMLERR=$CHAR(9)_"ERROR"_$CHAR(9)
- +3 ;soft error count
- SET XMLER=-1
- +4 ;maximum allowable soft errors
- SET XMLMAXER=5
- +5 ;length of READ time
- SET XMLTIME=30
- +6 ;non-recoverable error flag
- SET ER=0
- +7 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 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")
- +4 QUIT
- SUM ; Calculate checksum, accounting also for the character's position
- +1 SET XMSUM=0
- FOR %=1:1:$LENGTH(X)
- SET XMSUM=XMSUM+($ASCII(X,%)*%)
- +2 QUIT