- XMTDL2 ;ISC-SF/GMB-Deliver local mail to mailbox (cont.) ;04/17/2002 11:31
- ;;8.0;MailMan;;Jun 28, 2002
- ; Replaces ^XMADJF1B (ISC-WASH/CAP)
- ; XMTO Recipient DUZ
- ; XMZ Original XMZ
- ; XMZSUBJ Msg subject
- ; XMZFROM Who sent the original message
- ; XMFROM Who sent the msg or reply, or who forwarded the msg
- ; XMREPLY 0=msg is not a reply; 1=msg is a reply
- ; XMK Basket number (or name) to deliver to (as specified by sender XMFROM)
- ; XMDEL Delete Date (as specified by sender XMZFROM)
- ; XMKCURR Basket the msg is currently in
- DELIVER(XMTO,XMZ,XMZSUBJ,XMZFROM,XMFROM,XMREPLY,XMK,XMDEL,XMZBSKT) ;
- N XMKCURR,XMACT
- I +XMTO'>0!'$D(^XMB(3.7,XMTO,2)) Q ; Do not deliver if invalid mailbox
- S XMFROM=+$G(XMFROM),XMREPLY=+$G(XMREPLY),XMK=$G(XMK),XMDEL=+$G(XMDEL),XMZBSKT=$G(XMZBSKT)
- I XMTO=.6,XMREPLY Q ; Do not deliver response to Shared,Mail
- S XMKCURR=$O(^XMB(3.7,"M",XMZ,XMTO,0)) ; Get basket it is in
- I XMKCURR D Q ; Already in a basket (ignore any basket sender may have specified)
- . Q:'XMREPLY ; If this is a reply, continue, else it must be a forwarded msg, so quit.
- . I XMKCURR=.5 D Q ; Msg is in waste basket
- . . D CHEKBSKT(XMTO,.XMK,XMZSUBJ,XMZFROM,XMZBSKT,.XMACT) ; Where should it go?
- . . Q:XMK=.5
- . . D MOVENEW(XMFROM,XMTO,XMK,XMZ,.XMACT) ; Move msg and make it new.
- . ; Msg is not in waste basket. Make the msg new.
- . Q:$D(^XMB(3.7,XMTO,"N0",XMKCURR,XMZ)) ; Already new.
- . D:XMFROM'=XMTO MAKENEW(XMTO,XMKCURR,XMZ)
- ; Not yet in a basket.
- ; Reinstated user may not see replies to old msgs which he doesn't already have.
- I XMREPLY,$P(^XMB(3.7,XMTO,0),U,7) Q:$$SECRET($P(^(0),U,7),XMZ)
- S:$G(XMK)="" XMK=0
- I +XMK=XMK D
- . D CHEKBSKT(XMTO,.XMK,XMZSUBJ,XMZFROM,XMZBSKT,.XMACT)
- E D
- . S XMK=$$NAMEBSKT(XMTO,XMK,"Y")
- D ADDNEW($S(XMREPLY:XMFROM,1:XMZFROM),XMTO,XMK,XMZ,XMDEL,.XMACT,XMREPLY)
- Q
- CHEKBSKT(XMTO,XMK,XMZSUBJ,XMZFROM,XMZBSKT,XMACT) ; Basket number (or no basket at all)
- N XMREC
- S XMREC=$G(^XMB(3.7,XMTO,16))
- ; If the message hasn't been sent to a specific basket for this user
- ; and the sender specified a delivery basket, and the recipient is
- ; OK with that, then use the delivery basket.
- ; Note: The IN basket is not considered a 'specific basket'.
- I XMK<2,XMZBSKT'="","^^N^"'[(U_$P(XMREC,U,2)_U) S XMK=$$NAMEBSKT(XMTO,XMZBSKT,$P(XMREC,U,2)) Q:XMK
- ; If the message hasn't been sent to a specific basket for this user
- ; and active filters exist, and filtering is turned on,
- ; then filter the message.
- I XMK<2,$D(^XMB(3.7,XMTO,15,"AF")),$P(XMREC,U,1)="Y" D FILTER^XMTDF(XMTO,XMZ,XMZSUBJ,XMZFROM,.XMK,"",.XMACT) Q
- ; The message was sent to a specific basket for this user.
- I XMK Q:$D(^XMB(3.7,XMTO,2,XMK,0)) ; Quit if the basket XMK exists.
- S XMK=1 ; Since the basket doesn't exist, force to the IN basket
- Q:$D(^XMB(3.7,XMTO,2,XMK,0)) ; Quit if the IN basket exists.
- D MAKEBSKT^XMXBSKT(XMTO,XMK,$$EZBLD^DIALOG(37005)) ; Create the "IN" basket
- Q
- NAMEBSKT(XMTO,XMKN,XMZBOK) ; Basket name (not number)
- N XMK
- S XMK=$O(^XMB(3.7,XMTO,2,"B",XMKN,0))
- S:'XMK XMK=$$FIND1^DIC(3.701,","_XMTO_",","X",$$LOW^XLFSTR(XMKN))
- I XMK D Q XMK
- . Q:XMZBOK'="S" ; 'YES' or 'EXISTING ONLY'
- . S:$P(^XMB(3.7,XMTO,2,XMK,0),U,3)'="Y" XMK=0 ; 'SELECTED ONLY'
- ; Basket not found
- Q:XMZBOK'="Y" 0 ; quit if not 'YES'
- I XMKN=$$EZBLD^DIALOG(37004) S XMK=.5 D MAKEBSKT^XMXBSKT(XMTO,XMK,XMKN) Q XMK ; "WASTE"
- I XMKN=$$EZBLD^DIALOG(37005) S XMK=1 D MAKEBSKT^XMXBSKT(XMTO,XMK,XMKN) Q XMK ; "IN"
- D MAKEBSKT^XMXBSKT(XMTO,.XMK,XMKN)
- Q XMK
- ADDNEW(XMFROM,XMTO,XMK,XMZ,XMDEL,XMACT,XMREPLY) ;
- N XMFDA,XMIENS,XMIEN,XMTRIES
- S XMIENS="+1,"_XMK_","_XMTO_","
- S XMIEN(1)=XMZ
- S XMFDA(3.702,XMIENS,.01)=XMZ
- I XMK'=.5 D
- . I XMFROM'=XMTO D
- . . I $G(XMACT("NONEW")),'$$RESP^XMXUTIL2(XMZ),$$ZREAD^XMXUTIL2(XMTO,XMZ)="" Q
- . . S XMFDA(3.702,XMIENS,3)=1 ; new flag
- . . D INCRNEW^XMXUTIL(XMTO,XMK) ; New counts
- . I $G(XMACT("VDAYS")) D Q
- . . S XMFDA(3.702,XMIENS,5)=$$FMADD^XLFDT(DT,XMACT("VDAYS")) ; vapor date
- . . S XMFDA(3.702,XMIENS,7)=0 ; vapor date set by user
- . I XMDEL S XMFDA(3.702,XMIENS,5)=XMDEL ; vapor date
- ; Basket sequence number (XMKZ), and priority & new xrefs are handled by FM triggers.
- ATRY D UPDATE^DIE("S","XMFDA","XMIEN")
- I '$D(DIERR) D Q
- . Q:'$D(XMACT("FWD"))
- . I 'XMREPLY,XMFROM'=XMTO D FORWARD(XMTO,XMZ,XMACT("FWD"))
- S XMTRIES=$G(XMTRIES)+1
- I $D(^TMP("DIERR",$J,"E",110)) H 1 G ATRY ; Try again if can't lock
- Q
- MAKENEW(XMTO,XMK,XMZ) ;
- ; We ignore any "vapor" date here because this is an existing msg
- N XMFDA,XMREC
- S XMREC=$G(^XMB(3.7,XMTO,2,XMK,1,XMZ,0))
- I XMREC="" D Q:XMREC=""
- . ; Message entry should have been there, but it wasn't. Add it.
- . D FIXBSKT(XMTO,XMK,XMZ)
- . S XMREC=$G(^XMB(3.7,XMTO,2,XMK,1,XMZ,0)) Q:XMREC'=""
- . D ADDNEW(0,XMTO,XMK,XMZ,0)
- S XMFDA(3.702,XMZ_","_XMK_","_XMTO_",",3)=1 ; new flag
- ; Delete 'automatic delete date' if it was set by the system
- ; (during IN BASKET PURGE).
- S:$P(XMREC,U,7) XMFDA(3.702,XMZ_","_XMK_","_XMTO_",",5)="@"
- L +^XMB(3.7,XMTO,2,XMK,1,XMZ,0):1 ; Lock message
- ; Priority & new xrefs are handled by FM triggers.
- D FILE^DIE("","XMFDA")
- L -^XMB(3.7,XMTO,2,XMK,1,XMZ,0)
- D INCRNEW^XMXUTIL(XMTO,XMK) ; New counts
- Q
- SECRET(XMDATE,XMZ) ;
- ; Don't need to check to see if the user already has the msg, because
- ; at this point, we already know that he doesn't.
- N XMCRE8
- S XMCRE8=$P($G(^XMB(3.9,XMZ,.6)),U)
- Q $S('XMCRE8:0,XMDATE>XMCRE8:1,1:0) ; 1 means user may NOT see the msg.
- MOVENEW(XMFROM,XMTO,XMK,XMZ,XMACT) ; Move msg from WASTE bskt and make new
- N XMFDA,XMREC,XMIENS,XMIEN,XMTRIES
- S XMREC=$G(^XMB(3.7,XMTO,2,.5,1,XMZ,0))
- I XMREC="" D Q:XMREC=""
- . ; Message entry should have been there, but it wasn't.
- . D FIXBSKT(XMTO,.5,XMZ)
- . S XMREC=$G(^XMB(3.7,XMTO,2,.5,1,XMZ,0)) Q:XMREC'=""
- . D ADDNEW(XMFROM,XMTO,XMK,XMZ,0)
- S XMIENS="+1,"_XMK_","_XMTO_","
- S XMIEN(1)=XMZ
- S XMFDA(3.702,XMIENS,.01)=XMZ
- S:XMFROM'=XMTO XMFDA(3.702,XMIENS,3)=1 ; new flag
- S:$P(XMREC,U,4) XMFDA(3.702,XMIENS,4)=$P(XMREC,U,4) ; date last accessed
- ;I '$P(XMREC,U,7),$P(XMREC,U,5)>DT S XMFDA(3.702,XMIENS,5)=$P(XMREC,U,5) ; vapor date set by user, not system
- I $G(XMACT("VDAYS")) D
- . S XMFDA(3.702,XMIENS,5)=$$FMADD^XLFDT(DT,XMACT("VDAYS")) ; vapor date
- . S XMFDA(3.702,XMIENS,7)=0 ; vapor date set by user
- MTRY D UPDATE^DIE("S","XMFDA","XMIEN")
- I '$D(DIERR) D Q
- . D:XMFROM'=XMTO INCRNEW^XMXUTIL(XMTO,XMK) ; Increment new counts
- . N DA,DIK
- . S DA(2)=XMTO,DA(1)=.5,DA=XMZ
- . S DIK="^XMB(3.7,"_XMTO_",2,.5,1,"
- . D ^DIK ; delete msg from waste bskt
- S XMTRIES=$G(XMTRIES)+1
- I $D(^TMP("DIERR",$J,"E",110)) H 1 G MTRY ; Try again if can't lock
- Q
- FIXBSKT(XMTO,XMK,XMZ) ; Basket integrity check
- N XMERROR ; (set in ^XMUT4)
- L +^XMB(3.7,XMTO,2,XMK):1
- K ^XMB(3.7,"M",XMZ,XMTO,XMK) ; This xref is wrong.
- D BSKT^XMUT4(XMTO,XMK)
- L -^XMB(3.7,XMTO,2,XMK)
- Q
- FORWARD(XMTO,XMZ,XMFIEN) ;
- ; XMFIEN IEN of the filter which activated.
- N XMUPTR
- S XMUPTR=+$O(^XMB(3.9,XMZ,1,"C",XMTO,0))
- Q:$P($G(^XMB(3.9,XMZ,1,XMUPTR,0)),U,13)'="" ; already forwarded once.
- N XMFDA
- S XMFDA(3.91,XMUPTR_","_XMZ_",",15)=XMFIEN
- D FILE^DIE("","XMFDA")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMTDL2 7241 printed Feb 18, 2025@23:39:30 Page 2
- XMTDL2 ;ISC-SF/GMB-Deliver local mail to mailbox (cont.) ;04/17/2002 11:31
- +1 ;;8.0;MailMan;;Jun 28, 2002
- +2 ; Replaces ^XMADJF1B (ISC-WASH/CAP)
- +3 ; XMTO Recipient DUZ
- +4 ; XMZ Original XMZ
- +5 ; XMZSUBJ Msg subject
- +6 ; XMZFROM Who sent the original message
- +7 ; XMFROM Who sent the msg or reply, or who forwarded the msg
- +8 ; XMREPLY 0=msg is not a reply; 1=msg is a reply
- +9 ; XMK Basket number (or name) to deliver to (as specified by sender XMFROM)
- +10 ; XMDEL Delete Date (as specified by sender XMZFROM)
- +11 ; XMKCURR Basket the msg is currently in
- DELIVER(XMTO,XMZ,XMZSUBJ,XMZFROM,XMFROM,XMREPLY,XMK,XMDEL,XMZBSKT) ;
- +1 NEW XMKCURR,XMACT
- +2 ; Do not deliver if invalid mailbox
- IF +XMTO'>0!'$DATA(^XMB(3.7,XMTO,2))
- QUIT
- +3 SET XMFROM=+$GET(XMFROM)
- SET XMREPLY=+$GET(XMREPLY)
- SET XMK=$GET(XMK)
- SET XMDEL=+$GET(XMDEL)
- SET XMZBSKT=$GET(XMZBSKT)
- +4 ; Do not deliver response to Shared,Mail
- IF XMTO=.6
- IF XMREPLY
- QUIT
- +5 ; Get basket it is in
- SET XMKCURR=$ORDER(^XMB(3.7,"M",XMZ,XMTO,0))
- +6 ; Already in a basket (ignore any basket sender may have specified)
- IF XMKCURR
- Begin DoDot:1
- +7 ; If this is a reply, continue, else it must be a forwarded msg, so quit.
- if 'XMREPLY
- QUIT
- +8 ; Msg is in waste basket
- IF XMKCURR=.5
- Begin DoDot:2
- +9 ; Where should it go?
- DO CHEKBSKT(XMTO,.XMK,XMZSUBJ,XMZFROM,XMZBSKT,.XMACT)
- +10 if XMK=.5
- QUIT
- +11 ; Move msg and make it new.
- DO MOVENEW(XMFROM,XMTO,XMK,XMZ,.XMACT)
- End DoDot:2
- QUIT
- +12 ; Msg is not in waste basket. Make the msg new.
- +13 ; Already new.
- if $DATA(^XMB(3.7,XMTO,"N0",XMKCURR,XMZ))
- QUIT
- +14 if XMFROM'=XMTO
- DO MAKENEW(XMTO,XMKCURR,XMZ)
- End DoDot:1
- QUIT
- +15 ; Not yet in a basket.
- +16 ; Reinstated user may not see replies to old msgs which he doesn't already have.
- +17 IF XMREPLY
- IF $PIECE(^XMB(3.7,XMTO,0),U,7)
- if $$SECRET($PIECE(^(0),U,7),XMZ)
- QUIT
- +18 if $GET(XMK)=""
- SET XMK=0
- +19 IF +XMK=XMK
- Begin DoDot:1
- +20 DO CHEKBSKT(XMTO,.XMK,XMZSUBJ,XMZFROM,XMZBSKT,.XMACT)
- End DoDot:1
- +21 IF '$TEST
- Begin DoDot:1
- +22 SET XMK=$$NAMEBSKT(XMTO,XMK,"Y")
- End DoDot:1
- +23 DO ADDNEW($SELECT(XMREPLY:XMFROM,1:XMZFROM),XMTO,XMK,XMZ,XMDEL,.XMACT,XMREPLY)
- +24 QUIT
- CHEKBSKT(XMTO,XMK,XMZSUBJ,XMZFROM,XMZBSKT,XMACT) ; Basket number (or no basket at all)
- +1 NEW XMREC
- +2 SET XMREC=$GET(^XMB(3.7,XMTO,16))
- +3 ; If the message hasn't been sent to a specific basket for this user
- +4 ; and the sender specified a delivery basket, and the recipient is
- +5 ; OK with that, then use the delivery basket.
- +6 ; Note: The IN basket is not considered a 'specific basket'.
- +7 IF XMK<2
- IF XMZBSKT'=""
- IF "^^N^"'[(U_$PIECE(XMREC,U,2)_U)
- SET XMK=$$NAMEBSKT(XMTO,XMZBSKT,$PIECE(XMREC,U,2))
- if XMK
- QUIT
- +8 ; If the message hasn't been sent to a specific basket for this user
- +9 ; and active filters exist, and filtering is turned on,
- +10 ; then filter the message.
- +11 IF XMK<2
- IF $DATA(^XMB(3.7,XMTO,15,"AF"))
- IF $PIECE(XMREC,U,1)="Y"
- DO FILTER^XMTDF(XMTO,XMZ,XMZSUBJ,XMZFROM,.XMK,"",.XMACT)
- QUIT
- +12 ; The message was sent to a specific basket for this user.
- +13 ; Quit if the basket XMK exists.
- IF XMK
- if $DATA(^XMB(3.7,XMTO,2,XMK,0))
- QUIT
- +14 ; Since the basket doesn't exist, force to the IN basket
- SET XMK=1
- +15 ; Quit if the IN basket exists.
- if $DATA(^XMB(3.7,XMTO,2,XMK,0))
- QUIT
- +16 ; Create the "IN" basket
- DO MAKEBSKT^XMXBSKT(XMTO,XMK,$$EZBLD^DIALOG(37005))
- +17 QUIT
- NAMEBSKT(XMTO,XMKN,XMZBOK) ; Basket name (not number)
- +1 NEW XMK
- +2 SET XMK=$ORDER(^XMB(3.7,XMTO,2,"B",XMKN,0))
- +3 if 'XMK
- SET XMK=$$FIND1^DIC(3.701,","_XMTO_",","X",$$LOW^XLFSTR(XMKN))
- +4 IF XMK
- Begin DoDot:1
- +5 ; 'YES' or 'EXISTING ONLY'
- if XMZBOK'="S"
- QUIT
- +6 ; 'SELECTED ONLY'
- if $PIECE(^XMB(3.7,XMTO,2,XMK,0),U,3)'="Y"
- SET XMK=0
- End DoDot:1
- QUIT XMK
- +7 ; Basket not found
- +8 ; quit if not 'YES'
- if XMZBOK'="Y"
- QUIT 0
- +9 ; "WASTE"
- IF XMKN=$$EZBLD^DIALOG(37004)
- SET XMK=.5
- DO MAKEBSKT^XMXBSKT(XMTO,XMK,XMKN)
- QUIT XMK
- +10 ; "IN"
- IF XMKN=$$EZBLD^DIALOG(37005)
- SET XMK=1
- DO MAKEBSKT^XMXBSKT(XMTO,XMK,XMKN)
- QUIT XMK
- +11 DO MAKEBSKT^XMXBSKT(XMTO,.XMK,XMKN)
- +12 QUIT XMK
- ADDNEW(XMFROM,XMTO,XMK,XMZ,XMDEL,XMACT,XMREPLY) ;
- +1 NEW XMFDA,XMIENS,XMIEN,XMTRIES
- +2 SET XMIENS="+1,"_XMK_","_XMTO_","
- +3 SET XMIEN(1)=XMZ
- +4 SET XMFDA(3.702,XMIENS,.01)=XMZ
- +5 IF XMK'=.5
- Begin DoDot:1
- +6 IF XMFROM'=XMTO
- Begin DoDot:2
- +7 IF $GET(XMACT("NONEW"))
- IF '$$RESP^XMXUTIL2(XMZ)
- IF $$ZREAD^XMXUTIL2(XMTO,XMZ)=""
- QUIT
- +8 ; new flag
- SET XMFDA(3.702,XMIENS,3)=1
- +9 ; New counts
- DO INCRNEW^XMXUTIL(XMTO,XMK)
- End DoDot:2
- +10 IF $GET(XMACT("VDAYS"))
- Begin DoDot:2
- +11 ; vapor date
- SET XMFDA(3.702,XMIENS,5)=$$FMADD^XLFDT(DT,XMACT("VDAYS"))
- +12 ; vapor date set by user
- SET XMFDA(3.702,XMIENS,7)=0
- End DoDot:2
- QUIT
- +13 ; vapor date
- IF XMDEL
- SET XMFDA(3.702,XMIENS,5)=XMDEL
- End DoDot:1
- +14 ; Basket sequence number (XMKZ), and priority & new xrefs are handled by FM triggers.
- ATRY DO UPDATE^DIE("S","XMFDA","XMIEN")
- +1 IF '$DATA(DIERR)
- Begin DoDot:1
- +2 if '$DATA(XMACT("FWD"))
- QUIT
- +3 IF 'XMREPLY
- IF XMFROM'=XMTO
- DO FORWARD(XMTO,XMZ,XMACT("FWD"))
- End DoDot:1
- QUIT
- +4 SET XMTRIES=$GET(XMTRIES)+1
- +5 ; Try again if can't lock
- IF $DATA(^TMP("DIERR",$JOB,"E",110))
- HANG 1
- GOTO ATRY
- +6 QUIT
- MAKENEW(XMTO,XMK,XMZ) ;
- +1 ; We ignore any "vapor" date here because this is an existing msg
- +2 NEW XMFDA,XMREC
- +3 SET XMREC=$GET(^XMB(3.7,XMTO,2,XMK,1,XMZ,0))
- +4 IF XMREC=""
- Begin DoDot:1
- +5 ; Message entry should have been there, but it wasn't. Add it.
- +6 DO FIXBSKT(XMTO,XMK,XMZ)
- +7 SET XMREC=$GET(^XMB(3.7,XMTO,2,XMK,1,XMZ,0))
- if XMREC'=""
- QUIT
- +8 DO ADDNEW(0,XMTO,XMK,XMZ,0)
- End DoDot:1
- if XMREC=""
- QUIT
- +9 ; new flag
- SET XMFDA(3.702,XMZ_","_XMK_","_XMTO_",",3)=1
- +10 ; Delete 'automatic delete date' if it was set by the system
- +11 ; (during IN BASKET PURGE).
- +12 if $PIECE(XMREC,U,7)
- SET XMFDA(3.702,XMZ_","_XMK_","_XMTO_",",5)="@"
- +13 ; Lock message
- LOCK +^XMB(3.7,XMTO,2,XMK,1,XMZ,0):1
- +14 ; Priority & new xrefs are handled by FM triggers.
- +15 DO FILE^DIE("","XMFDA")
- +16 LOCK -^XMB(3.7,XMTO,2,XMK,1,XMZ,0)
- +17 ; New counts
- DO INCRNEW^XMXUTIL(XMTO,XMK)
- +18 QUIT
- SECRET(XMDATE,XMZ) ;
- +1 ; Don't need to check to see if the user already has the msg, because
- +2 ; at this point, we already know that he doesn't.
- +3 NEW XMCRE8
- +4 SET XMCRE8=$PIECE($GET(^XMB(3.9,XMZ,.6)),U)
- +5 ; 1 means user may NOT see the msg.
- QUIT $SELECT('XMCRE8:0,XMDATE>XMCRE8:1,1:0)
- MOVENEW(XMFROM,XMTO,XMK,XMZ,XMACT) ; Move msg from WASTE bskt and make new
- +1 NEW XMFDA,XMREC,XMIENS,XMIEN,XMTRIES
- +2 SET XMREC=$GET(^XMB(3.7,XMTO,2,.5,1,XMZ,0))
- +3 IF XMREC=""
- Begin DoDot:1
- +4 ; Message entry should have been there, but it wasn't.
- +5 DO FIXBSKT(XMTO,.5,XMZ)
- +6 SET XMREC=$GET(^XMB(3.7,XMTO,2,.5,1,XMZ,0))
- if XMREC'=""
- QUIT
- +7 DO ADDNEW(XMFROM,XMTO,XMK,XMZ,0)
- End DoDot:1
- if XMREC=""
- QUIT
- +8 SET XMIENS="+1,"_XMK_","_XMTO_","
- +9 SET XMIEN(1)=XMZ
- +10 SET XMFDA(3.702,XMIENS,.01)=XMZ
- +11 ; new flag
- if XMFROM'=XMTO
- SET XMFDA(3.702,XMIENS,3)=1
- +12 ; date last accessed
- if $PIECE(XMREC,U,4)
- SET XMFDA(3.702,XMIENS,4)=$PIECE(XMREC,U,4)
- +13 ;I '$P(XMREC,U,7),$P(XMREC,U,5)>DT S XMFDA(3.702,XMIENS,5)=$P(XMREC,U,5) ; vapor date set by user, not system
- +14 IF $GET(XMACT("VDAYS"))
- Begin DoDot:1
- +15 ; vapor date
- SET XMFDA(3.702,XMIENS,5)=$$FMADD^XLFDT(DT,XMACT("VDAYS"))
- +16 ; vapor date set by user
- SET XMFDA(3.702,XMIENS,7)=0
- End DoDot:1
- MTRY DO UPDATE^DIE("S","XMFDA","XMIEN")
- +1 IF '$DATA(DIERR)
- Begin DoDot:1
- +2 ; Increment new counts
- if XMFROM'=XMTO
- DO INCRNEW^XMXUTIL(XMTO,XMK)
- +3 NEW DA,DIK
- +4 SET DA(2)=XMTO
- SET DA(1)=.5
- SET DA=XMZ
- +5 SET DIK="^XMB(3.7,"_XMTO_",2,.5,1,"
- +6 ; delete msg from waste bskt
- DO ^DIK
- End DoDot:1
- QUIT
- +7 SET XMTRIES=$GET(XMTRIES)+1
- +8 ; Try again if can't lock
- IF $DATA(^TMP("DIERR",$JOB,"E",110))
- HANG 1
- GOTO MTRY
- +9 QUIT
- FIXBSKT(XMTO,XMK,XMZ) ; Basket integrity check
- +1 ; (set in ^XMUT4)
- NEW XMERROR
- +2 LOCK +^XMB(3.7,XMTO,2,XMK):1
- +3 ; This xref is wrong.
- KILL ^XMB(3.7,"M",XMZ,XMTO,XMK)
- +4 DO BSKT^XMUT4(XMTO,XMK)
- +5 LOCK -^XMB(3.7,XMTO,2,XMK)
- +6 QUIT
- FORWARD(XMTO,XMZ,XMFIEN) ;
- +1 ; XMFIEN IEN of the filter which activated.
- +2 NEW XMUPTR
- +3 SET XMUPTR=+$ORDER(^XMB(3.9,XMZ,1,"C",XMTO,0))
- +4 ; already forwarded once.
- if $PIECE($GET(^XMB(3.9,XMZ,1,XMUPTR,0)),U,13)'=""
- QUIT
- +5 NEW XMFDA
- +6 SET XMFDA(3.91,XMUPTR_","_XMZ_",",15)=XMFIEN
- +7 DO FILE^DIE("","XMFDA")
- +8 QUIT