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