96 lines
3.5 KiB
Mathematica
96 lines
3.5 KiB
Mathematica
XMRPCTS0 ;(KC-VAMC)/XXX-Send TWIX's to PCTS Host [XMTR] ;03/21/2002 07:49
|
|
;;8.0;MailMan;;Jun 28, 2002
|
|
; Entry points used by MailMan options (not covered by DBIA):
|
|
; RQ XMNET-TWIX-TRANSMIT
|
|
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
|
; Walk through this Domains Transmit Basket and send them.
|
|
; If there is an error, record the error message, copy of
|
|
; the message, and drop to PCTS Mailgroup.
|
|
;-------------------------------------------------------------
|
|
D DSP^XMRPCTS("==>Checking for PCTS Messages to Transmit<==")
|
|
;Get domain # for the PCTS domain
|
|
S XMINST=$O(^DIC(4.2,"B","VHA.DMIA",0))
|
|
S XMK=XMINST+1000,XMDUZ=.5,XMZ=0,U="^" D INIT^XMRPCTSA S XMRPCTS("S")=0
|
|
WALK D DSP("==>Checking for messages in basket # "_XMK_"<==")
|
|
S XMZ=$O(^XMB(3.7,.5,2,XMK,1,XMZ)) G EXIT:XMZ<1
|
|
I '$D(^XMB(3.9,XMZ,0)) D ZAPIT^XMXMSGS2(.5,XMK,XMZ) G WALK ;Message is Gone?
|
|
D DSP("<==MREQ for local "_XMZ) W "MREQ",!,XMZ,!,"PCTS",!,"AMS",!,"TAB",!,XMET,XMCR S %=0
|
|
;
|
|
MREQ F I=1:1:3 R X:5 Q:$T
|
|
I X["MAK1" R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET!(XMMN'=XMZ) EXIT G REM
|
|
I X["MEND"!(X[XMET) D DSP("==>MENDing<==") G EXIT
|
|
S %=%+1 G MREQ:%<3,EXIT
|
|
REM R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET!(XMMN'?1N.N) EXIT
|
|
D DSP("==>MAK1 for REMOTE "_XMMN)
|
|
MDTA ;
|
|
D DSP("<==MDTA, Now Sending Message #"_XMZ)
|
|
S ^XMBS(4.2999,XMINST,3)=$H_"^"_XMZ_"^^^^DMI/MM-SSP" ; mailman status
|
|
W "MDTA",!,XMZ,!,XMMN,!,XMSH S XMLPC=0 ;Here we go!
|
|
F X=0:0 S X=$O(^XMB(3.9,XMZ,2,X)) Q:X<1 I $D(^(X,0)) S Z=^(0) D Q:$E(Z,1,6)["NNNN"
|
|
. N X,Y S X=$C(XMLPC)_Z_XMCR_XMLF X ^%ZOSF("LPC") S XMLPC=Y W Z,!
|
|
;S X=$C(XMLPC)_XMLF) X ^%ZOSF("LPC") S XMLPC=Y ;We like that extra lf calculated
|
|
S XMLPC=$E(XMDH,XMLPC\16+1)_$E(XMDH,XMLPC#16+1) ;The Magic Code
|
|
W $C(25),XMLPC,XMET,XMCR S %=1 ;Write the checksum
|
|
MAK2 F I=1:1:3 R X:5 Q:$T ;Look for the status of the one we just sent
|
|
I X["MAK2" S XMSTAT="Sent-> AMS Msg# "_XMMN R X:3 R X:3 D STAT S XMRPCTS("S")=XMRPCTS("S")+1 G WALK
|
|
I $E(X["MN") R X:3 R X:3 S XMSTAT="Error: "_$P(X,XMLF,2) D STAT,ERR G WALK
|
|
S %=%+1 G MAK2:%<3
|
|
;
|
|
D DSP("==>INVALID RESPONSE from RCVR, Expecting MAK2, Closing up")
|
|
G EXIT
|
|
;
|
|
Q
|
|
JD() ; Returns today's Julian date
|
|
N XMDDD,XMHHMM,XMNOW,XMDT
|
|
S XMNOW=$$NOW^XLFDT
|
|
S XMDT=$E(XMNOW,1,7)
|
|
S XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$E(XMDT,1,3)_"0101",1)+1,3,"0")
|
|
S XMHHMM=$$LJ^XLFSTR($E(XMNOW,9,12),4,"0")
|
|
Q XMDDD_XMHHMM
|
|
;
|
|
DSP(XMTRAN) ;
|
|
D TRAN^XMC1
|
|
S %="" ;Show us what is going on
|
|
Q
|
|
;
|
|
STAT ;Update the Mailman Status
|
|
S X=$O(^XMB(3.9,XMZ,1,"C","XXX@"_$P(^DIC(4.2,+XMINST,0),U),0))
|
|
I X>0 S $P(^XMB(3.9,XMZ,1,X,0),U,5,6)=$$DT_U_XMSTAT
|
|
S ^XMBS(4.2999,XMINST,3)="" ;Mailman Status
|
|
D ZAPIT^XMXMSGS2(.5,XMK,XMZ) ;Remove it from the Domains Basket
|
|
Q
|
|
ERR N %,X,XMSUB,XMTEXT,XMY,Y
|
|
D DSP("==>Recording Rejected Message #"_XMZ_" "_XMSTAT)
|
|
S XMTEXT="^XMB(3.9,"_XMZ_",2,"
|
|
N XMZ,DIC,XMDF
|
|
S XMSUB="PCTS Message Returned "_XMSTAT,XMDF=1
|
|
S XMY("G.PCTS")="" ; Mail group PCTS must be created on the system
|
|
S XMY(.5)=""
|
|
D ^XMD
|
|
Q ;Send it to the PostMaster anyway
|
|
;
|
|
DT() N X,Y,%DT S %DT="T",X="N" D ^%DT Q (Y)
|
|
EXIT D DSP("==>Quitting<==")
|
|
W "MEND",!
|
|
Q
|
|
RQ ;Force this domain to play its script, it plays regardless...
|
|
;Queue this puppy to run at regular intervals.
|
|
N XMDUZ,XMSITE,XMINST,XMB,%
|
|
S XMDUZ=.5
|
|
S XMSITE="VHA.DMIA"
|
|
S XMINST=$O(^DIC(4.2,"B",XMSITE,0))
|
|
I $D(ZTQUEUED) D I $$OBE^XMTDR(XMINST) G QQ
|
|
. S ZTREQ="@"
|
|
E I $$TSKEXIST^XMKPR(XMINST) G QQ
|
|
D SCRIPT^XMKPR1(XMINST,XMSITE,.XMB)
|
|
I 'XMB("SCR IEN") G QQ
|
|
D PLAY^XMTDR(XMINST,XMSITE,.XMB)
|
|
QQ ;
|
|
D DSP("Quitting from sending TWIX's")
|
|
;D KL1^XMC
|
|
L
|
|
K DIC,X,Y,XMDT,ZTPAR
|
|
Q:'$G(XMRPCTS0)
|
|
S XMCI=XMRPCTS0
|
|
Q
|