XMJMQ1 ;ISC-SF/GMB-Q,QD,QN Query recipients (cont.) ;04/17/2002 10:11
;;8.0;MailMan;;Jun 28, 2002
; Replaces ^XMA5,^XMA5A (ISC-WASH/THM/CAP)
QINIT(XMDUZ,XMK,XMKN,XMZ,XMRESPM,XMABORT) ;
N XMZSTR,XMSUBJ,XMRESPS
S XMABORT=0
S XMZSTR=$$EZBLD^DIALOG(34537,XMZ) ; [#_XMZ_]
S XMSUBJ=$P(^XMB(3.9,XMZ,0),U)
S:XMSUBJ["~U~" XMSUBJ=$$DECODEUP^XMXUTIL1(XMSUBJ)
S XMSUBJ=$$EZBLD^DIALOG(34536,XMSUBJ) ; Subj: _XMSUBJ
S XMRESPS=+$P($G(^XMB(3.9,XMZ,3,0)),U,4)
S XMRESPM=$$EZBLD^DIALOG($S(XMRESPS=1:34557.1,1:34557),XMRESPS) ; XMRESPS_ response / responses
W @IOF
D PAGE1HDR^XMJMP1(XMDUZ,XMK,XMKN,XMZ,XMRESPS,^XMB(3.9,XMZ,0),XMSUBJ,XMZSTR)
D INFO(XMDUZ,XMK,XMZ,0,"","","",.XMABORT)
Q
INFO(XMDUZ,XMK,XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ;
N XMREC,XMRECIPS,XMDIALOG
S XMREC=^XMB(3.9,XMZ,0)
I $Y+4>IOSL D Q:XMABORT
. D PAGE^XMJMQ(.XMABORT)
E W !
W !,$$EZBLD^DIALOG(34559,XMZ_"@"_^XMB("NETNAME")) ; Local Message-ID:
S XMDIALOG=$S($P(XMREC,U,7)["P":34543,$P(XMREC,U,7)["S":34560,$P(XMREC,U,8):34561,1:0) I XMDIALOG D W(XMDIALOG) ; Priority! / [SPOOL] / <RESPONSE>
S XMRECIPS=+$P($G(^XMB(3.9,XMZ,1,0)),U,4)
I XMRECIPS D W($S(XMRECIPS=1:34562.1,1:34562),XMRECIPS) ; (_XMRECIPS_ Recipient(s))
I "^Y^y^"[(U_$P(XMREC,U,5)_U) D W(34564) ; Confirmation requested.
I $D(^XMB(3.9,XMZ,"K")) D W($S(" "[$P(XMREC,U,10):34565,1:34566),$P(XMREC,U,10)) ; Scramble Hint:
I $O(^XMB(3.9,XMZ,2005,0)) D LIST^XMA2B ; MIME body parts
I "^Y^y^"[(U_$P(XMREC,U,9)_U) D W(34567) ; Closed.
I "^Y^y^"[(U_$P(XMREC,U,11)_U) D W(34568) ; Confidential.
I "^Y^y^"[(U_$P(XMREC,U,12)_U) D W(34570) ; 'Information only' for all recipients.
I $D(^XMB(3.9,XMZ,.5)) D
. S XMREC=^XMB(3.9,XMZ,.5)
. I $P(XMREC,U,1)'="" D W(34571,$P(XMREC,U,1)) ; Delivery basket:
; The following is already listed in the message header:
;I $D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)) D
;. N XMVAPOR
;. S XMVAPOR=$P($G(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,5)
;. I XMVAPOR D W(34572,$$MMDT^XMXUTIL1(XMVAPOR)) ; Automatic Deletion Date:
D LATER(XMDUZ,XMZ,XMPHDR,XMSUBJ,XMZSTR,.XMPAGE,.XMABORT)
Q
LATER(XMDUZ,XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ; List dates message will be new on 'later'
Q:'$O(^XMB(3.73,"AC",XMZ,XMDUZ,0))
N XMIEN,XMSEP
I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
W !,$$EZBLD^DIALOG(34595) ; Message will be NEW on:
S XMIEN="",XMSEP=" "
F S XMIEN=$O(^XMB(3.73,"AC",XMZ,XMDUZ,XMIEN)) Q:XMIEN="" D
. D W2(XMSEP,$$FMTE^XLFDT($E($P(^XMB(3.73,XMIEN,0),U),1,12)),.XMABORT)
. S XMSEP=", "
Q
W(XMPIECE,XMPARM) ;
S XMPIECE=$$EZBLD^DIALOG(XMPIECE,.XMPARM)
I 1+$L(XMPIECE)+$X>IOM D Q:XMABORT
. I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
. W !
W " ",XMPIECE
Q
W2(XMSEP,XMPIECE,XMABORT) ;
I $X+$L(XMSEP)+$L(XMPIECE)>IOM D Q:XMABORT
. I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
. W !,XMPIECE
E W XMSEP,XMPIECE
Q
NETWORK(XMZ,XMABORT) ;
N I,J,XMLINE,XMPOS,XMPHDR
I $O(^XMB(3.9,XMZ,2,0))'<1 D Q
. W !!,$$EZBLD^DIALOG(34550) ; This message originated locally. There is no network header.
I $D(^XMB(3.9,XMZ,.7)) W !!,$$EZBLD^DIALOG(34551,$P(^XMB(3.9,XMZ,.7),U,1)) ; Envelope From:
W !!,$$EZBLD^DIALOG(34552),! ; Network header:
S (I,XMPHDR)=0
F S I=$O(^XMB(3.9,XMZ,2,I)) Q:I=""!(I'<1) D Q:XMABORT
. S XMLINE=^XMB(3.9,XMZ,2,I,0)
. I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
. I $L(XMLINE)<IOM W !,XMLINE Q
. S XMPOS=0
. F D Q:XMLINE=""!XMABORT
. . I $L(XMLINE)+XMPOS+1>IOM F J=IOM-XMPOS-1:-1:IOM-XMPOS-20 Q:", -;)"[$E(XMLINE,J)
. . I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
. . W !,?XMPOS,$E(XMLINE,1,J)
. . S XMPOS=10
. . S XMLINE=$E(XMLINE,J+1,999)
Q
SUMMARY(XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ;
N XMTYPE
I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
W !
I '$O(^XMB(3.9,XMZ,6,0)),'$O(^XMB(3.9,XMZ,7,0)) D Q
. N XMTEXT
. D BLD^DIALOG(34596,"","","XMTEXT","F")
. D MSG^DIALOG("WM","","","","XMTEXT")
. ;This is an old message which has no summary recipient list.
. ;Only the Detail Query (QD) is available.
W !,$$EZBLD^DIALOG(34597),! ; This message was addressed as follows:
D PRTADDR(XMZ,6,.XMTYPE,.XMABORT) Q:XMABORT ; addressed to
D PRTADDR(XMZ,7,.XMTYPE,.XMABORT) ; deliver later to
Q
PRTADDR(XMZ,XMNODE,XMTYPE,XMABORT) ;
N XMTO
S XMTO="*" ; List Broadcasts first
F S XMTO=$O(^XMB(3.9,XMZ,XMNODE,"B",XMTO)) Q:$E(XMTO,1,1)'="*" D PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT) Q:XMABORT
Q:XMABORT
S XMTO="G." ; List Groups next
F S XMTO=$O(^XMB(3.9,XMZ,XMNODE,"B",XMTO)) Q:$E(XMTO,1,2)'="G." D PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT) Q:XMABORT
Q:XMABORT
S XMTO="" ; Now list the rest
F S XMTO=$O(^XMB(3.9,XMZ,XMNODE,"B",XMTO)) Q:XMTO="" D Q:XMABORT
. Q:$E(XMTO,1,2)="G."
. Q:$E(XMTO,1,1)="*"
. D PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT)
Q
PRTSUMRY(XMZ,XMNODE,XMTO,XMTYPE,XMABORT) ;
N XMIEN,XMREC
S XMIEN=$O(^XMB(3.9,XMZ,XMNODE,"B",XMTO,0)) Q:'XMIEN
S XMREC=$G(^XMB(3.9,XMZ,XMNODE,XMIEN,0)) Q:XMREC=""
I $Y+3>IOSL D PAGE^XMJMQ(.XMABORT) Q:XMABORT
I $P(XMREC,U,2)'="" D
. S XMTYPE=$P(XMREC,U,2)
. I '$D(XMTYPE(XMTYPE)) S XMTYPE(XMTYPE)=$$EXTERNAL^DILFD(3.91,6.5,"",XMTYPE) I $D(DIERR) S XMTYPE(XMTYPE)=XMTYPE
. W !,XMTYPE(XMTYPE),":",$P(XMREC,U,1)
E W !,$P(XMREC,U,1)
Q:XMNODE=6
N XMPARM
S XMPARM(1)=$$MMDT^XMXUTIL1($P(XMREC,U,5)),XMPARM(2)=$P(XMREC,U,4)
D W(34598,.XMPARM) ; for delivery x by y
Q
SEARCH(XMZ,XMNAME,XMRESPM) ;
N XMPHDR,XMUSER,XMSITE
S XMPHDR=0
I $Y+5>IOSL D Q:XMABORT
. D PAGE^XMJMQ(.XMABORT)
E W !
W !,$$EZBLD^DIALOG(34554,XMNAME),! ; Searching for recipients that match '_XMNAME_'.
I XMNAME["@" D
. S XMSITE=$$UP^XLFSTR($P(XMNAME,"@",2,99))
. ;S XMUSER=$P(XMNAME,"@",1)_$S(XMNAME[",":"@",1:",")
. S XMUSER=$P($P(XMNAME,"@",1),",",1)_","
. S XMNAME=XMUSER_XMSITE
E D Q:XMABORT
. D FIND^DIC(200,"","@;.01","AP",XMNAME,"","B^BB^C^D","I $D(^XMB(3.9,XMZ,1,""C"",+Y))")
. I '$D(DIERR) D PSEARCH(200,XMZ,XMRESPM,.XMABORT) Q:XMABORT
Q:$O(^XMB(3.9,XMZ,1,"C",":"))="" ; Quit if there aren't any non-local addressees
N XMSCREEN
S XMSCREEN=$S(+XMNAME=XMNAME:"I '$D(^XMB(3.9,XMZ,1,""C"",XMNAME))",1:"")
D FIND^DIC(3.91,","_XMZ_",","","CP",XMNAME,"","C",XMSCREEN)
I '$D(DIERR) D PSEARCH(3.91,XMZ,XMRESPM,.XMABORT)
Q:$E(XMNAME)'?1U ; Quit if the search string does not begin with an upper case letter
Q:$O(^XMB(3.9,XMZ,1,"C","`"))="" ; Quit if there aren't any lower case addressees
; FM will translate lower case to upper case in its search, but won't
; translate upper to lower, so we do it here.
S XMSCREEN="I ^(0)]""`""" ; Limit search to lower case addresses
S XMNAME=$S($D(XMSITE):$$LOW^XLFSTR(XMUSER)_XMSITE,1:$$LOW^XLFSTR(XMNAME))
D FIND^DIC(3.91,","_XMZ_",","","CP",XMNAME,"","C",XMSCREEN)
I '$D(DIERR) D PSEARCH(3.91,XMZ,XMRESPM,.XMABORT)
Q
PSEARCH(XMFILE,XMZ,XMRESPM,XMABORT) ; Print search results
N XMI,XMIEN,XMTYPE,XMREC
S XMI=0
F S XMI=$O(^TMP("DILIST",$J,XMI)) Q:'XMI S XMREC=^(XMI,0) D Q:XMABORT
. S XMIEN=$S(XMFILE=200:$O(^XMB(3.9,XMZ,1,"C",$P(XMREC,U,1),0)),1:$P(XMREC,U,1))
. D WNAME^XMJMQ(XMZ,$P(XMREC,U,2),XMIEN,XMRESPM,.XMTYPE,.XMABORT)
Q
XMJMQ1 ;ISC-SF/GMB-Q,QD,QN Query recipients (cont.) ;04/17/2002 10:11
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Replaces ^XMA5,^XMA5A (ISC-WASH/THM/CAP)
QINIT(XMDUZ,XMK,XMKN,XMZ,XMRESPM,XMABORT) ;
+1 NEW XMZSTR,XMSUBJ,XMRESPS
+2 SET XMABORT=0
+3 ; [#_XMZ_]
SET XMZSTR=$$EZBLD^DIALOG(34537,XMZ)
+4 SET XMSUBJ=$PIECE(^XMB(3.9,XMZ,0),U)
+5 IF XMSUBJ["~U~"
SET XMSUBJ=$$DECODEUP^XMXUTIL1(XMSUBJ)
+6 ; Subj: _XMSUBJ
SET XMSUBJ=$$EZBLD^DIALOG(34536,XMSUBJ)
+7 SET XMRESPS=+$PIECE($GET(^XMB(3.9,XMZ,3,0)),U,4)
+8 ; XMRESPS_ response / responses
SET XMRESPM=$$EZBLD^DIALOG($SELECT(XMRESPS=1:34557.1,1:34557),XMRESPS)
+9 WRITE @IOF
+10 DO PAGE1HDR^XMJMP1(XMDUZ,XMK,XMKN,XMZ,XMRESPS,^XMB(3.9,XMZ,0),XMSUBJ,XMZSTR)
+11 DO INFO(XMDUZ,XMK,XMZ,0,"","","",.XMABORT)
+12 QUIT
INFO(XMDUZ,XMK,XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ;
+1 NEW XMREC,XMRECIPS,XMDIALOG
+2 SET XMREC=^XMB(3.9,XMZ,0)
+3 IF $Y+4>IOSL
Begin DoDot:1
+4 DO PAGE^XMJMQ(.XMABORT)
End DoDot:1
IF XMABORT
QUIT
+5 IF '$TEST
WRITE !
+6 ; Local Message-ID:
WRITE !,$$EZBLD^DIALOG(34559,XMZ_"@"_^XMB("NETNAME"))
+7 ; Priority! / [SPOOL] / <RESPONSE>
SET XMDIALOG=$SELECT($PIECE(XMREC,U,7)["P":34543,$PIECE(XMREC,U,7)["S":34560,$PIECE(XMREC,U,8):34561,1:0)
IF XMDIALOG
DO W(XMDIALOG)
+8 SET XMRECIPS=+$PIECE($GET(^XMB(3.9,XMZ,1,0)),U,4)
+9 ; (_XMRECIPS_ Recipient(s))
IF XMRECIPS
DO W($SELECT(XMRECIPS=1:34562.1,1:34562),XMRECIPS)
+10 ; Confirmation requested.
IF "^Y^y^"[(U_$PIECE(XMREC,U,5)_U)
DO W(34564)
+11 ; Scramble Hint:
IF $DATA(^XMB(3.9,XMZ,"K"))
DO W($SELECT(" "[$PIECE(XMREC,U,10):34565,1:34566),$PIECE(XMREC,U,10))
+12 ; MIME body parts
IF $ORDER(^XMB(3.9,XMZ,2005,0))
DO LIST^XMA2B
+13 ; Closed.
IF "^Y^y^"[(U_$PIECE(XMREC,U,9)_U)
DO W(34567)
+14 ; Confidential.
IF "^Y^y^"[(U_$PIECE(XMREC,U,11)_U)
DO W(34568)
+15 ; 'Information only' for all recipients.
IF "^Y^y^"[(U_$PIECE(XMREC,U,12)_U)
DO W(34570)
+16 IF $DATA(^XMB(3.9,XMZ,.5))
Begin DoDot:1
+17 SET XMREC=^XMB(3.9,XMZ,.5)
+18 ; Delivery basket:
IF $PIECE(XMREC,U,1)'=""
DO W(34571,$PIECE(XMREC,U,1))
End DoDot:1
+19 ; The following is already listed in the message header:
+20 ;I $D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)) D
+21 ;. N XMVAPOR
+22 ;. S XMVAPOR=$P($G(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,5)
+23 ;. I XMVAPOR D W(34572,$$MMDT^XMXUTIL1(XMVAPOR)) ; Automatic Deletion Date:
+24 DO LATER(XMDUZ,XMZ,XMPHDR,XMSUBJ,XMZSTR,.XMPAGE,.XMABORT)
+25 QUIT
LATER(XMDUZ,XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ; List dates message will be new on 'later'
+1 IF '$ORDER(^XMB(3.73,"AC",XMZ,XMDUZ,0))
QUIT
+2 NEW XMIEN,XMSEP
+3 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+4 ; Message will be NEW on:
WRITE !,$$EZBLD^DIALOG(34595)
+5 SET XMIEN=""
SET XMSEP=" "
+6 FOR
SET XMIEN=$ORDER(^XMB(3.73,"AC",XMZ,XMDUZ,XMIEN))
IF XMIEN=""
QUIT
Begin DoDot:1
+7 DO W2(XMSEP,$$FMTE^XLFDT($EXTRACT($PIECE(^XMB(3.73,XMIEN,0),U),1,12)),.XMABORT)
+8 SET XMSEP=", "
End DoDot:1
+9 QUIT
W(XMPIECE,XMPARM) ;
+1 SET XMPIECE=$$EZBLD^DIALOG(XMPIECE,.XMPARM)
+2 IF 1+$LENGTH(XMPIECE)+$X>IOM
Begin DoDot:1
+3 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+4 WRITE !
End DoDot:1
IF XMABORT
QUIT
+5 WRITE " ",XMPIECE
+6 QUIT
W2(XMSEP,XMPIECE,XMABORT) ;
+1 IF $X+$LENGTH(XMSEP)+$LENGTH(XMPIECE)>IOM
Begin DoDot:1
+2 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+3 WRITE !,XMPIECE
End DoDot:1
IF XMABORT
QUIT
+4 IF '$TEST
WRITE XMSEP,XMPIECE
+5 QUIT
NETWORK(XMZ,XMABORT) ;
+1 NEW I,J,XMLINE,XMPOS,XMPHDR
+2 IF $ORDER(^XMB(3.9,XMZ,2,0))'<1
Begin DoDot:1
+3 ; This message originated locally. There is no network header.
WRITE !!,$$EZBLD^DIALOG(34550)
End DoDot:1
QUIT
+4 ; Envelope From:
IF $DATA(^XMB(3.9,XMZ,.7))
WRITE !!,$$EZBLD^DIALOG(34551,$PIECE(^XMB(3.9,XMZ,.7),U,1))
+5 ; Network header:
WRITE !!,$$EZBLD^DIALOG(34552),!
+6 SET (I,XMPHDR)=0
+7 FOR
SET I=$ORDER(^XMB(3.9,XMZ,2,I))
IF I=""!(I'<1)
QUIT
Begin DoDot:1
+8 SET XMLINE=^XMB(3.9,XMZ,2,I,0)
+9 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+10 IF $LENGTH(XMLINE)<IOM
WRITE !,XMLINE
QUIT
+11 SET XMPOS=0
+12 FOR
Begin DoDot:2
+13 IF $LENGTH(XMLINE)+XMPOS+1>IOM
FOR J=IOM-XMPOS-1:-1:IOM-XMPOS-20
IF ", -;)"[$EXTRACT(XMLINE,J)
QUIT
+14 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+15 WRITE !,?XMPOS,$EXTRACT(XMLINE,1,J)
+16 SET XMPOS=10
+17 SET XMLINE=$EXTRACT(XMLINE,J+1,999)
End DoDot:2
IF XMLINE=""!XMABORT
QUIT
End DoDot:1
IF XMABORT
QUIT
+18 QUIT
SUMMARY(XMZ,XMPHDR,XMSUBJ,XMZSTR,XMPAGE,XMABORT) ;
+1 NEW XMTYPE
+2 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+3 WRITE !
+4 IF '$ORDER(^XMB(3.9,XMZ,6,0))
IF '$ORDER(^XMB(3.9,XMZ,7,0))
Begin DoDot:1
+5 NEW XMTEXT
+6 DO BLD^DIALOG(34596,"","","XMTEXT","F")
+7 DO MSG^DIALOG("WM","","","","XMTEXT")
+8 ;This is an old message which has no summary recipient list.
+9 ;Only the Detail Query (QD) is available.
End DoDot:1
QUIT
+10 ; This message was addressed as follows:
WRITE !,$$EZBLD^DIALOG(34597),!
+11 ; addressed to
DO PRTADDR(XMZ,6,.XMTYPE,.XMABORT)
IF XMABORT
QUIT
+12 ; deliver later to
DO PRTADDR(XMZ,7,.XMTYPE,.XMABORT)
+13 QUIT
PRTADDR(XMZ,XMNODE,XMTYPE,XMABORT) ;
+1 NEW XMTO
+2 ; List Broadcasts first
SET XMTO="*"
+3 FOR
SET XMTO=$ORDER(^XMB(3.9,XMZ,XMNODE,"B",XMTO))
IF $EXTRACT(XMTO,1,1)'="*"
QUIT
DO PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT)
IF XMABORT
QUIT
+4 IF XMABORT
QUIT
+5 ; List Groups next
SET XMTO="G."
+6 FOR
SET XMTO=$ORDER(^XMB(3.9,XMZ,XMNODE,"B",XMTO))
IF $EXTRACT(XMTO,1,2)'="G."
QUIT
DO PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT)
IF XMABORT
QUIT
+7 IF XMABORT
QUIT
+8 ; Now list the rest
SET XMTO=""
+9 FOR
SET XMTO=$ORDER(^XMB(3.9,XMZ,XMNODE,"B",XMTO))
IF XMTO=""
QUIT
Begin DoDot:1
+10 IF $EXTRACT(XMTO,1,2)="G."
QUIT
+11 IF $EXTRACT(XMTO,1,1)="*"
QUIT
+12 DO PRTSUMRY(XMZ,XMNODE,XMTO,.XMTYPE,.XMABORT)
End DoDot:1
IF XMABORT
QUIT
+13 QUIT
PRTSUMRY(XMZ,XMNODE,XMTO,XMTYPE,XMABORT) ;
+1 NEW XMIEN,XMREC
+2 SET XMIEN=$ORDER(^XMB(3.9,XMZ,XMNODE,"B",XMTO,0))
IF 'XMIEN
QUIT
+3 SET XMREC=$GET(^XMB(3.9,XMZ,XMNODE,XMIEN,0))
IF XMREC=""
QUIT
+4 IF $Y+3>IOSL
DO PAGE^XMJMQ(.XMABORT)
IF XMABORT
QUIT
+5 IF $PIECE(XMREC,U,2)'=""
Begin DoDot:1
+6 SET XMTYPE=$PIECE(XMREC,U,2)
+7 IF '$DATA(XMTYPE(XMTYPE))
SET XMTYPE(XMTYPE)=$$EXTERNAL^DILFD(3.91,6.5,"",XMTYPE)
IF $DATA(DIERR)
SET XMTYPE(XMTYPE)=XMTYPE
+8 WRITE !,XMTYPE(XMTYPE),":",$PIECE(XMREC,U,1)
End DoDot:1
+9 IF '$TEST
WRITE !,$PIECE(XMREC,U,1)
+10 IF XMNODE=6
QUIT
+11 NEW XMPARM
+12 SET XMPARM(1)=$$MMDT^XMXUTIL1($PIECE(XMREC,U,5))
SET XMPARM(2)=$PIECE(XMREC,U,4)
+13 ; for delivery x by y
DO W(34598,.XMPARM)
+14 QUIT
SEARCH(XMZ,XMNAME,XMRESPM) ;
+1 NEW XMPHDR,XMUSER,XMSITE
+2 SET XMPHDR=0
+3 IF $Y+5>IOSL
Begin DoDot:1
+4 DO PAGE^XMJMQ(.XMABORT)
End DoDot:1
IF XMABORT
QUIT
+5 IF '$TEST
WRITE !
+6 ; Searching for recipients that match '_XMNAME_'.
WRITE !,$$EZBLD^DIALOG(34554,XMNAME),!
+7 IF XMNAME["@"
Begin DoDot:1
+8 SET XMSITE=$$UP^XLFSTR($PIECE(XMNAME,"@",2,99))
+9 ;S XMUSER=$P(XMNAME,"@",1)_$S(XMNAME[",":"@",1:",")
+10 SET XMUSER=$PIECE($PIECE(XMNAME,"@",1),",",1)_","
+11 SET XMNAME=XMUSER_XMSITE
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO FIND^DIC(200,"","@;.01","AP",XMNAME,"","B^BB^C^D","I $D(^XMB(3.9,XMZ,1,""C"",+Y))")
+14 IF '$DATA(DIERR)
DO PSEARCH(200,XMZ,XMRESPM,.XMABORT)
IF XMABORT
QUIT
End DoDot:1
IF XMABORT
QUIT
+15 ; Quit if there aren't any non-local addressees
IF $ORDER(^XMB(3.9,XMZ,1,"C","
QUIT
+16 NEW XMSCREEN
+17 SET XMSCREEN=$SELECT(+XMNAME=XMNAME:"I '$D(^XMB(3.9,XMZ,1,""C"",XMNAME))",1:"")
+18 DO FIND^DIC(3.91,","_XMZ_",","","CP",XMNAME,"","C",XMSCREEN)
+19 IF '$DATA(DIERR)
DO PSEARCH(3.91,XMZ,XMRESPM,.XMABORT)
+20 ; Quit if the search string does not begin with an upper case letter
IF $EXTRACT(XMNAME)'?1U
QUIT
+21 ; Quit if there aren't any lower case addressees
IF $ORDER(^XMB(3.9,XMZ,1,"C","`"))=""
QUIT
+22 ; FM will translate lower case to upper case in its search, but won't
+23 ; translate upper to lower, so we do it here.
+24 ; Limit search to lower case addresses
SET XMSCREEN="I ^(0)]""`"""
+25 SET XMNAME=$SELECT($DATA(XMSITE):$$LOW^XLFSTR(XMUSER)_XMSITE,1:$$LOW^XLFSTR(XMNAME))
+26 DO FIND^DIC(3.91,","_XMZ_",","","CP",XMNAME,"","C",XMSCREEN)
+27 IF '$DATA(DIERR)
DO PSEARCH(3.91,XMZ,XMRESPM,.XMABORT)
+28 QUIT
PSEARCH(XMFILE,XMZ,XMRESPM,XMABORT) ; Print search results
+1 NEW XMI,XMIEN,XMTYPE,XMREC
+2 SET XMI=0
+3 FOR
SET XMI=$ORDER(^TMP("DILIST",$JOB,XMI))
IF 'XMI
QUIT
SET XMREC=^(XMI,0)
Begin DoDot:1
+4 SET XMIEN=$SELECT(XMFILE=200:$ORDER(^XMB(3.9,XMZ,1,"C",$PIECE(XMREC,U,1),0)),1:$PIECE(XMREC,U,1))
+5 DO WNAME^XMJMQ(XMZ,$PIECE(XMREC,U,2),XMIEN,XMRESPM,.XMTYPE,.XMABORT)
End DoDot:1
IF XMABORT
QUIT
+6 QUIT
