XMRPCTS1 ;(KC-VAMC)/XXX-Simple PCTS front end to MailMan ;02/06/99 10:32
;;8.0;MailMan;;Jun 28, 2002
N XMUS,XMFM,XMSTR,XMRI,XMTO,XMABORT
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;All should be sent to XXX@VHA.DMIA the local PCTS Domain
;Edit these for your site.
S XMUS="XXXX" ;Local routing indicator
S XMFM="YYYY" ;from line
I XMUS="XXXX"!(XMFM="YYYY") S %="FIX Routing codes !!!"_XMPCTS0("ERR")
;-------------------------------------------------------------
S XMABORT=0
D INIT(.XMDUZ,XMUS,.XMSTR,.XMRI,.XMTO,.XMABORT) Q:XMABORT
D CRE8XMZ^XMXSEND("Local PCTS Transmission.",.XMZ,1) I XMZ<1 S XMABORT=1 Q
D EDITON^XMJMS(XMDUZ,XMZ)
D PROCESS(XMDUZ,XMSTR,XMFM,XMRI,XMTO,.XMZ,.XMABORT)
D EDITOFF^XMJMS(XMDUZ)
Q:'XMABORT
W !!,"TWIX Send aborted !",$C(7)
H 2
D KILLMSG^XMXUTIL(XMZ)
Q
INIT(XMDUZ,XMUS,XMSTR,XMRI,XMTO,XMABORT) ;
N XMSEQ
I '$D(DUZ)#2 D Q
. W !!,"DUZ not defined..."
. S XMABORT=1
D EN^XM
W !!,"Create PCTS/AMS message.",!
;Making this the pseudo-sequence number - meaningless.
S XMSEQ=$P(^XMB(3.9,0),U,3),XMSEQ=$$RJ^XLFSTR($E(XMSEQ,$L(XMSEQ)-3,99),4,"0")
;Build the Header
S XMSTR="PAAUIJAZ "_XMUS_XMSEQ_" "_$$JD^XMRPCTS0_"-UUUU--"
D RI(.XMRI,.XMABORT) Q:XMABORT
D TO(.XMTO,.XMABORT)
Q
RI(XMRI,XMABORT) ;
N DIR,DIRUT,Y,X,DTOUT,DUOUT
S DIR(0)="FO^3:30^K X'?1UP.UP X"
S DIR("A")="Destination RI"
S DIR("?")="Enter the Destination Routing Indicator, like RUCHJBO."
D ^DIR I $D(DTOUT)!$D(DUOUT) S XMABORT=1 Q
I Y="" S Y="<RI>" W "<blank>"
S XMRI=Y
S:$E(XMRI,$L(XMRI))'="." XMRI=XMRI_"."
Q
TO(XMTO,XMABORT) ;
N DIR,DIRUT,Y,X,DTOUT,DUOUT
S DIR(0)="F^3:60"
S DIR("A")="Destination TO line"
S DIR("?")="Enter the content of the TO line of the message."
D ^DIR I $D(DTOUT)!$D(DUOUT) S XMABORT=1 Q
S XMTO=Y
Q
PROCESS(XMDUZ,XMSTR,XMFM,XMRI,XMTO,XMZ,XMABORT) ;
N I,%,XMTEXT,XMINSTR,XMRESTR
S %="ZNR UUUUU"
F I="RUCH","RUEV","RUWL","RUGS" I XMRI[I S %="VADM"
S I=0
S I=I+1,XMTEXT(I)=XMSTR_XMRI ;header line
S I=I+1,XMTEXT(I)=%
S I=I+1,XMTEXT(I)="FM "_XMFM ;from line
S I=I+1,XMTEXT(I)="TO "_XMTO ;to line
S I=I+1,XMTEXT(I)="BT"
S I=I+1,XMTEXT(I)=""
S I=I+1,XMTEXT(I)="<text>"
S I=I+1,XMTEXT(I)=""
S I=I+1,XMTEXT(I)="BT"
S I=I+1,XMTEXT(I)=""
S I=I+1,XMTEXT(I)="NNNN"
D MOVEBODY^XMXSEND(XMZ,"XMTEXT")
D E Q:XMABORT
D INIT^XMXADDR
D READY(XMDUZ,.XMINSTR,.XMRESTR,.XMABORT) Q:XMABORT
W !,"You may add recipients to this message."
D TOWHOM^XMJMT(XMDUZ,"Send",.XMINSTR,.XMRESTR,.XMABORT)
D:'XMABORT XMIT(XMDUZ,XMZ,.XMINSTR,.XMABORT)
D CLEANUP^XMXADDR
Q
XMIT(XMDUZ,XMZ,XMINSTR,XMABORT) ;
N DIR,Y,X,DIRUT,XMFINISH
S XMFINISH=0
F D Q:XMFINISH!XMABORT
. S DIR(0)="SAM^E:Edit Text;T:Transmit now"
. S DIR("A")="Select Message option: "
. S DIR("B")="Transmit now"
. S DIR("??")="^D Q^XMRPCTS1"
. D ^DIR I $D(DIRUT) S XMABORT=1 Q
. D @Y
Q
E ; Edit Text
F D BODY^XMJMS(XMDUZ,XMZ,.XMRESTR,.XMABORT) Q:XMABORT!$$NCHECK(XMZ)
Q
NCHECK(XMZ) ; If "NNNN" found in text, issue error
N NCNT,I
S (NCNT,I)=0
F S I=$O(^XMB(3.9,XMZ,2,I)) Q:'I I ^XMB(3.9,XMZ,2,I,0)["NNNN" S NCNT=NCNT+1
Q:NCNT'>1 1
W !!,"<< 4 CONSECUTIVE N's ARE NOT ALLOWED IN THE MSG TEXT !!! >>",!!,$C(7)
H 5
Q 0
T ; Transmit
S XMFINISH=1
D BLDNSND^XMXSEND(XMDUZ,XMZ,.XMINSTR)
Q
Q W !,"Answer: ",!
W !,"T (or just return) to PERMANENTLY transmit the message."
W !,"E to Edit the text of the message."
W !,"'^' to cancel the message."
Q
READY(XMDUZ,XMINSTR,XMRESTR,XMABORT) ;
N DIR,DIRUT,Y
S DIR(0)="Y"
S DIR("A")="Ready to send to the Austin AMS System"
S DIR("?",1)="'YES' will place the message in the queue for transmission through the AMS System."
S DIR("?")="'NO' will place the message only in your IN basket."
D ^DIR I $D(DIRUT) S XMABORT=1 Q
Q:'Y
W !,"Send to: XXX@VHA.DMIA"
D ADDR^XMXADDR(XMDUZ,"XXX@VHA.DMIA",.XMINSTR,.XMRESTR)
Q
EXIT ;
K I,XMTO,XMFM,XMSTR,XMUS,XMTM,XMRI,DIC,XCNP,XMXUSEC,ZTPAR,XMSEQ,XMOUT,DTOUT
K ^TMP("XMY",$J),^TMP("XMY0",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRPCTS1 4085 printed Sep 23, 2025@19:49:04 Page 2
XMRPCTS1 ;(KC-VAMC)/XXX-Simple PCTS front end to MailMan ;02/06/99 10:32
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 NEW XMUS,XMFM,XMSTR,XMRI,XMTO,XMABORT
+3 ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+4 ;All should be sent to XXX@VHA.DMIA the local PCTS Domain
+5 ;Edit these for your site.
+6 ;Local routing indicator
SET XMUS="XXXX"
+7 ;from line
SET XMFM="YYYY"
+8 IF XMUS="XXXX"!(XMFM="YYYY")
SET %="FIX Routing codes !!!"_XMPCTS0("ERR")
+9 ;-------------------------------------------------------------
+10 SET XMABORT=0
+11 DO INIT(.XMDUZ,XMUS,.XMSTR,.XMRI,.XMTO,.XMABORT)
if XMABORT
QUIT
+12 DO CRE8XMZ^XMXSEND("Local PCTS Transmission.",.XMZ,1)
IF XMZ<1
SET XMABORT=1
QUIT
+13 DO EDITON^XMJMS(XMDUZ,XMZ)
+14 DO PROCESS(XMDUZ,XMSTR,XMFM,XMRI,XMTO,.XMZ,.XMABORT)
+15 DO EDITOFF^XMJMS(XMDUZ)
+16 if 'XMABORT
QUIT
+17 WRITE !!,"TWIX Send aborted !",$CHAR(7)
+18 HANG 2
+19 DO KILLMSG^XMXUTIL(XMZ)
+20 QUIT
INIT(XMDUZ,XMUS,XMSTR,XMRI,XMTO,XMABORT) ;
+1 NEW XMSEQ
+2 IF '$DATA(DUZ)#2
Begin DoDot:1
+3 WRITE !!,"DUZ not defined..."
+4 SET XMABORT=1
End DoDot:1
QUIT
+5 DO EN^XM
+6 WRITE !!,"Create PCTS/AMS message.",!
+7 ;Making this the pseudo-sequence number - meaningless.
+8 SET XMSEQ=$PIECE(^XMB(3.9,0),U,3)
SET XMSEQ=$$RJ^XLFSTR($EXTRACT(XMSEQ,$LENGTH(XMSEQ)-3,99),4,"0")
+9 ;Build the Header
+10 SET XMSTR="PAAUIJAZ "_XMUS_XMSEQ_" "_$$JD^XMRPCTS0_"-UUUU--"
+11 DO RI(.XMRI,.XMABORT)
if XMABORT
QUIT
+12 DO TO(.XMTO,.XMABORT)
+13 QUIT
RI(XMRI,XMABORT) ;
+1 NEW DIR,DIRUT,Y,X,DTOUT,DUOUT
+2 SET DIR(0)="FO^3:30^K X'?1UP.UP X"
+3 SET DIR("A")="Destination RI"
+4 SET DIR("?")="Enter the Destination Routing Indicator, like RUCHJBO."
+5 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET XMABORT=1
QUIT
+6 IF Y=""
SET Y="<RI>"
WRITE "<blank>"
+7 SET XMRI=Y
+8 if $EXTRACT(XMRI,$LENGTH(XMRI))'="."
SET XMRI=XMRI_"."
+9 QUIT
TO(XMTO,XMABORT) ;
+1 NEW DIR,DIRUT,Y,X,DTOUT,DUOUT
+2 SET DIR(0)="F^3:60"
+3 SET DIR("A")="Destination TO line"
+4 SET DIR("?")="Enter the content of the TO line of the message."
+5 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET XMABORT=1
QUIT
+6 SET XMTO=Y
+7 QUIT
PROCESS(XMDUZ,XMSTR,XMFM,XMRI,XMTO,XMZ,XMABORT) ;
+1 NEW I,%,XMTEXT,XMINSTR,XMRESTR
+2 SET %="ZNR UUUUU"
+3 FOR I="RUCH","RUEV","RUWL","RUGS"
IF XMRI[I
SET %="VADM"
+4 SET I=0
+5 ;header line
SET I=I+1
SET XMTEXT(I)=XMSTR_XMRI
+6 SET I=I+1
SET XMTEXT(I)=%
+7 ;from line
SET I=I+1
SET XMTEXT(I)="FM "_XMFM
+8 ;to line
SET I=I+1
SET XMTEXT(I)="TO "_XMTO
+9 SET I=I+1
SET XMTEXT(I)="BT"
+10 SET I=I+1
SET XMTEXT(I)=""
+11 SET I=I+1
SET XMTEXT(I)="<text>"
+12 SET I=I+1
SET XMTEXT(I)=""
+13 SET I=I+1
SET XMTEXT(I)="BT"
+14 SET I=I+1
SET XMTEXT(I)=""
+15 SET I=I+1
SET XMTEXT(I)="NNNN"
+16 DO MOVEBODY^XMXSEND(XMZ,"XMTEXT")
+17 DO E
if XMABORT
QUIT
+18 DO INIT^XMXADDR
+19 DO READY(XMDUZ,.XMINSTR,.XMRESTR,.XMABORT)
if XMABORT
QUIT
+20 WRITE !,"You may add recipients to this message."
+21 DO TOWHOM^XMJMT(XMDUZ,"Send",.XMINSTR,.XMRESTR,.XMABORT)
+22 if 'XMABORT
DO XMIT(XMDUZ,XMZ,.XMINSTR,.XMABORT)
+23 DO CLEANUP^XMXADDR
+24 QUIT
XMIT(XMDUZ,XMZ,XMINSTR,XMABORT) ;
+1 NEW DIR,Y,X,DIRUT,XMFINISH
+2 SET XMFINISH=0
+3 FOR
Begin DoDot:1
+4 SET DIR(0)="SAM^E:Edit Text;T:Transmit now"
+5 SET DIR("A")="Select Message option: "
+6 SET DIR("B")="Transmit now"
+7 SET DIR("??")="^D Q^XMRPCTS1"
+8 DO ^DIR
IF $DATA(DIRUT)
SET XMABORT=1
QUIT
+9 DO @Y
End DoDot:1
if XMFINISH!XMABORT
QUIT
+10 QUIT
E ; Edit Text
+1 FOR
DO BODY^XMJMS(XMDUZ,XMZ,.XMRESTR,.XMABORT)
if XMABORT!$$NCHECK(XMZ)
QUIT
+2 QUIT
NCHECK(XMZ) ; If "NNNN" found in text, issue error
+1 NEW NCNT,I
+2 SET (NCNT,I)=0
+3 FOR
SET I=$ORDER(^XMB(3.9,XMZ,2,I))
if 'I
QUIT
IF ^XMB(3.9,XMZ,2,I,0)["NNNN"
SET NCNT=NCNT+1
+4 if NCNT'>1
QUIT 1
+5 WRITE !!,"<< 4 CONSECUTIVE N's ARE NOT ALLOWED IN THE MSG TEXT !!! >>",!!,$CHAR(7)
+6 HANG 5
+7 QUIT 0
T ; Transmit
+1 SET XMFINISH=1
+2 DO BLDNSND^XMXSEND(XMDUZ,XMZ,.XMINSTR)
+3 QUIT
Q WRITE !,"Answer: ",!
+1 WRITE !,"T (or just return) to PERMANENTLY transmit the message."
+2 WRITE !,"E to Edit the text of the message."
+3 WRITE !,"'^' to cancel the message."
+4 QUIT
READY(XMDUZ,XMINSTR,XMRESTR,XMABORT) ;
+1 NEW DIR,DIRUT,Y
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Ready to send to the Austin AMS System"
+4 SET DIR("?",1)="'YES' will place the message in the queue for transmission through the AMS System."
+5 SET DIR("?")="'NO' will place the message only in your IN basket."
+6 DO ^DIR
IF $DATA(DIRUT)
SET XMABORT=1
QUIT
+7 if 'Y
QUIT
+8 WRITE !,"Send to: XXX@VHA.DMIA"
+9 DO ADDR^XMXADDR(XMDUZ,"XXX@VHA.DMIA",.XMINSTR,.XMRESTR)
+10 QUIT
EXIT ;
+1 KILL I,XMTO,XMFM,XMSTR,XMUS,XMTM,XMRI,DIC,XCNP,XMXUSEC,ZTPAR,XMSEQ,XMOUT,DTOUT
+2 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB)
+3 QUIT
