- XMJMC ;ISC-SF/GMB-Copy message ;02/23/2000 15:34
- ;;8.0;MailMan;;Jun 28, 2002
- ; Replaces ^XMA2C,^XMA2C0 (ISC-WASH/CAP)
- COPY(XMDUZ,XMK,XMZ,XMFROM) ;
- N XMABORT,XMWHICH,XMLR,XMSAME,XMZREC
- D INIT(XMDUZ,XMK,XMZ,XMFROM,.XMZREC,.XMWHICH,.XMLR,.XMSAME,.XMABORT) Q:XMABORT
- D COPYIT(XMDUZ,XMZ,$P(XMZREC,U,1),XMFROM,$P(XMZREC,U,3),XMWHICH,XMLR,XMSAME)
- Q
- INIT(XMDUZ,XMK,XMZ,XMFROM,XMZREC,XMWHICH,XMLR,XMSAME,XMABORT) ;
- S XMZREC=^XMB(3.9,XMZ,0)
- S XMABORT=0
- D INIT^XMJMS(XMDUZ,.XMABORT) Q:XMABORT
- S XMWHICH=0
- D WHICH(XMZ,$$EZBLD^DIALOG(34600),.XMWHICH,.XMABORT) Q:XMABORT ; copy
- I '$$COPYRECP^XMXSEC1(XMZ) D Q
- . S (XMLR,XMSAME)=0
- . D SHOW^XMJERR
- D LISTR(.XMLR,.XMABORT) Q:XMABORT
- D TOSAME(.XMSAME,.XMABORT)
- Q
- WHICH(XMZ,XMVERB,XMWHICH,XMABORT) ;
- N XMRESPS
- S XMRESPS=+$P($G(^XMB(3.9,XMZ,3,0)),U,4)
- I XMRESPS=0 S XMWHICH=0
- E D WHICH^XMJMP(XMZ,XMRESPS,XMVERB,.XMWHICH,.XMABORT) Q:XMABORT!'$D(XMWHICH)
- Q:$$COPYAMT^XMXSEC1(XMZ,XMWHICH)
- S XMABORT=1
- D SHOW^XMJERR
- ;You may use the 'Transfer' option of the FileMan Editor
- ;to move text from this message or its responses into a new message.
- N XMTEXT
- D BLD^DIALOG(34601,"","","XMTEXT","F")
- D MSG^DIALOG("WH","","","","XMTEXT")
- Q
- LISTR(XMLR,XMABORT) ;
- N DIR,Y
- S DIR("A")=$$EZBLD^DIALOG(34602) ; List original recipients in text
- S DIR("B")=$$EZBLD^DIALOG(39053),DIR(0)="Y",DIR("??")="XM-U-M-COPY-2" ; No
- D ^DIR I $D(DIRUT) S XMABORT=1 Q
- S XMLR=Y
- Q
- TOSAME(XMSAME,XMABORT) ;
- N DIR,Y
- S DIR("A")=$$EZBLD^DIALOG(34603) ; Deliver to the same recipients
- S DIR("B")=$$EZBLD^DIALOG(39053),DIR(0)="Y",DIR("??")="XM-U-M-COPY-2" ; No
- D ^DIR I $D(DIRUT) S XMABORT=1 Q
- S XMSAME=Y
- Q:'XMSAME
- ;LOCAL recipients (NOT Recipients on remote network nodes) will be copied.
- N XMTEXT
- W !
- D BLD^DIALOG(34604,"","","XMTEXT","F")
- D MSG^DIALOG("WM","","","","XMTEXT")
- Q
- COPYIT(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME) ;
- ; XMWHICH List of responses to copy
- ; XMLR 1=list original recipients in msg; 0=don't
- ; XMSAME 1=deliver to the original recipients; 0=don't
- N XMZ,XMSUBJ,XMABORT
- S XMABORT=0
- D INIT^XMXADDR
- S XMSUBJ=$E($$EZBLD^DIALOG(34605,XMSUBJO),1,65) ; Copy of:
- D SUBJ^XMJMS(.XMSUBJ,.XMABORT) Q:XMABORT
- D CRE8XMZ^XMXSEND(XMSUBJ,.XMZ,1) I XMZ<1 S XMABORT=1 Q
- D:'$G(XMPAKMAN) EDITON^XMJMS(XMDUZ,XMZ)
- D CPROCESS(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME,XMZ,XMSUBJ,.XMABORT)
- D:XMABORT=DTIME HALT^XMJMS($$EZBLD^DIALOG(34606)) ; copying
- D:'$G(XMPAKMAN) EDITOFF^XMJMS(XMDUZ)
- D:XMABORT KILLMSG^XMXUTIL(XMZ)
- Q
- CPROCESS(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME,XMZ,XMSUBJ,XMABORT) ;
- N XMINSTR,XMRESTR,XMC
- D COPYTEXT(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,XMWHICH,.XMC)
- D:XMLR!XMSAME COPYRECP(XMLR,XMSAME,XMZO,XMZ,.XMINSTR,.XMC)
- S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XMC_U_XMC_U_DT
- D ET^XMJMSO Q:XMABORT
- D TOWHOM^XMJMT(XMDUZ,$$EZBLD^DIALOG(34110),.XMINSTR,.XMRESTR,.XMABORT) Q:XMABORT ; Send to add'l recipients
- I $G(XMPAKMAN) S XMINSTR("TYPE")=$S($P(^XMB(3.9,XMZO,0),U,7)["K":"K",1:"X")
- D SENDMSG^XMJMSO(XMDUZ,XMZ,XMSUBJ,.XMINSTR,.XMRESTR,.XMABORT) Q:XMABORT ; transmit prompt
- N XMIEN
- S XMIEN=+$O(^XMB(3.9,XMZO,1,"C",XMDUZ,0))
- I XMIEN S ^XMB(3.9,XMZO,1,XMIEN,"C")=$$NOW^XLFDT
- Q
- COPYTEXT(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,XMWHICH,XMC) ;
- N I,XMRESP,XMRANGE
- W !,$$EZBLD^DIALOG(34607) ; Copying text
- D COPYHEAD(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,"C",.XMC)
- F I=1:1:$L(XMWHICH,",") D
- . S XMRANGE=$P(XMWHICH,",",I)
- . Q:XMRANGE="" ; (XMWHICH can end with a ",", giving us a null piece.)
- . F XMRESP=$P(XMRANGE,"-",1):1:$S(XMRANGE["-":$P(XMRANGE,"-",2),1:XMRANGE) D
- . . I XMRESP=0 D COPYRESP(XMRESP,XMZO,XMZ,.XMC) Q
- . . D COPYRESP(XMRESP,+$G(^XMB(3.9,XMZO,3,XMRESP,0)),XMZ,.XMC)
- Q
- COPYHEAD(XMZO,XMSUBJ,XMFROM,XMDATE,XMZ,XMTYPE,XMC) ;
- N XMPRE
- S XMPRE=$S(XMTYPE="C":"",1:">")
- S ^XMB(3.9,XMZ,2,1,0)=XMPRE_$$EZBLD^DIALOG(34205)_": """_XMSUBJ_""""_$S(XMTYPE="C":" "_$$EZBLD^DIALOG(34537,XMZO),1:"") ; Original message:
- S ^XMB(3.9,XMZ,2,2,0)=XMPRE_$$EZBLD^DIALOG(34538,$$NAME^XMXUTIL(XMFROM)) ; From
- S ^XMB(3.9,XMZ,2,3,0)=XMPRE_$$EZBLD^DIALOG(34585,$$MMDT^XMXUTIL1(XMDATE)) ; Sent:
- S XMC=3
- Q
- COPYRESP(XMRESP,XMZR,XMZ,XMC) ;
- N XMF,XMFROM,XMDT,XMZREC
- S XMC=XMC+1
- S ^XMB(3.9,XMZ,2,XMC,0)=""
- I XMRESP D
- . S XMZREC=$G(^XMB(3.9,XMZR,0))
- . S XMFROM=$$NAME^XMXUTIL($P(XMZREC,U,2))
- . S XMDT=$P(XMZREC,U,3)
- . S XMC=XMC+1
- . S ^XMB(3.9,XMZ,2,XMC,0)=$$EZBLD^DIALOG(34204,XMRESP)_": "_XMFROM_" "_$$MMDT^XMXUTIL1(XMDT) ; Response #
- S XMF=.999999
- F S XMF=$O(^XMB(3.9,XMZR,2,XMF)) Q:XMF="" D
- . S XMC=XMC+1
- . W:XMC#50=0 "."
- . S ^XMB(3.9,XMZ,2,XMC,0)=^XMB(3.9,XMZR,2,XMF,0)
- Q
- COPYRECP(XMLR,XMSAME,XMZO,XMZ,XMINSTR,XMC) ;
- N XMTO,XMNAME
- I XMLR D
- . W !,$$EZBLD^DIALOG($S(XMSAME:34610,1:34611)) ; Copying recipients into text (and onto message)
- . N XMTEXT,X
- . S XMTEXT=$$EZBLD^DIALOG(34608) ; Original Recipients
- . S XMC=XMC+1,^XMB(3.9,XMZ,2,XMC,0)=""
- . S XMC=XMC+1,^XMB(3.9,XMZ,2,XMC,0)=XMTEXT
- . S X="",$P(X,"-",$L(XMTEXT)+1)="" ; "-------------------"
- . S XMC=XMC+1,^XMB(3.9,XMZ,2,XMC,0)=X
- E W !,$$EZBLD^DIALOG(34612) ; Copying recipients onto message
- S XMTO=""
- F S XMTO=$O(^XMB(3.9,XMZO,1,"C",XMTO)) Q:XMTO="" D
- . I XMSAME,XMTO=+XMTO W ! D ADDR^XMXADDR(XMDUZ,"`"_XMTO,.XMINSTR)
- . Q:'XMLR
- . I +XMTO=XMTO S XMNAME=$$NAME^XMXUTIL(XMTO)
- . E I $L(XMTO)<30 S XMNAME=XMTO
- . E S XMNAME=$P($G(^XMB(3.9,XMZO,1,$O(^XMB(3.9,XMZO,1,"C",XMTO,0)),0)),U,1)
- . S XMC=XMC+1,^XMB(3.9,XMZ,2,XMC,0)=XMNAME
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMJMC 5550 printed Feb 18, 2025@23:38:04 Page 2
- XMJMC ;ISC-SF/GMB-Copy message ;02/23/2000 15:34
- +1 ;;8.0;MailMan;;Jun 28, 2002
- +2 ; Replaces ^XMA2C,^XMA2C0 (ISC-WASH/CAP)
- COPY(XMDUZ,XMK,XMZ,XMFROM) ;
- +1 NEW XMABORT,XMWHICH,XMLR,XMSAME,XMZREC
- +2 DO INIT(XMDUZ,XMK,XMZ,XMFROM,.XMZREC,.XMWHICH,.XMLR,.XMSAME,.XMABORT)
- if XMABORT
- QUIT
- +3 DO COPYIT(XMDUZ,XMZ,$PIECE(XMZREC,U,1),XMFROM,$PIECE(XMZREC,U,3),XMWHICH,XMLR,XMSAME)
- +4 QUIT
- INIT(XMDUZ,XMK,XMZ,XMFROM,XMZREC,XMWHICH,XMLR,XMSAME,XMABORT) ;
- +1 SET XMZREC=^XMB(3.9,XMZ,0)
- +2 SET XMABORT=0
- +3 DO INIT^XMJMS(XMDUZ,.XMABORT)
- if XMABORT
- QUIT
- +4 SET XMWHICH=0
- +5 ; copy
- DO WHICH(XMZ,$$EZBLD^DIALOG(34600),.XMWHICH,.XMABORT)
- if XMABORT
- QUIT
- +6 IF '$$COPYRECP^XMXSEC1(XMZ)
- Begin DoDot:1
- +7 SET (XMLR,XMSAME)=0
- +8 DO SHOW^XMJERR
- End DoDot:1
- QUIT
- +9 DO LISTR(.XMLR,.XMABORT)
- if XMABORT
- QUIT
- +10 DO TOSAME(.XMSAME,.XMABORT)
- +11 QUIT
- WHICH(XMZ,XMVERB,XMWHICH,XMABORT) ;
- +1 NEW XMRESPS
- +2 SET XMRESPS=+$PIECE($GET(^XMB(3.9,XMZ,3,0)),U,4)
- +3 IF XMRESPS=0
- SET XMWHICH=0
- +4 IF '$TEST
- DO WHICH^XMJMP(XMZ,XMRESPS,XMVERB,.XMWHICH,.XMABORT)
- if XMABORT!'$DATA(XMWHICH)
- QUIT
- +5 if $$COPYAMT^XMXSEC1(XMZ,XMWHICH)
- QUIT
- +6 SET XMABORT=1
- +7 DO SHOW^XMJERR
- +8 ;You may use the 'Transfer' option of the FileMan Editor
- +9 ;to move text from this message or its responses into a new message.
- +10 NEW XMTEXT
- +11 DO BLD^DIALOG(34601,"","","XMTEXT","F")
- +12 DO MSG^DIALOG("WH","","","","XMTEXT")
- +13 QUIT
- LISTR(XMLR,XMABORT) ;
- +1 NEW DIR,Y
- +2 ; List original recipients in text
- SET DIR("A")=$$EZBLD^DIALOG(34602)
- +3 ; No
- SET DIR("B")=$$EZBLD^DIALOG(39053)
- SET DIR(0)="Y"
- SET DIR("??")="XM-U-M-COPY-2"
- +4 DO ^DIR
- IF $DATA(DIRUT)
- SET XMABORT=1
- QUIT
- +5 SET XMLR=Y
- +6 QUIT
- TOSAME(XMSAME,XMABORT) ;
- +1 NEW DIR,Y
- +2 ; Deliver to the same recipients
- SET DIR("A")=$$EZBLD^DIALOG(34603)
- +3 ; No
- SET DIR("B")=$$EZBLD^DIALOG(39053)
- SET DIR(0)="Y"
- SET DIR("??")="XM-U-M-COPY-2"
- +4 DO ^DIR
- IF $DATA(DIRUT)
- SET XMABORT=1
- QUIT
- +5 SET XMSAME=Y
- +6 if 'XMSAME
- QUIT
- +7 ;LOCAL recipients (NOT Recipients on remote network nodes) will be copied.
- +8 NEW XMTEXT
- +9 WRITE !
- +10 DO BLD^DIALOG(34604,"","","XMTEXT","F")
- +11 DO MSG^DIALOG("WM","","","","XMTEXT")
- +12 QUIT
- COPYIT(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME) ;
- +1 ; XMWHICH List of responses to copy
- +2 ; XMLR 1=list original recipients in msg; 0=don't
- +3 ; XMSAME 1=deliver to the original recipients; 0=don't
- +4 NEW XMZ,XMSUBJ,XMABORT
- +5 SET XMABORT=0
- +6 DO INIT^XMXADDR
- +7 ; Copy of:
- SET XMSUBJ=$EXTRACT($$EZBLD^DIALOG(34605,XMSUBJO),1,65)
- +8 DO SUBJ^XMJMS(.XMSUBJ,.XMABORT)
- if XMABORT
- QUIT
- +9 DO CRE8XMZ^XMXSEND(XMSUBJ,.XMZ,1)
- IF XMZ<1
- SET XMABORT=1
- QUIT
- +10 if '$GET(XMPAKMAN)
- DO EDITON^XMJMS(XMDUZ,XMZ)
- +11 DO CPROCESS(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME,XMZ,XMSUBJ,.XMABORT)
- +12 ; copying
- if XMABORT=DTIME
- DO HALT^XMJMS($$EZBLD^DIALOG(34606))
- +13 if '$GET(XMPAKMAN)
- DO EDITOFF^XMJMS(XMDUZ)
- +14 if XMABORT
- DO KILLMSG^XMXUTIL(XMZ)
- +15 QUIT
- CPROCESS(XMDUZ,XMZO,XMSUBJO,XMFROM,XMDATEO,XMWHICH,XMLR,XMSAME,XMZ,XMSUBJ,XMABORT) ;
- +1 NEW XMINSTR,XMRESTR,XMC
- +2 DO COPYTEXT(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,XMWHICH,.XMC)
- +3 if XMLR!XMSAME
- DO COPYRECP(XMLR,XMSAME,XMZO,XMZ,.XMINSTR,.XMC)
- +4 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_XMC_U_XMC_U_DT
- +5 DO ET^XMJMSO
- if XMABORT
- QUIT
- +6 ; Send to add'l recipients
- DO TOWHOM^XMJMT(XMDUZ,$$EZBLD^DIALOG(34110),.XMINSTR,.XMRESTR,.XMABORT)
- if XMABORT
- QUIT
- +7 IF $GET(XMPAKMAN)
- SET XMINSTR("TYPE")=$SELECT($PIECE(^XMB(3.9,XMZO,0),U,7)["K":"K",1:"X")
- +8 ; transmit prompt
- DO SENDMSG^XMJMSO(XMDUZ,XMZ,XMSUBJ,.XMINSTR,.XMRESTR,.XMABORT)
- if XMABORT
- QUIT
- +9 NEW XMIEN
- +10 SET XMIEN=+$ORDER(^XMB(3.9,XMZO,1,"C",XMDUZ,0))
- +11 IF XMIEN
- SET ^XMB(3.9,XMZO,1,XMIEN,"C")=$$NOW^XLFDT
- +12 QUIT
- COPYTEXT(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,XMWHICH,XMC) ;
- +1 NEW I,XMRESP,XMRANGE
- +2 ; Copying text
- WRITE !,$$EZBLD^DIALOG(34607)
- +3 DO COPYHEAD(XMZO,XMSUBJO,XMFROM,XMDATEO,XMZ,"C",.XMC)
- +4 FOR I=1:1:$LENGTH(XMWHICH,",")
- Begin DoDot:1
- +5 SET XMRANGE=$PIECE(XMWHICH,",",I)
- +6 ; (XMWHICH can end with a ",", giving us a null piece.)
- if XMRANGE=""
- QUIT
- +7 FOR XMRESP=$PIECE(XMRANGE,"-",1):1:$SELECT(XMRANGE["-":$PIECE(XMRANGE,"-",2),1:XMRANGE)
- Begin DoDot:2
- +8 IF XMRESP=0
- DO COPYRESP(XMRESP,XMZO,XMZ,.XMC)
- QUIT
- +9 DO COPYRESP(XMRESP,+$GET(^XMB(3.9,XMZO,3,XMRESP,0)),XMZ,.XMC)
- End DoDot:2
- End DoDot:1
- +10 QUIT
- COPYHEAD(XMZO,XMSUBJ,XMFROM,XMDATE,XMZ,XMTYPE,XMC) ;
- +1 NEW XMPRE
- +2 SET XMPRE=$SELECT(XMTYPE="C":"",1:">")
- +3 ; Original message:
- SET ^XMB(3.9,XMZ,2,1,0)=XMPRE_$$EZBLD^DIALOG(34205)_": """_XMSUBJ_""""_$SELECT(XMTYPE="C":" "_$$EZBLD^DIALOG(34537,XMZO),1:"")
- +4 ; From
- SET ^XMB(3.9,XMZ,2,2,0)=XMPRE_$$EZBLD^DIALOG(34538,$$NAME^XMXUTIL(XMFROM))
- +5 ; Sent:
- SET ^XMB(3.9,XMZ,2,3,0)=XMPRE_$$EZBLD^DIALOG(34585,$$MMDT^XMXUTIL1(XMDATE))
- +6 SET XMC=3
- +7 QUIT
- COPYRESP(XMRESP,XMZR,XMZ,XMC) ;
- +1 NEW XMF,XMFROM,XMDT,XMZREC
- +2 SET XMC=XMC+1
- +3 SET ^XMB(3.9,XMZ,2,XMC,0)=""
- +4 IF XMRESP
- Begin DoDot:1
- +5 SET XMZREC=$GET(^XMB(3.9,XMZR,0))
- +6 SET XMFROM=$$NAME^XMXUTIL($PIECE(XMZREC,U,2))
- +7 SET XMDT=$PIECE(XMZREC,U,3)
- +8 SET XMC=XMC+1
- +9 ; Response #
- SET ^XMB(3.9,XMZ,2,XMC,0)=$$EZBLD^DIALOG(34204,XMRESP)_": "_XMFROM_" "_$$MMDT^XMXUTIL1(XMDT)
- End DoDot:1
- +10 SET XMF=.999999
- +11 FOR
- SET XMF=$ORDER(^XMB(3.9,XMZR,2,XMF))
- if XMF=""
- QUIT
- Begin DoDot:1
- +12 SET XMC=XMC+1
- +13 if XMC#50=0
- WRITE "."
- +14 SET ^XMB(3.9,XMZ,2,XMC,0)=^XMB(3.9,XMZR,2,XMF,0)
- End DoDot:1
- +15 QUIT
- COPYRECP(XMLR,XMSAME,XMZO,XMZ,XMINSTR,XMC) ;
- +1 NEW XMTO,XMNAME
- +2 IF XMLR
- Begin DoDot:1
- +3 ; Copying recipients into text (and onto message)
- WRITE !,$$EZBLD^DIALOG($SELECT(XMSAME:34610,1:34611))
- +4 NEW XMTEXT,X
- +5 ; Original Recipients
- SET XMTEXT=$$EZBLD^DIALOG(34608)
- +6 SET XMC=XMC+1
- SET ^XMB(3.9,XMZ,2,XMC,0)=""
- +7 SET XMC=XMC+1
- SET ^XMB(3.9,XMZ,2,XMC,0)=XMTEXT
- +8 ; "-------------------"
- SET X=""
- SET $PIECE(X,"-",$LENGTH(XMTEXT)+1)=""
- +9 SET XMC=XMC+1
- SET ^XMB(3.9,XMZ,2,XMC,0)=X
- End DoDot:1
- +10 ; Copying recipients onto message
- IF '$TEST
- WRITE !,$$EZBLD^DIALOG(34612)
- +11 SET XMTO=""
- +12 FOR
- SET XMTO=$ORDER(^XMB(3.9,XMZO,1,"C",XMTO))
- if XMTO=""
- QUIT
- Begin DoDot:1
- +13 IF XMSAME
- IF XMTO=+XMTO
- WRITE !
- DO ADDR^XMXADDR(XMDUZ,"`"_XMTO,.XMINSTR)
- +14 if 'XMLR
- QUIT
- +15 IF +XMTO=XMTO
- SET XMNAME=$$NAME^XMXUTIL(XMTO)
- +16 IF '$TEST
- IF $LENGTH(XMTO)<30
- SET XMNAME=XMTO
- +17 IF '$TEST
- SET XMNAME=$PIECE($GET(^XMB(3.9,XMZO,1,$ORDER(^XMB(3.9,XMZO,1,"C",XMTO,0)),0)),U,1)
- +18 SET XMC=XMC+1
- SET ^XMB(3.9,XMZ,2,XMC,0)=XMNAME
- End DoDot:1
- +19 QUIT