Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XMRPCTS0

XMRPCTS0.m

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