source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMRPCTS0.m@ 703

Last change on this file since 703 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1XMRPCTS0 ;(KC-VAMC)/XXX-Send TWIX's to PCTS Host [XMTR] ;03/21/2002 07:49
2 ;;8.0;MailMan;;Jun 28, 2002
3 ; Entry points used by MailMan options (not covered by DBIA):
4 ; RQ XMNET-TWIX-TRANSMIT
5 ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6 ; Walk through this Domains Transmit Basket and send them.
7 ; If there is an error, record the error message, copy of
8 ; the message, and drop to PCTS Mailgroup.
9 ;-------------------------------------------------------------
10 D DSP^XMRPCTS("==>Checking for PCTS Messages to Transmit<==")
11 ;Get domain # for the PCTS domain
12 S XMINST=$O(^DIC(4.2,"B","VHA.DMIA",0))
13 S XMK=XMINST+1000,XMDUZ=.5,XMZ=0,U="^" D INIT^XMRPCTSA S XMRPCTS("S")=0
14WALK D DSP("==>Checking for messages in basket # "_XMK_"<==")
15 S XMZ=$O(^XMB(3.7,.5,2,XMK,1,XMZ)) G EXIT:XMZ<1
16 I '$D(^XMB(3.9,XMZ,0)) D ZAPIT^XMXMSGS2(.5,XMK,XMZ) G WALK ;Message is Gone?
17 D DSP("<==MREQ for local "_XMZ) W "MREQ",!,XMZ,!,"PCTS",!,"AMS",!,"TAB",!,XMET,XMCR S %=0
18 ;
19MREQ F I=1:1:3 R X:5 Q:$T
20 I X["MAK1" R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET!(XMMN'=XMZ) EXIT G REM
21 I X["MEND"!(X[XMET) D DSP("==>MENDing<==") G EXIT
22 S %=%+1 G MREQ:%<3,EXIT
23REM R X:3 S XMMN=$P(X,XMLF,2) G:X[XMET!(XMMN'?1N.N) EXIT
24 D DSP("==>MAK1 for REMOTE "_XMMN)
25MDTA ;
26 D DSP("<==MDTA, Now Sending Message #"_XMZ)
27 S ^XMBS(4.2999,XMINST,3)=$H_"^"_XMZ_"^^^^DMI/MM-SSP" ; mailman status
28 W "MDTA",!,XMZ,!,XMMN,!,XMSH S XMLPC=0 ;Here we go!
29 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"
30 . N X,Y S X=$C(XMLPC)_Z_XMCR_XMLF X ^%ZOSF("LPC") S XMLPC=Y W Z,!
31 ;S X=$C(XMLPC)_XMLF) X ^%ZOSF("LPC") S XMLPC=Y ;We like that extra lf calculated
32 S XMLPC=$E(XMDH,XMLPC\16+1)_$E(XMDH,XMLPC#16+1) ;The Magic Code
33 W $C(25),XMLPC,XMET,XMCR S %=1 ;Write the checksum
34MAK2 F I=1:1:3 R X:5 Q:$T ;Look for the status of the one we just sent
35 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
36 I $E(X["MN") R X:3 R X:3 S XMSTAT="Error: "_$P(X,XMLF,2) D STAT,ERR G WALK
37 S %=%+1 G MAK2:%<3
38 ;
39 D DSP("==>INVALID RESPONSE from RCVR, Expecting MAK2, Closing up")
40 G EXIT
41 ;
42 Q
43JD() ; Returns today's Julian date
44 N XMDDD,XMHHMM,XMNOW,XMDT
45 S XMNOW=$$NOW^XLFDT
46 S XMDT=$E(XMNOW,1,7)
47 S XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$E(XMDT,1,3)_"0101",1)+1,3,"0")
48 S XMHHMM=$$LJ^XLFSTR($E(XMNOW,9,12),4,"0")
49 Q XMDDD_XMHHMM
50 ;
51DSP(XMTRAN) ;
52 D TRAN^XMC1
53 S %="" ;Show us what is going on
54 Q
55 ;
56STAT ;Update the Mailman Status
57 S X=$O(^XMB(3.9,XMZ,1,"C","XXX@"_$P(^DIC(4.2,+XMINST,0),U),0))
58 I X>0 S $P(^XMB(3.9,XMZ,1,X,0),U,5,6)=$$DT_U_XMSTAT
59 S ^XMBS(4.2999,XMINST,3)="" ;Mailman Status
60 D ZAPIT^XMXMSGS2(.5,XMK,XMZ) ;Remove it from the Domains Basket
61 Q
62ERR N %,X,XMSUB,XMTEXT,XMY,Y
63 D DSP("==>Recording Rejected Message #"_XMZ_" "_XMSTAT)
64 S XMTEXT="^XMB(3.9,"_XMZ_",2,"
65 N XMZ,DIC,XMDF
66 S XMSUB="PCTS Message Returned "_XMSTAT,XMDF=1
67 S XMY("G.PCTS")="" ; Mail group PCTS must be created on the system
68 S XMY(.5)=""
69 D ^XMD
70 Q ;Send it to the PostMaster anyway
71 ;
72DT() N X,Y,%DT S %DT="T",X="N" D ^%DT Q (Y)
73EXIT D DSP("==>Quitting<==")
74 W "MEND",!
75 Q
76RQ ;Force this domain to play its script, it plays regardless...
77 ;Queue this puppy to run at regular intervals.
78 N XMDUZ,XMSITE,XMINST,XMB,%
79 S XMDUZ=.5
80 S XMSITE="VHA.DMIA"
81 S XMINST=$O(^DIC(4.2,"B",XMSITE,0))
82 I $D(ZTQUEUED) D I $$OBE^XMTDR(XMINST) G QQ
83 . S ZTREQ="@"
84 E I $$TSKEXIST^XMKPR(XMINST) G QQ
85 D SCRIPT^XMKPR1(XMINST,XMSITE,.XMB)
86 I 'XMB("SCR IEN") G QQ
87 D PLAY^XMTDR(XMINST,XMSITE,.XMB)
88QQ ;
89 D DSP("Quitting from sending TWIX's")
90 ;D KL1^XMC
91 L
92 K DIC,X,Y,XMDT,ZTPAR
93 Q:'$G(XMRPCTS0)
94 S XMCI=XMRPCTS0
95 Q
Note: See TracBrowser for help on using the repository browser.