PXRMEXMM ; SLC/PKR - Routines to select and deal with MailMan messages ;01/22/2013
;;2.0;CLINICAL REMINDERS;**12,26**;Feb 04, 2005;Build 404
;=============================================================
CMM(SUCCESS,LIST) ;Create a MailMan message containing the repository
;entries in LIST.
;Get a new MailMan message number.
N IC,IND,LC,LEN,LNUM,RIEN,TEMP,TLC,XMSUB
S TEMP=$$GETSUB
I (TEMP["^")!(TEMP="") Q
S XMSUB="CREX: "_TEMP
S TEMP=$$SUBCHK^XMGAPI0(XMSUB,0)
I $P(TEMP,U,1)'="" S XMSUB=$E(XMSUB,1,65)
RETRY ;
D XMZ^XMA2
I XMZ<1 G RETRY
S SUCCESS("XMZ")=XMZ
S SUCCESS("SUB")=XMSUB
;
S (IC,TLC)=0
S LEN=$L(LIST,",")-1
F IND=1:1:LEN D
. S LNUM=$P(LIST,",",IND)
. S RIEN=$$RIEN^PXRMEXU1(LNUM)
. S LC=$O(^PXD(811.8,RIEN,100,""),-1)
. S TLC=TLC+LC
. F IND=1:1:LC D
.. S IC=IC+1
.. S ^XMB(3.9,XMZ,2,IC,0)=^PXD(811.8,RIEN,100,IND,0)
S ^XMB(3.9,XMZ,2,0)="^3.92^"_TLC_"^"_TLC_"^"_DT
;
;Make the message information only.
S $P(^XMB(3.9,XMZ,0),U,12)="Y"
;
;Get a list of who to send it to and send it.
D ENT2^XMD
Q
;
;=============================================================
GETMESSN() ;Get the message number.
N BSKT,DIC,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ZN
S DIC("A")="Select a MailMan message: "
S DIC=3.9
S DIC(0)="EQV"
;Look for messages that start with "C" for either CREX or Copy of.
S X="CREX:"
;DBIA #2736 for XMXUTIL2
S DIC("S")="S BSKT=$$BSKT^XMXUTIL2(DUZ,+Y) I BSKT>0,BSKT'=.5"
S DIC("W")="S ZN=$$ZNODE^XMXUTIL2(+Y) W !,"" "",$$FROM^XMXUTIL2(ZN),"" "",$$DATE^XMXUTIL2(ZN),!"
W !
D ^DIC K DIC
I X=(U_U) S DTOUT=1
I $D(DIROUT)!$D(DIRUT) Q ""
I $D(DTOUT)!$D(DUOUT) Q ""
I +Y'=-1 Q $P(Y,U,1)
;
S DIC("A")="Select a MailMan message: "
S DIC=3.9
S DIC(0)="EQV"
S X="Copy of: CREX:"
;DBIA #2736 for XMXUTIL2
S DIC("S")="S BSKT=$$BSKT^XMXUTIL2(DUZ,+Y) I BSKT>0,BSKT'=.5"
S DIC("W")="S ZN=$$ZNODE^XMXUTIL2(+Y) W !,"" "",$$FROM^XMXUTIL2(ZN),"" "",$$DATE^XMXUTIL2(ZN),!"
W !
D ^DIC K DIC
I X=(U_U) S DTOUT=1
I $D(DIROUT)!$D(DIRUT) Q ""
I $D(DTOUT)!$D(DUOUT) Q ""
Q $P(Y,U,1)
;
;=============================================================
GETSUB() ;Prompt the user for a subject.
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="FAU"_U_"1:59"
S DIR("A")="Enter a subject: "
D ^DIR
I $D(DIROUT)!$D(DIRUT) Q ""
I $D(DTOUT)!$D(DUOUT) Q ""
Q Y
;
;=============================================================
LMM(SUCCESS,XMZ) ;Load repository entries from a MailMan message.
N CSUM,DATEP,EXTYPE,FDA,FDAIEN,IENROOT,IND,LINE,MSG,NENTRY,NLINES,RETMP
N RNAME,SITE,SOURCE,SSOURCE,TEMP,US,USER,VRSN,XMER,XMPOS,XMRG,XMVAR
;Get the message information
;DBIA #1144
S TEMP=$$HDR^XMGAPI2(XMZ,.XMVAR,0)
I TEMP'=0 D Q
. W !,"This MailMan message has a corrupted header."
. S SUCCESS=0
. H 2
;Load the message
W !,"Loading MailMan message number ",XMZ
K ^TMP("PXRMEXLMM",$J)
S RETMP="^TMP(""PXRMEXLMM"",$J)"
S (NENTRY,NLINES,SSOURCE)=0
S XMPOS=$$STARTPOS(XMZ)
F D REC^XMS3 Q:+$G(XMER)=-1 D
. S NLINES=NLINES+1
. S ^TMP("PXRMEXLMM",$J,NLINES,0)=XMRG
. I XMRG["<PACKAGE_VERSION>" S VRSN=$$GETTAGV^PXRMEXU3(XMRG,"<PACKAGE_VERSION>")
. I XMRG["<EXCHANGE_TYPE>" S EXTYPE=$$GETTAGV^PXRMEXU3(XMRG,"<EXCHANGE_TYPE>",1)
. I XMRG="<SOURCE>" S SSOURCE=1
. I SSOURCE D
.. I XMRG["<NAME>" S RNAME=$$GETTAGV^PXRMEXU3(XMRG,"<NAME>",1)
.. I XMRG["<USER>" S USER=$$GETTAGV^PXRMEXU3(XMRG,"<USER>",1)
.. I XMRG["<SITE>" S SITE=$$GETTAGV^PXRMEXU3(XMRG,"<SITE>",1)
.. I XMRG["<DATE_PACKED>" S DATEP=$$GETTAGV^PXRMEXU3(XMRG,"<DATE_PACKED>")
. I XMRG="</SOURCE>" D
.. S SSOURCE=0
.. S SOURCE=USER_" at "_SITE
.;See if the entry is loaded into the temporary storage.
. I XMRG="</REMINDER_EXCHANGE_FILE_ENTRY>" D
.. S NLINES=0
.. S NENTRY=NENTRY+1
..;Make sure it has the correct format.
.. I (^TMP("PXRMEXLMM",$J,1,0)'["xml")!(^TMP("PXRMEXLMM",$J,2,0)'="<REMINDER_EXCHANGE_FILE_ENTRY>") D Q
... W !,"There is a problem reading this MailMan message for entry ",NENTRY,", try it again."
... W !,"If it fails twice it is not in the proper reminder exchange format."
... S SUCCESS=0
... H 2
... S XMER=-1
..;Make sure this entry does not already exist.
.. I $$REXISTS^PXRMEXIU(RNAME,DATEP) D
... W !,RNAME," with a date packed of ",DATEP
... W !,"is already in the Exchange File, it will not be added again."
... S SUCCESS(NENTRY)=0
... H 2
.. E D
... K FDA,IENROOT
... S FDA(811.8,"+1,",.01)=RNAME
... S FDA(811.8,"+1,",.02)=SOURCE
... S FDA(811.8,"+1,",.03)=DATEP
... D UPDATE^PXRMEXPU(.US,.FDA,.IENROOT)
... S SUCCESS(NENTRY)=US
...;Create the description and save the data.
... N DESL,DESCT,KEYWORDT
... D DESC^PXRMEXU3(RETMP,.DESCT)
... D KEYWORD^PXRMEXU3(RETMP,.KEYWORDT)
... S DESL("RNAME")=RNAME,DESL("SOURCE")=SOURCE,DESL("DATEP")=DATEP
... S DESL("VRSN")=VRSN
... D DESC^PXRMEXU1(IENROOT(1),.DESL,"DESCT","KEYWORDT")
... M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXLMM",$J)
... W !,"Added Exchange entry ",RNAME H 2
.. K ^TMP("PXRMEXLMM",$J)
;Check the success of the entry installs.
S SUCCESS=1
S IND=""
F S IND=$O(SUCCESS(IND)) Q:+IND=0 D
. I 'SUCCESS(IND) S SUCCESS=0 Q
Q
;
;=============================================================
STARTPOS(XMZ) ;Find the starting position by looking for the xml header.
;This will skip over extra header information created by things like
;copying or using p-message.
N XMPOS,XMER,XMRG
S XMPOS=.99
F D REC^XMS3 Q:(XMRG="<?xml version=""1.0"" standalone=""yes""?>")!(+$G(XMER)=-1)
S XMPOS=$S($G(XMER)=-1:-1,1:XMPOS-1)
Q XMPOS
;
PXRMEXMM ; SLC/PKR - Routines to select and deal with MailMan messages ;01/22/2013
+1 ;;2.0;CLINICAL REMINDERS;**12,26**;Feb 04, 2005;Build 404
+2 ;=============================================================
CMM(SUCCESS,LIST) ;Create a MailMan message containing the repository
+1 ;entries in LIST.
+2 ;Get a new MailMan message number.
+3 NEW IC,IND,LC,LEN,LNUM,RIEN,TEMP,TLC,XMSUB
+4 SET TEMP=$$GETSUB
+5 IF (TEMP["^")!(TEMP="")
QUIT
+6 SET XMSUB="CREX: "_TEMP
+7 SET TEMP=$$SUBCHK^XMGAPI0(XMSUB,0)
+8 IF $PIECE(TEMP,U,1)'=""
SET XMSUB=$EXTRACT(XMSUB,1,65)
RETRY ;
+1 DO XMZ^XMA2
+2 IF XMZ<1
GOTO RETRY
+3 SET SUCCESS("XMZ")=XMZ
+4 SET SUCCESS("SUB")=XMSUB
+5 ;
+6 SET (IC,TLC)=0
+7 SET LEN=$LENGTH(LIST,",")-1
+8 FOR IND=1:1:LEN
Begin DoDot:1
+9 SET LNUM=$PIECE(LIST,",",IND)
+10 SET RIEN=$$RIEN^PXRMEXU1(LNUM)
+11 SET LC=$ORDER(^PXD(811.8,RIEN,100,""),-1)
+12 SET TLC=TLC+LC
+13 FOR IND=1:1:LC
Begin DoDot:2
+14 SET IC=IC+1
+15 SET ^XMB(3.9,XMZ,2,IC,0)=^PXD(811.8,RIEN,100,IND,0)
End DoDot:2
End DoDot:1
+16 SET ^XMB(3.9,XMZ,2,0)="^3.92^"_TLC_"^"_TLC_"^"_DT
+17 ;
+18 ;Make the message information only.
+19 SET $PIECE(^XMB(3.9,XMZ,0),U,12)="Y"
+20 ;
+21 ;Get a list of who to send it to and send it.
+22 DO ENT2^XMD
+23 QUIT
+24 ;
+25 ;=============================================================
GETMESSN() ;Get the message number.
+1 NEW BSKT,DIC,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ZN
+2 SET DIC("A")="Select a MailMan message: "
+3 SET DIC=3.9
+4 SET DIC(0)="EQV"
+5 ;Look for messages that start with "C" for either CREX or Copy of.
+6 SET X="CREX:"
+7 ;DBIA #2736 for XMXUTIL2
+8 SET DIC("S")="S BSKT=$$BSKT^XMXUTIL2(DUZ,+Y) I BSKT>0,BSKT'=.5"
+9 SET DIC("W")="S ZN=$$ZNODE^XMXUTIL2(+Y) W !,"" "",$$FROM^XMXUTIL2(ZN),"" "",$$DATE^XMXUTIL2(ZN),!"
+10 WRITE !
+11 DO ^DIC
KILL DIC
+12 IF X=(U_U)
SET DTOUT=1
+13 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT ""
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+15 IF +Y'=-1
QUIT $PIECE(Y,U,1)
+16 ;
+17 SET DIC("A")="Select a MailMan message: "
+18 SET DIC=3.9
+19 SET DIC(0)="EQV"
+20 SET X="Copy of: CREX:"
+21 ;DBIA #2736 for XMXUTIL2
+22 SET DIC("S")="S BSKT=$$BSKT^XMXUTIL2(DUZ,+Y) I BSKT>0,BSKT'=.5"
+23 SET DIC("W")="S ZN=$$ZNODE^XMXUTIL2(+Y) W !,"" "",$$FROM^XMXUTIL2(ZN),"" "",$$DATE^XMXUTIL2(ZN),!"
+24 WRITE !
+25 DO ^DIC
KILL DIC
+26 IF X=(U_U)
SET DTOUT=1
+27 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT ""
+28 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+29 QUIT $PIECE(Y,U,1)
+30 ;
+31 ;=============================================================
GETSUB() ;Prompt the user for a subject.
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="FAU"_U_"1:59"
+3 SET DIR("A")="Enter a subject: "
+4 DO ^DIR
+5 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT ""
+6 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+7 QUIT Y
+8 ;
+9 ;=============================================================
LMM(SUCCESS,XMZ) ;Load repository entries from a MailMan message.
+1 NEW CSUM,DATEP,EXTYPE,FDA,FDAIEN,IENROOT,IND,LINE,MSG,NENTRY,NLINES,RETMP
+2 NEW RNAME,SITE,SOURCE,SSOURCE,TEMP,US,USER,VRSN,XMER,XMPOS,XMRG,XMVAR
+3 ;Get the message information
+4 ;DBIA #1144
+5 SET TEMP=$$HDR^XMGAPI2(XMZ,.XMVAR,0)
+6 IF TEMP'=0
Begin DoDot:1
+7 WRITE !,"This MailMan message has a corrupted header."
+8 SET SUCCESS=0
+9 HANG 2
End DoDot:1
QUIT
+10 ;Load the message
+11 WRITE !,"Loading MailMan message number ",XMZ
+12 KILL ^TMP("PXRMEXLMM",$JOB)
+13 SET RETMP="^TMP(""PXRMEXLMM"",$J)"
+14 SET (NENTRY,NLINES,SSOURCE)=0
+15 SET XMPOS=$$STARTPOS(XMZ)
+16 FOR
DO REC^XMS3
IF +$GET(XMER)=-1
QUIT
Begin DoDot:1
+17 SET NLINES=NLINES+1
+18 SET ^TMP("PXRMEXLMM",$JOB,NLINES,0)=XMRG
+19 IF XMRG["<PACKAGE_VERSION>"
SET VRSN=$$GETTAGV^PXRMEXU3(XMRG,"<PACKAGE_VERSION>")
+20 IF XMRG["<EXCHANGE_TYPE>"
SET EXTYPE=$$GETTAGV^PXRMEXU3(XMRG,"<EXCHANGE_TYPE>",1)
+21 IF XMRG="<SOURCE>"
SET SSOURCE=1
+22 IF SSOURCE
Begin DoDot:2
+23 IF XMRG["<NAME>"
SET RNAME=$$GETTAGV^PXRMEXU3(XMRG,"<NAME>",1)
+24 IF XMRG["<USER>"
SET USER=$$GETTAGV^PXRMEXU3(XMRG,"<USER>",1)
+25 IF XMRG["<SITE>"
SET SITE=$$GETTAGV^PXRMEXU3(XMRG,"<SITE>",1)
+26 IF XMRG["<DATE_PACKED>"
SET DATEP=$$GETTAGV^PXRMEXU3(XMRG,"<DATE_PACKED>")
End DoDot:2
+27 IF XMRG="</SOURCE>"
Begin DoDot:2
+28 SET SSOURCE=0
+29 SET SOURCE=USER_" at "_SITE
End DoDot:2
+30 ;See if the entry is loaded into the temporary storage.
+31 IF XMRG="</REMINDER_EXCHANGE_FILE_ENTRY>"
Begin DoDot:2
+32 SET NLINES=0
+33 SET NENTRY=NENTRY+1
+34 ;Make sure it has the correct format.
+35 IF (^TMP("PXRMEXLMM",$JOB,1,0)'["xml")!(^TMP("PXRMEXLMM",$JOB,2,0)'="<REMINDER_EXCHANGE_FILE_ENTRY>")
Begin DoDot:3
+36 WRITE !,"There is a problem reading this MailMan message for entry ",NENTRY,", try it again."
+37 WRITE !,"If it fails twice it is not in the proper reminder exchange format."
+38 SET SUCCESS=0
+39 HANG 2
+40 SET XMER=-1
End DoDot:3
QUIT
+41 ;Make sure this entry does not already exist.
+42 IF $$REXISTS^PXRMEXIU(RNAME,DATEP)
Begin DoDot:3
+43 WRITE !,RNAME," with a date packed of ",DATEP
+44 WRITE !,"is already in the Exchange File, it will not be added again."
+45 SET SUCCESS(NENTRY)=0
+46 HANG 2
End DoDot:3
+47 IF '$TEST
Begin DoDot:3
+48 KILL FDA,IENROOT
+49 SET FDA(811.8,"+1,",.01)=RNAME
+50 SET FDA(811.8,"+1,",.02)=SOURCE
+51 SET FDA(811.8,"+1,",.03)=DATEP
+52 DO UPDATE^PXRMEXPU(.US,.FDA,.IENROOT)
+53 SET SUCCESS(NENTRY)=US
+54 ;Create the description and save the data.
+55 NEW DESL,DESCT,KEYWORDT
+56 DO DESC^PXRMEXU3(RETMP,.DESCT)
+57 DO KEYWORD^PXRMEXU3(RETMP,.KEYWORDT)
+58 SET DESL("RNAME")=RNAME
SET DESL("SOURCE")=SOURCE
SET DESL("DATEP")=DATEP
+59 SET DESL("VRSN")=VRSN
+60 DO DESC^PXRMEXU1(IENROOT(1),.DESL,"DESCT","KEYWORDT")
+61 MERGE ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXLMM",$JOB)
+62 WRITE !,"Added Exchange entry ",RNAME
HANG 2
End DoDot:3
+63 KILL ^TMP("PXRMEXLMM",$JOB)
End DoDot:2
End DoDot:1
+64 ;Check the success of the entry installs.
+65 SET SUCCESS=1
+66 SET IND=""
+67 FOR
SET IND=$ORDER(SUCCESS(IND))
IF +IND=0
QUIT
Begin DoDot:1
+68 IF 'SUCCESS(IND)
SET SUCCESS=0
QUIT
End DoDot:1
+69 QUIT
+70 ;
+71 ;=============================================================
STARTPOS(XMZ) ;Find the starting position by looking for the xml header.
+1 ;This will skip over extra header information created by things like
+2 ;copying or using p-message.
+3 NEW XMPOS,XMER,XMRG
+4 SET XMPOS=.99
+5 FOR
DO REC^XMS3
IF (XMRG="<?xml version=""1.0"" standalone=""yes""?>")!(+$GET(XMER)=-1)
QUIT
+6 SET XMPOS=$SELECT($GET(XMER)=-1:-1,1:XMPOS-1)
+7 QUIT XMPOS
+8 ;
