- 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 Dec 13, 2024@02:13: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