- XMXPARM ;ISC-SF/GMB-Parameter check ;03/26/2003 08:00
- ;;8.0;MailMan;**15,45**;Jun 28, 2002;Build 8
- ACTMSGS(XMDUZ,XMK,XMKZA) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- I $G(XMK)'="" S XMK=$$XMK(XMDUZ,"XMK",XMK)
- D XMKZA^XMXPARM1(.XMKZA)
- Q
- ACTMSG(XMDUZ,XMK,XMKZ) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- I $G(XMK)'="" D
- . S XMK=$$XMK(XMDUZ,"XMK",XMK)
- . D XMKZ^XMXPARM1(XMK,.XMKZ)
- E D XMZ(.XMKZ)
- Q
- ANSRMSG(XMDUZ,XMK,XMKZ,XMSUBJ,XMBODY,XMTO,XMINSTR) ;
- D ACTMSG(.XMDUZ,.XMK,.XMKZ)
- I $G(XMSUBJ)'="" S XMSUBJ=$$XMSUBJ("XMSUBJ",$G(XMSUBJ))
- D XMBODY^XMXPARM1(.XMBODY)
- D:$D(XMTO) XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; truly optional
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- Q
- BULLETIN(XMDUZ,XMBN,XMPARM,XMBODY,XMTO,XMINSTR,XMATTACH) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- D XMBN^XMXPARM1(.XMBN)
- D:$D(XMBODY) XMBODY^XMXPARM1(.XMBODY,1)
- D:$D(XMTO) XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; truly optional
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- Q
- FWDMSG(XMDUZ,XMK,XMKZA,XMTO,XMINSTR) ;
- D ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- D XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; need at least one
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- Q
- LATERMSG(XMDUZ,XMK,XMKZA,XMINSTR) ;
- D ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- I $D(XMINSTR("LATER")) D Q
- . ;I XMINSTR("LATER")="@" Q
- . S XMINSTR("LATER")=$$XMDATE("XMINSTR(""LATER"")",XMINSTR("LATER"))
- I $G(XMINSTR)'="" D Q
- . ;I XMINSTR="@" Q
- . S XMINSTR=$$XMDATE("LATER",XMINSTR)
- D ERRSET^XMXUTIL(39419) ;Later date must be supplied.
- Q
- MOVEMSG(XMDUZ,XMK,XMKZA,XMKTO) ;
- D ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- D XMKTO(XMDUZ,.XMKTO)
- Q
- PRTMSG(XMDUZ,XMK,XMKZA,XMPRTTO,XMINSTR,XMSUBJ,XMTO) ;
- D ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- Q:'$D(XMINSTR)
- I $D(XMINSTR("WHEN")) S XMINSTR("WHEN")=$$XMDATE("XMINSTR(""WHEN"")",XMINSTR("WHEN"))
- I $D(XMINSTR("HDR")) D XMCODE^XMXPARM1("XMINSTR(""HDR"")",XMINSTR("HDR"),"^0^1^")
- I $D(XMINSTR("RECIPS")) D XMCODE^XMXPARM1("XMINSTR(""RECIPS"")",XMINSTR("RECIPS"),"^0^1^2^")
- I $G(XMSUBJ)'="" S XMSUBJ=$$XMSUBJ("XMSUBJ",$G(XMSUBJ))
- I $D(XMTO) D XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; ok
- Q
- REPLYMSG(XMDUZ,XMK,XMKZ,XMBODY,XMINSTR) ;
- D ACTMSG(.XMDUZ,.XMK,.XMKZ)
- D XMBODY^XMXPARM1(.XMBODY)
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- I $G(XMINSTR("NET REPLY")),$G(XMINSTR("NET SUBJ"))'="" S XMINSTR("NET SUBJ")=$$XMSUBJ("XMINSTR(""NET SUBJ"")",XMINSTR("NET SUBJ"))
- Q
- SENDMSG(XMDUZ,XMSUBJ,XMBODY,XMTO,XMINSTR,XMATTACH) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- S XMSUBJ=$$XMSUBJ("XMSUBJ",$G(XMSUBJ))
- D XMBODY^XMXPARM1(.XMBODY)
- D XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; need at least one
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- D:$D(XMATTACH) XMATTACH^XMXPARM1(.XMATTACH)
- Q
- VAPORMSG(XMDUZ,XMK,XMKZA,XMINSTR) ;
- D ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- I $D(XMINSTR("VAPOR")) D Q
- . I XMINSTR("VAPOR")="@" Q
- . S XMINSTR("VAPOR")=$$XMDATE("XMINSTR(""VAPOR"")",XMINSTR("VAPOR"))
- I $G(XMINSTR)'="" D Q
- . I XMINSTR="@" Q
- . S XMINSTR=$$XMDATE("VAPOR",XMINSTR)
- D ERRSET^XMXUTIL(39417) ;Vaporize date must be supplied.
- Q
- ADDRNSND(XMDUZ,XMZ,XMTO,XMINSTR) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- D XMZ(.XMZ)
- D XMTO^XMXPARM1(.XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; need at least one
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- Q
- MOVEBODY(XMZ,XMBODY) ;
- K XMERR,^TMP("XMERR",$J)
- D XMZ(.XMZ)
- D XMBODY^XMXPARM1(.XMBODY)
- Q
- VSUBJ(XMSUBJ) ;
- K XMERR,^TMP("XMERR",$J)
- S XMSUBJ=$$XMSUBJ("XMSUBJ",$G(XMSUBJ))
- Q
- ITOWHOM(XMDUZ,XMZ,XMTYPE,XMINSTR) ;
- K XMERR,^TMP("XMERR",$J)
- D XMDUZ(.XMDUZ,.XMV)
- D XMFLAG("XMTYPE",XMTYPE,"SF")
- I XMTYPE'="S",XMINSTR("ADDR FLAGS")'["R" D XMZ(.XMZ)
- D:$D(XMINSTR) XMINSTR(.XMINSTR)
- Q
- TOWHOM(XMDUZ,XMZ,XMTYPE,XMTO,XMINSTR) ;
- D ITOWHOM(.XMDUZ,.XMZ,.XMTYPE,.XMINSTR)
- D XMTO^XMXPARM1(XMTO,$G(XMINSTR("ADDR FLAGS"))["I") ; need at least one
- Q
- XMDUZ(XMDUZ,XMV) ;
- S:$G(XMDUZ)="" XMDUZ=DUZ
- D CHKUSER^XMXPARM1(.XMDUZ)
- ; Need XMV "NAME","DUZ NAME", "NETNAME", "VERSION"
- ; ^XMB("NETNAME"),^XMB("NUM"),^XMB("VIA")
- I XMDUZ'=DUZ D
- . I $D(^XUSEC("XMNOPRIV",DUZ)) D Q ;You have been given the XMNOPRIV
- . . D ERRSET^XMXUTIL(38053) ;key and may not become anyone's surrogate.
- . I XMDUZ'=.6,'$D(^XMB(3.7,"AB",DUZ,XMDUZ)) D Q
- . . ;You are not authorized to be a surrogate of DUZ |1|.
- . . D ERRSET^XMXUTIL(39401,XMDUZ)
- I $D(XMV("VERSION")),$G(XMV("DUZ NAME"))=$$NAME^XMXUTIL(DUZ),$G(XMV("NAME"))=$$NAME^XMXUTIL(XMDUZ) Q
- D INITAPI^XMVVITAE
- Q
- XMSUBJ(XMPARM,XMSUBJ) ; Validate a prospective message subject
- ;I $G(XMSUBJ)="" D ERRSET^XMXUTIL(39402) Q "" ;No subject.
- I XMSUBJ?.E1C.E S XMSUBJ=$$CTRL^XMXUTIL1(XMSUBJ)
- I $E(XMSUBJ,1)=" "!($E(XMSUBJ,$L(XMSUBJ))=" ") S XMSUBJ=$$STRIP^XMXUTIL1(XMSUBJ)
- I XMSUBJ[" " S XMSUBJ=$$MAXBLANK^XMXUTIL1(XMSUBJ)
- I $G(XMSUBJ)="" Q $$EZBLD^DIALOG(34012) ;* No Subject *
- I $L(XMSUBJ)+(2*($L(XMSUBJ,U)-1))>65!($L(XMSUBJ)<3) D Q XMSUBJ
- . D ERRSET^XMXUTIL(39403) ;Subject must be from 3 to 65 characters long.
- I XMSUBJ?1"R".N D Q XMSUBJ
- . D ERRSET^XMXUTIL(39404) ;Subject 'Rnnn' reserved.
- ;D CHK^DIE(3.9,.01,"H",XMSUBJ)
- Q XMSUBJ
- XMINSTR(XMINSTR) ; Validate special instructions
- S:$D(XMINSTR("RCPT BSKT")) XMINSTR("RCPT BSKT")=$$XMKN^XMXPARMB(XMDUZ,"XMINSTR(""RCPT BSKT"")",XMINSTR("RCPT BSKT"),1)
- S:$D(XMINSTR("SELF BSKT")) XMINSTR("SELF BSKT")=$$XMK(XMDUZ,"XMINSTR(""SELF BSKT"")",XMINSTR("SELF BSKT"),1)
- I $D(XMINSTR("SHARE DATE")) S XMINSTR("SHARE DATE")=$$XMDATE("XMINSTR(""SHARE DATE"")",XMINSTR("SHARE DATE"))
- S:$D(XMINSTR("SHARE BSKT")) XMINSTR("SHARE BSKT")=$$XMK(.6,"XMINSTR(""SHARE BSKT"")",XMINSTR("SHARE BSKT"),1)
- I $D(XMINSTR("VAPOR")) S XMINSTR("VAPOR")=$$XMDATE("XMINSTR(""VAPOR"")",XMINSTR("VAPOR"))
- I $D(XMINSTR("LATER")) S XMINSTR("LATER")=$$XMDATE("XMINSTR(""LATER"")",XMINSTR("LATER"))
- I $D(XMINSTR("FROM")) S XMINSTR("FROM")=$$XMFROM("XMINSTR(""FROM"")",XMINSTR("FROM"))
- I $D(XMINSTR("FWD BY")) S XMINSTR("FWD BY")=$$XMFROM("XMINSTR(""FWD BY"")",XMINSTR("FWD BY"))
- D:$D(XMINSTR("FLAGS")) XMFLAG("XMINSTR(""FLAGS"")",XMINSTR("FLAGS"),"CIPRSX")
- I $D(XMINSTR("SCR KEY"))!$D(XMINSTR("SCR HINT")) D
- . D XMKEY^XMXPARM1($G(XMINSTR("SCR KEY")))
- . D XMHINT^XMXPARM1($G(XMINSTR("SCR HINT")))
- D:$D(XMINSTR("TYPE")) XMTYPE(XMINSTR("TYPE"))
- D:$D(XMINSTR("STRIP")) XMSTRIP^XMXPARM1(XMINSTR("STRIP"))
- Q
- XMDATE(XMPARM,XMDATE) ;
- N %DT,Y,X
- S X=XMDATE
- S %DT="FT",%DT(0)="NOW"
- D ^%DT
- Q:Y>0 Y
- N XMP
- S XMP("PARAM","ID")=XMPARM
- S XMP("PARAM","VALUE")=XMDATE
- D ERRSET^XMXUTIL(39409,.XMP) ;Must be a date in the future.
- Q XMDATE
- XMFROM(XMPARM,XMFROM) ;
- ;Code below is preventing valid new person file entries from Processing
- ;N XMHOLD
- Q:XMFROM=.5 XMFROM
- I +XMFROM=XMFROM!(XMFROM[U)!($L(XMFROM)>65)!(XMFROM="") D Q XMFROM
- . N XMP S XMP("PARAM","ID")=XMPARM,XMP("PARAM","VALUE")=XMFROM
- . ;S XMP("PARAM","FILE")=X,XMP("PARAM","FIELD")=Y
- . ;Must be from 1 to 65 characters, no # or ^.
- . D ERRSET^XMXUTIL(39410,.XMP)
- ;S XMHOLD=XMFROM
- ;S XMFROM=$$CTRL^XMXUTIL1(XMFROM)
- ;S XMFROM=$$STRIP^XMXUTIL1(XMFROM)
- ;S XMFROM=$$MAXBLANK^XMXUTIL1(XMFROM)
- ;Q:XMFROM["POSTMASTER" XMFROM
- ; "B^BB^C^D" = name^alias^initial^nickname
- ;I '$$FIND1^DIC(200,"","O",$$UP^XLFSTR(XMFROM),"B^BB^C^D")!$D(DIERR) D Q XMHOLD
- ;. N XMP S XMP("PARAM","ID")=XMPARM,XMP("PARAM","VALUE")=XMHOLD
- ;. ;S XMP("PARAM","FILE")=X,XMP("PARAM","FIELD")=Y
- ;. D ERRSET^XMXUTIL(39411,.XMP) ;May not be a real person.
- Q XMFROM
- XMTYPE(XMTYPE) ; Validate a message type
- I $L(XMTYPE)'=1 D Q
- . N XMP S XMP("PARAM","ID")="XMINSTR(""TYPE"")",XMP("PARAM","VALUE")=XMTYPE
- . ;S XMPARM("PARAM","FILE")=3.9,XMPARM("PARAM","FIELD")=1.7
- . D ERRSET^XMXUTIL(39412,.XMP) ;Must be 1 character.
- D XMFLAG("XMINSTR(""TYPE"")",XMTYPE,"BDKOSX")
- Q
- XMFLAG(XMPARM,XMFLAG,FLAGSET) ;
- N XMLEFT
- S XMLEFT=$TR(XMFLAG,FLAGSET,"")
- Q:XMLEFT=""
- N XMP S XMP("PARAM","ID")=XMPARM,XMP("PARAM","VALUE")=XMFLAG,XMP(1)=XMLEFT
- D ERRSET^XMXUTIL(39413,.XMP) ;|1| is not valid.
- Q
- XMKTO(XMDUZ,XMKTO) ;
- I $G(XMKTO)="" D Q
- . N XMP S XMP("PARAM","ID")="XMKTO",XMP("PARAM","VALUE")=""
- . D ERRSET^XMXUTIL(39416,.XMP) ;Destination basket must be supplied.
- S XMKTO=$$XMK(XMDUZ,"XMKTO",XMKTO)
- Q
- XMK(XMDUZ,XMPARM,XMK,XMOPTNL) ;
- I +XMK=XMK,$D(^XMB(3.7,XMDUZ,2,XMK)) Q XMK
- ; Just in case a name was passed...
- N XMKN
- S XMKN=XMK
- S XMK=$$FIND1^DIC(3.701,","_XMDUZ_",","OQ",XMKN)
- Q:XMK XMK
- I '$D(DIERR),$G(XMOPTNL) Q XMKN ; Basket not found. Will create on delivery.
- N XMP S XMP("PARAM","ID")=XMPARM,XMP("PARAM","VALUE")=XMKN,XMP(1)=XMKN
- ;Basket name '|1|' ambiguous / not found.
- D ERRSET^XMXUTIL($S($D(DIERR):39414,1:39415),.XMP)
- Q XMKN
- XMZ(XMZ) ;
- I $G(XMZ),$D(^XMB(3.9,XMZ,0)) Q
- D ERRSET^XMXUTIL(34353,XMZ) ;Message '|1|' does not exist.
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMXPARM 8789 printed Feb 18, 2025@23:40:28 Page 2
- XMXPARM ;ISC-SF/GMB-Parameter check ;03/26/2003 08:00
- +1 ;;8.0;MailMan;**15,45**;Jun 28, 2002;Build 8
- ACTMSGS(XMDUZ,XMK,XMKZA) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 IF $GET(XMK)'=""
- SET XMK=$$XMK(XMDUZ,"XMK",XMK)
- +4 DO XMKZA^XMXPARM1(.XMKZA)
- +5 QUIT
- ACTMSG(XMDUZ,XMK,XMKZ) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 IF $GET(XMK)'=""
- Begin DoDot:1
- +4 SET XMK=$$XMK(XMDUZ,"XMK",XMK)
- +5 DO XMKZ^XMXPARM1(XMK,.XMKZ)
- End DoDot:1
- +6 IF '$TEST
- DO XMZ(.XMKZ)
- +7 QUIT
- ANSRMSG(XMDUZ,XMK,XMKZ,XMSUBJ,XMBODY,XMTO,XMINSTR) ;
- +1 DO ACTMSG(.XMDUZ,.XMK,.XMKZ)
- +2 IF $GET(XMSUBJ)'=""
- SET XMSUBJ=$$XMSUBJ("XMSUBJ",$GET(XMSUBJ))
- +3 DO XMBODY^XMXPARM1(.XMBODY)
- +4 ; truly optional
- if $DATA(XMTO)
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +5 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +6 QUIT
- BULLETIN(XMDUZ,XMBN,XMPARM,XMBODY,XMTO,XMINSTR,XMATTACH) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 DO XMBN^XMXPARM1(.XMBN)
- +4 if $DATA(XMBODY)
- DO XMBODY^XMXPARM1(.XMBODY,1)
- +5 ; truly optional
- if $DATA(XMTO)
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +6 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +7 QUIT
- FWDMSG(XMDUZ,XMK,XMKZA,XMTO,XMINSTR) ;
- +1 DO ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- +2 ; need at least one
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +3 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +4 QUIT
- LATERMSG(XMDUZ,XMK,XMKZA,XMINSTR) ;
- +1 DO ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- +2 IF $DATA(XMINSTR("LATER"))
- Begin DoDot:1
- +3 ;I XMINSTR("LATER")="@" Q
- +4 SET XMINSTR("LATER")=$$XMDATE("XMINSTR(""LATER"")",XMINSTR("LATER"))
- End DoDot:1
- QUIT
- +5 IF $GET(XMINSTR)'=""
- Begin DoDot:1
- +6 ;I XMINSTR="@" Q
- +7 SET XMINSTR=$$XMDATE("LATER",XMINSTR)
- End DoDot:1
- QUIT
- +8 ;Later date must be supplied.
- DO ERRSET^XMXUTIL(39419)
- +9 QUIT
- MOVEMSG(XMDUZ,XMK,XMKZA,XMKTO) ;
- +1 DO ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- +2 DO XMKTO(XMDUZ,.XMKTO)
- +3 QUIT
- PRTMSG(XMDUZ,XMK,XMKZA,XMPRTTO,XMINSTR,XMSUBJ,XMTO) ;
- +1 DO ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- +2 if '$DATA(XMINSTR)
- QUIT
- +3 IF $DATA(XMINSTR("WHEN"))
- SET XMINSTR("WHEN")=$$XMDATE("XMINSTR(""WHEN"")",XMINSTR("WHEN"))
- +4 IF $DATA(XMINSTR("HDR"))
- DO XMCODE^XMXPARM1("XMINSTR(""HDR"")",XMINSTR("HDR"),"^0^1^")
- +5 IF $DATA(XMINSTR("RECIPS"))
- DO XMCODE^XMXPARM1("XMINSTR(""RECIPS"")",XMINSTR("RECIPS"),"^0^1^2^")
- +6 IF $GET(XMSUBJ)'=""
- SET XMSUBJ=$$XMSUBJ("XMSUBJ",$GET(XMSUBJ))
- +7 ; ok
- IF $DATA(XMTO)
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +8 QUIT
- REPLYMSG(XMDUZ,XMK,XMKZ,XMBODY,XMINSTR) ;
- +1 DO ACTMSG(.XMDUZ,.XMK,.XMKZ)
- +2 DO XMBODY^XMXPARM1(.XMBODY)
- +3 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +4 IF $GET(XMINSTR("NET REPLY"))
- IF $GET(XMINSTR("NET SUBJ"))'=""
- SET XMINSTR("NET SUBJ")=$$XMSUBJ("XMINSTR(""NET SUBJ"")",XMINSTR("NET SUBJ"))
- +5 QUIT
- SENDMSG(XMDUZ,XMSUBJ,XMBODY,XMTO,XMINSTR,XMATTACH) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 SET XMSUBJ=$$XMSUBJ("XMSUBJ",$GET(XMSUBJ))
- +4 DO XMBODY^XMXPARM1(.XMBODY)
- +5 ; need at least one
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +6 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +7 if $DATA(XMATTACH)
- DO XMATTACH^XMXPARM1(.XMATTACH)
- +8 QUIT
- VAPORMSG(XMDUZ,XMK,XMKZA,XMINSTR) ;
- +1 DO ACTMSGS(.XMDUZ,.XMK,.XMKZA)
- +2 IF $DATA(XMINSTR("VAPOR"))
- Begin DoDot:1
- +3 IF XMINSTR("VAPOR")="@"
- QUIT
- +4 SET XMINSTR("VAPOR")=$$XMDATE("XMINSTR(""VAPOR"")",XMINSTR("VAPOR"))
- End DoDot:1
- QUIT
- +5 IF $GET(XMINSTR)'=""
- Begin DoDot:1
- +6 IF XMINSTR="@"
- QUIT
- +7 SET XMINSTR=$$XMDATE("VAPOR",XMINSTR)
- End DoDot:1
- QUIT
- +8 ;Vaporize date must be supplied.
- DO ERRSET^XMXUTIL(39417)
- +9 QUIT
- ADDRNSND(XMDUZ,XMZ,XMTO,XMINSTR) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 DO XMZ(.XMZ)
- +4 ; need at least one
- DO XMTO^XMXPARM1(.XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +5 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +6 QUIT
- MOVEBODY(XMZ,XMBODY) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMZ(.XMZ)
- +3 DO XMBODY^XMXPARM1(.XMBODY)
- +4 QUIT
- VSUBJ(XMSUBJ) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 SET XMSUBJ=$$XMSUBJ("XMSUBJ",$GET(XMSUBJ))
- +3 QUIT
- ITOWHOM(XMDUZ,XMZ,XMTYPE,XMINSTR) ;
- +1 KILL XMERR,^TMP("XMERR",$JOB)
- +2 DO XMDUZ(.XMDUZ,.XMV)
- +3 DO XMFLAG("XMTYPE",XMTYPE,"SF")
- +4 IF XMTYPE'="S"
- IF XMINSTR("ADDR FLAGS")'["R"
- DO XMZ(.XMZ)
- +5 if $DATA(XMINSTR)
- DO XMINSTR(.XMINSTR)
- +6 QUIT
- TOWHOM(XMDUZ,XMZ,XMTYPE,XMTO,XMINSTR) ;
- +1 DO ITOWHOM(.XMDUZ,.XMZ,.XMTYPE,.XMINSTR)
- +2 ; need at least one
- DO XMTO^XMXPARM1(XMTO,$GET(XMINSTR("ADDR FLAGS"))["I")
- +3 QUIT
- XMDUZ(XMDUZ,XMV) ;
- +1 if $GET(XMDUZ)=""
- SET XMDUZ=DUZ
- +2 DO CHKUSER^XMXPARM1(.XMDUZ)
- +3 ; Need XMV "NAME","DUZ NAME", "NETNAME", "VERSION"
- +4 ; ^XMB("NETNAME"),^XMB("NUM"),^XMB("VIA")
- +5 IF XMDUZ'=DUZ
- Begin DoDot:1
- +6 ;You have been given the XMNOPRIV
- IF $DATA(^XUSEC("XMNOPRIV",DUZ))
- Begin DoDot:2
- +7 ;key and may not become anyone's surrogate.
- DO ERRSET^XMXUTIL(38053)
- End DoDot:2
- QUIT
- +8 IF XMDUZ'=.6
- IF '$DATA(^XMB(3.7,"AB",DUZ,XMDUZ))
- Begin DoDot:2
- +9 ;You are not authorized to be a surrogate of DUZ |1|.
- +10 DO ERRSET^XMXUTIL(39401,XMDUZ)
- End DoDot:2
- QUIT
- End DoDot:1
- +11 IF $DATA(XMV("VERSION"))
- IF $GET(XMV("DUZ NAME"))=$$NAME^XMXUTIL(DUZ)
- IF $GET(XMV("NAME"))=$$NAME^XMXUTIL(XMDUZ)
- QUIT
- +12 DO INITAPI^XMVVITAE
- +13 QUIT
- XMSUBJ(XMPARM,XMSUBJ) ; Validate a prospective message subject
- +1 ;I $G(XMSUBJ)="" D ERRSET^XMXUTIL(39402) Q "" ;No subject.
- +2 IF XMSUBJ?.E1C.E
- SET XMSUBJ=$$CTRL^XMXUTIL1(XMSUBJ)
- +3 IF $EXTRACT(XMSUBJ,1)=" "!($EXTRACT(XMSUBJ,$LENGTH(XMSUBJ))=" ")
- SET XMSUBJ=$$STRIP^XMXUTIL1(XMSUBJ)
- +4 IF XMSUBJ[" "
- SET XMSUBJ=$$MAXBLANK^XMXUTIL1(XMSUBJ)
- +5 ;* No Subject *
- IF $GET(XMSUBJ)=""
- QUIT $$EZBLD^DIALOG(34012)
- +6 IF $LENGTH(XMSUBJ)+(2*($LENGTH(XMSUBJ,U)-1))>65!($LENGTH(XMSUBJ)<3)
- Begin DoDot:1
- +7 ;Subject must be from 3 to 65 characters long.
- DO ERRSET^XMXUTIL(39403)
- End DoDot:1
- QUIT XMSUBJ
- +8 IF XMSUBJ?1"R".N
- Begin DoDot:1
- +9 ;Subject 'Rnnn' reserved.
- DO ERRSET^XMXUTIL(39404)
- End DoDot:1
- QUIT XMSUBJ
- +10 ;D CHK^DIE(3.9,.01,"H",XMSUBJ)
- +11 QUIT XMSUBJ
- XMINSTR(XMINSTR) ; Validate special instructions
- +1 if $DATA(XMINSTR("RCPT BSKT"))
- SET XMINSTR("RCPT BSKT")=$$XMKN^XMXPARMB(XMDUZ,"XMINSTR(""RCPT BSKT"")",XMINSTR("RCPT BSKT"),1)
- +2 if $DATA(XMINSTR("SELF BSKT"))
- SET XMINSTR("SELF BSKT")=$$XMK(XMDUZ,"XMINSTR(""SELF BSKT"")",XMINSTR("SELF BSKT"),1)
- +3 IF $DATA(XMINSTR("SHARE DATE"))
- SET XMINSTR("SHARE DATE")=$$XMDATE("XMINSTR(""SHARE DATE"")",XMINSTR("SHARE DATE"))
- +4 if $DATA(XMINSTR("SHARE BSKT"))
- SET XMINSTR("SHARE BSKT")=$$XMK(.6,"XMINSTR(""SHARE BSKT"")",XMINSTR("SHARE BSKT"),1)
- +5 IF $DATA(XMINSTR("VAPOR"))
- SET XMINSTR("VAPOR")=$$XMDATE("XMINSTR(""VAPOR"")",XMINSTR("VAPOR"))
- +6 IF $DATA(XMINSTR("LATER"))
- SET XMINSTR("LATER")=$$XMDATE("XMINSTR(""LATER"")",XMINSTR("LATER"))
- +7 IF $DATA(XMINSTR("FROM"))
- SET XMINSTR("FROM")=$$XMFROM("XMINSTR(""FROM"")",XMINSTR("FROM"))
- +8 IF $DATA(XMINSTR("FWD BY"))
- SET XMINSTR("FWD BY")=$$XMFROM("XMINSTR(""FWD BY"")",XMINSTR("FWD BY"))
- +9 if $DATA(XMINSTR("FLAGS"))
- DO XMFLAG("XMINSTR(""FLAGS"")",XMINSTR("FLAGS"),"CIPRSX")
- +10 IF $DATA(XMINSTR("SCR KEY"))!$DATA(XMINSTR("SCR HINT"))
- Begin DoDot:1
- +11 DO XMKEY^XMXPARM1($GET(XMINSTR("SCR KEY")))
- +12 DO XMHINT^XMXPARM1($GET(XMINSTR("SCR HINT")))
- End DoDot:1
- +13 if $DATA(XMINSTR("TYPE"))
- DO XMTYPE(XMINSTR("TYPE"))
- +14 if $DATA(XMINSTR("STRIP"))
- DO XMSTRIP^XMXPARM1(XMINSTR("STRIP"))
- +15 QUIT
- XMDATE(XMPARM,XMDATE) ;
- +1 NEW %DT,Y,X
- +2 SET X=XMDATE
- +3 SET %DT="FT"
- SET %DT(0)="NOW"
- +4 DO ^%DT
- +5 if Y>0
- QUIT Y
- +6 NEW XMP
- +7 SET XMP("PARAM","ID")=XMPARM
- +8 SET XMP("PARAM","VALUE")=XMDATE
- +9 ;Must be a date in the future.
- DO ERRSET^XMXUTIL(39409,.XMP)
- +10 QUIT XMDATE
- XMFROM(XMPARM,XMFROM) ;
- +1 ;Code below is preventing valid new person file entries from Processing
- +2 ;N XMHOLD
- +3 if XMFROM=.5
- QUIT XMFROM
- +4 IF +XMFROM=XMFROM!(XMFROM[U)!($LENGTH(XMFROM)>65)!(XMFROM="")
- Begin DoDot:1
- +5 NEW XMP
- SET XMP("PARAM","ID")=XMPARM
- SET XMP("PARAM","VALUE")=XMFROM
- +6 ;S XMP("PARAM","FILE")=X,XMP("PARAM","FIELD")=Y
- +7 ;Must be from 1 to 65 characters, no # or ^.
- +8 DO ERRSET^XMXUTIL(39410,.XMP)
- End DoDot:1
- QUIT XMFROM
- +9 ;S XMHOLD=XMFROM
- +10 ;S XMFROM=$$CTRL^XMXUTIL1(XMFROM)
- +11 ;S XMFROM=$$STRIP^XMXUTIL1(XMFROM)
- +12 ;S XMFROM=$$MAXBLANK^XMXUTIL1(XMFROM)
- +13 ;Q:XMFROM["POSTMASTER" XMFROM
- +14 ; "B^BB^C^D" = name^alias^initial^nickname
- +15 ;I '$$FIND1^DIC(200,"","O",$$UP^XLFSTR(XMFROM),"B^BB^C^D")!$D(DIERR) D Q XMHOLD
- +16 ;. N XMP S XMP("PARAM","ID")=XMPARM,XMP("PARAM","VALUE")=XMHOLD
- +17 ;. ;S XMP("PARAM","FILE")=X,XMP("PARAM","FIELD")=Y
- +18 ;. D ERRSET^XMXUTIL(39411,.XMP) ;May not be a real person.
- +19 QUIT XMFROM
- XMTYPE(XMTYPE) ; Validate a message type
- +1 IF $LENGTH(XMTYPE)'=1
- Begin DoDot:1
- +2 NEW XMP
- SET XMP("PARAM","ID")="XMINSTR(""TYPE"")"
- SET XMP("PARAM","VALUE")=XMTYPE
- +3 ;S XMPARM("PARAM","FILE")=3.9,XMPARM("PARAM","FIELD")=1.7
- +4 ;Must be 1 character.
- DO ERRSET^XMXUTIL(39412,.XMP)
- End DoDot:1
- QUIT
- +5 DO XMFLAG("XMINSTR(""TYPE"")",XMTYPE,"BDKOSX")
- +6 QUIT
- XMFLAG(XMPARM,XMFLAG,FLAGSET) ;
- +1 NEW XMLEFT
- +2 SET XMLEFT=$TRANSLATE(XMFLAG,FLAGSET,"")
- +3 if XMLEFT=""
- QUIT
- +4 NEW XMP
- SET XMP("PARAM","ID")=XMPARM
- SET XMP("PARAM","VALUE")=XMFLAG
- SET XMP(1)=XMLEFT
- +5 ;|1| is not valid.
- DO ERRSET^XMXUTIL(39413,.XMP)
- +6 QUIT
- XMKTO(XMDUZ,XMKTO) ;
- +1 IF $GET(XMKTO)=""
- Begin DoDot:1
- +2 NEW XMP
- SET XMP("PARAM","ID")="XMKTO"
- SET XMP("PARAM","VALUE")=""
- +3 ;Destination basket must be supplied.
- DO ERRSET^XMXUTIL(39416,.XMP)
- End DoDot:1
- QUIT
- +4 SET XMKTO=$$XMK(XMDUZ,"XMKTO",XMKTO)
- +5 QUIT
- XMK(XMDUZ,XMPARM,XMK,XMOPTNL) ;
- +1 IF +XMK=XMK
- IF $DATA(^XMB(3.7,XMDUZ,2,XMK))
- QUIT XMK
- +2 ; Just in case a name was passed...
- +3 NEW XMKN
- +4 SET XMKN=XMK
- +5 SET XMK=$$FIND1^DIC(3.701,","_XMDUZ_",","OQ",XMKN)
- +6 if XMK
- QUIT XMK
- +7 ; Basket not found. Will create on delivery.
- IF '$DATA(DIERR)
- IF $GET(XMOPTNL)
- QUIT XMKN
- +8 NEW XMP
- SET XMP("PARAM","ID")=XMPARM
- SET XMP("PARAM","VALUE")=XMKN
- SET XMP(1)=XMKN
- +9 ;Basket name '|1|' ambiguous / not found.
- +10 DO ERRSET^XMXUTIL($SELECT($DATA(DIERR):39414,1:39415),.XMP)
- +11 QUIT XMKN
- XMZ(XMZ) ;
- +1 IF $GET(XMZ)
- IF $DATA(^XMB(3.9,XMZ,0))
- QUIT
- +2 ;Message '|1|' does not exist.
- DO ERRSET^XMXUTIL(34353,XMZ)
- +3 QUIT