- XMXBSKT ;ISC-SF/GMB-Basket APIs ;03/25/2003 14:55
- ;;8.0;MailMan;**16**;Jun 28, 2002
- CRE8BSKT(XMDUZ,XMKN,XMK) ; Routine creates basket, given name, and
- ; returns basket number.
- K XMERR,^TMP("XMERR",$J)
- I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- S XMK=$$FIND1^DIC(3.701,","_XMDUZ_",","X",XMKN)
- I XMK D Q
- .; (It might be better if used an index which was the upper case of
- .; the basket name, and if we checked for upper case of XMKN)
- . D ERRSET^XMXUTIL(37201.3,XMKN) ; Basket '_XMKN_' already exists.
- I XMDUZ=.5 D Q:$G(XMERR)
- . N I,XMK
- . S XMK=.99
- . F I=1:1 S XMK=$O(^XMB(3.7,.5,2,XMK)) Q:XMK>999!'XMK
- . Q:I<999
- . D ERRSET^XMXUTIL(38113.1) ; Postmaster may not have more than 999 baskets. (>999=Network msg queues)
- ;D VAL^DIE(3.701,"1,"_XMDUZ_",",.01,"H",XMKN) ; validate the name
- D MAKEBSKT(XMDUZ,.XMK,XMKN)
- Q
- MAKEBSKT(XMDUZ,XMK,XMKN) ; Create a basket (For internal MM use only)
- ; If you give it an XMK, it'll put it there,
- ; else, it'll find a vacant XMK.
- N XMFDA,XMIEN,XMTRIES
- I 'XMK F XMK=2:1 Q:'$D(^XMB(3.7,XMDUZ,2,XMK)) ; Find 1st vacant bskt #
- S XMFDA(3.701,"+1,"_XMDUZ_",",.01)=XMKN
- S XMIEN(1)=XMK
- MTRY D UPDATE^DIE("S","XMFDA","XMIEN") Q:'$D(DIERR)
- S XMTRIES=$G(XMTRIES)+1
- I $D(^TMP("DIERR",$J,"E",110)) H 1 G MTRY ; Try again if can't lock
- Q
- DELBSKT(XMDUZ,XMK,XMFLAGS) ;
- ; XMK Basket IEN
- N XMNEW
- K XMERR,^TMP("XMERR",$J)
- I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- I XMK'>1 D Q
- . D ERRSET^XMXUTIL(37215.2,$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)) ; The '_IN/WASTE_' basket may not be deleted.
- I $G(XMFLAGS)'["D",$$BMSGCT^XMXUTIL(XMDUZ,XMK)>0 D Q
- . D ERRSET^XMXUTIL(37215.4,$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)) ; The '_x_' basket may not be deleted, because it still has messages in it.
- S XMNEW=$$BNMSGCT^XMXUTIL(XMDUZ,XMK)
- L +^XMB(3.7,XMDUZ):1
- S:XMNEW $P(^(0),U,6)=$P(^XMB(3.7,XMDUZ,0),U,6)-XMNEW
- N XMFDA
- S XMFDA(3.701,XMK_","_XMDUZ_",",.01)="@"
- D FILE^DIE("","XMFDA")
- L -^XMB(3.7,XMDUZ)
- Q
- LISTBSKT(XMDUZ,XMFLAGS,XMAMT,XMSTART,XMPART,XMTROOT) ;
- N XMORDER,XMI,XMCNT,XMK,XMKREC,XMSCREEN,XMFMFLAG
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- I $D(XMTROOT),XMTROOT'="" D
- . K @$$CREF^DILF(XMTROOT)
- . S XMTROOT=$$OREF^DILF(XMTROOT)_"""XMLIST"","
- E D
- . K ^TMP("XMLIST",$J)
- . S XMTROOT="^TMP(""XMLIST"",$J,"
- I $G(XMFLAGS)["N" S XMSCREEN="I $P(^(0),U,2)" ; Only baskets w/new msgs
- E S XMSCREEN=""
- S XMFMFLAG="I"
- I $G(XMFLAGS)["B" S XMFMFLAG=XMFMFLAG_"B"
- D LIST^DIC(3.701,","_XMDUZ_",","",XMFMFLAG,.XMAMT,.XMSTART,.XMPART,"",XMSCREEN)
- S @(XMTROOT_"0)")=^TMP("DILIST",$J,0)
- S XMORDER=$S($G(XMFLAGS)["B":-1,1:1)
- S XMCNT=0,XMI=""
- F S XMI=$O(^TMP("DILIST",$J,2,XMI),XMORDER) Q:'XMI S XMK=^(XMI) D
- . S XMCNT=XMCNT+1
- . S XMKREC=^XMB(3.7,XMDUZ,2,XMK,0)
- . S @(XMTROOT_XMCNT_")")=XMK_U_$P(XMKREC,U,1)_U_$$BMSGCT^XMXUTIL(XMDUZ,XMK)_U_+$P(XMKREC,U,2) ; basket ien^basket name^# msgs^# new msgs
- . I '$G(XMAMT) S @(XMTROOT_"""BSKT"",$$UP^XLFSTR($P(XMKREC,U,1)),"_XMCNT_")")=""
- K ^TMP("DILIST",$J)
- Q
- NAMEBSKT(XMDUZ,XMK,XMKN) ;
- ; XMK Basket IEN
- ; XMKN New basket name
- K XMERR,^TMP("XMERR",$J)
- I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q
- I XMDUZ'=DUZ,'$$WPRIV^XMXSEC Q
- I XMK'>1!(XMDUZ=.5&(XMK>999)) D Q
- . D ERRSET^XMXUTIL(37201.2,$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)) ; The '_x_' basket name may not be changed.
- N XMFDA
- S XMFDA(3.701,XMK_","_XMDUZ_",",.01)=XMKN
- D FILE^DIE("","XMFDA")
- Q
- QBSKT(XMDUZ,XMK,XMMSG) ; Message counts for a mail basket
- N XMKREC
- K XMERR,^TMP("XMERR",$J)
- S XMMSG=""
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- S XMKREC=^XMB(3.7,XMDUZ,2,XMK,0)
- S XMMSG=XMK_U_$P(XMKREC,U,1)_U_$$BMSGCT^XMXUTIL(XMDUZ,XMK)_U_+$P(XMKREC,U,2) ; basket ien^basket name^# msgs^# new msgs
- Q
- RSEQBSKT(XMDUZ,XMK,XMMSG) ; Resequence message numbers
- ; XMZ - Unique message number
- ; XMK - basket number
- ; XMKZ - Message number in basket
- ; XMKZCNT - Number of messages in basket
- N XMKZCNT,XMERROR ; (XMERROR is set in XMUT4)
- K XMERR,^TMP("XMERR",$J)
- S XMMSG=""
- ;I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q ; Shouldn't need special privileges.
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- D BSKT^XMUT4(XMDUZ,XMK) ; Basket integrity check
- D RSEQ(XMDUZ,XMK,.XMKZCNT) ; resequence
- S XMMSG=$$EZBLD^DIALOG(37212.9,XMKZCNT) ; Resequenced from 1 to _XMKZCNT.
- Q
- RSEQ(XMDUZ,XMK,XMKZNEW) ; Internal MailMan entry point to resequence a basket
- ; *** IN create date/xmz SEQUENCE ***
- N XMKZ,XMZ,XMFDA,XMCRE8DT
- K ^TMP("XM",$J,"RSEQ")
- S XMZ=0
- F S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,XMZ)) Q:XMZ'>0 S ^TMP("XM",$J,"RSEQ",+$P($G(^XMB(3.9,XMZ,.6)),U),XMZ)=""
- S XMKZNEW=0,(XMCRE8DT,XMZ)=""
- F S XMCRE8DT=$O(^TMP("XM",$J,"RSEQ",XMCRE8DT)) Q:XMCRE8DT="" D Q:$D(XMERR)
- . F S XMZ=$O(^TMP("XM",$J,"RSEQ",XMCRE8DT,XMZ)) Q:'XMZ D Q:$D(XMERR)
- . . S XMKZ=$P($G(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,2) Q:'XMKZ
- . . S XMKZNEW=XMKZNEW+1
- . . Q:XMKZ=XMKZNEW
- . . S XMFDA(3.702,XMZ_","_XMK_","_XMDUZ_",",2)=XMKZNEW
- . . D FILE^DIE("","XMFDA") I $D(DIERR) D ERRSET^XMXUTIL(37212.8,$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)) ; Error resequencing the '_x_' basket.
- K ^TMP("XM",$J,"RSEQ")
- Q:$D(XMERR)
- S:+$P($G(^XMB(3.7,XMDUZ,2,XMK,1,0)),U,4)'=XMKZNEW $P(^(0),U,4)=XMKZNEW
- Q
- XRSEQ(XMDUZ,XMK,XMKZNEW) ; Internal MailMan entry point to resequence a basket
- ; *** IN XMKZ SEQUENCE ***
- N XMKZ,XMZ,XMFDA
- S (XMKZ,XMKZNEW)=0
- F S XMKZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ)) Q:XMKZ'>0 D Q:$D(XMERR)
- . I XMKZ'>XMKZNEW S XMKZNEW=XMKZ-1
- . S XMZ=0
- . F S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,XMZ)) Q:XMZ'>0 D Q:$D(XMERR)
- . . S XMKZNEW=XMKZNEW+1
- . . Q:XMKZ=XMKZNEW
- . . S XMFDA(3.702,XMZ_","_XMK_","_XMDUZ_",",2)=XMKZNEW
- . . D FILE^DIE("","XMFDA") I $D(DIERR) D ERRSET^XMXUTIL(37212.8,$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)) ; Error resequencing the '_x_' basket.
- Q:$D(XMERR)
- S:+$P($G(^XMB(3.7,XMDUZ,2,XMK,1,0)),U,4)'=XMKZNEW $P(^(0),U,4)=XMKZNEW
- Q
- FLTRBSKT(XMDUZ,XMK,XMMSG) ; Filter a basket
- ; XMZ - Unique message number
- ; XMK - basket number
- K XMERR,^TMP("XMERR",$J)
- S XMMSG=""
- I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q
- I XMDUZ'=DUZ,'$$RPRIV^XMXSEC Q
- I XMK'=.5,'$D(^XMB(3.7,XMDUZ,15,"AF")) D Q
- . D ERRSET^XMXUTIL($S(XMDUZ=DUZ:37204.1,1:37204.2),XMV("NAME")) ; You have / x has no message filters defined.
- I XMDUZ=.5,XMK>1000 D Q
- . D ERRSET^XMXUTIL(37251) ; You may not do this with messages in the transmit queues.
- N XMZ,XMKN
- S XMKN=$P(^XMB(3.7,XMDUZ,2,XMK,0),U,1)
- S XMZ=0
- F S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,XMZ)) Q:XMZ'>0 D FLTR^XMXMSGS2(XMDUZ,XMK,XMKN,XMZ)
- S XMMSG=$$EZBLD^DIALOG(34306.2) ; Basket filtered.
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMXBSKT 6630 printed Jan 18, 2025@03:15:08 Page 2
- XMXBSKT ;ISC-SF/GMB-Basket APIs ;03/25/2003 14:55
- +1 ;;8.0;MailMan;**16**;Jun 28, 2002
- CRE8BSKT(XMDUZ,XMKN,XMK) ; Routine creates basket, given name, and
- +1 ; returns basket number.
- +2 KILL XMERR,^TMP("XMERR",$JOB)
- +3 IF XMDUZ=.6
- IF '$$POSTPRIV^XMXSEC
- QUIT
- +4 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +5 SET XMK=$$FIND1^DIC(3.701,","_XMDUZ_",","X",XMKN)
- +6 IF XMK
- Begin DoDot:1
- +7 ; (It might be better if used an index which was the upper case of
- +8 ; the basket name, and if we checked for upper case of XMKN)
- +9 ; Basket '_XMKN_' already exists.
- DO ERRSET^XMXUTIL(37201.3,XMKN)
- End DoDot:1
- QUIT
- +10 IF XMDUZ=.5
- Begin DoDot:1
- +11 NEW I,XMK
- +12 SET XMK=.99
- +13 FOR I=1:1
- SET XMK=$ORDER(^XMB(3.7,.5,2,XMK))
- if XMK>999!'XMK
- QUIT
- +14 if I<999
- QUIT
- +15 ; Postmaster may not have more than 999 baskets. (>999=Network msg queues)
- DO ERRSET^XMXUTIL(38113.1)
- End DoDot:1
- if $GET(XMERR)
- QUIT
- +16 ;D VAL^DIE(3.701,"1,"_XMDUZ_",",.01,"H",XMKN) ; validate the name
- +17 DO MAKEBSKT(XMDUZ,.XMK,XMKN)
- +18 QUIT
- MAKEBSKT(XMDUZ,XMK,XMKN) ; Create a basket (For internal MM use only)
- +1 ; If you give it an XMK, it'll put it there,
- +2 ; else, it'll find a vacant XMK.
- +3 NEW XMFDA,XMIEN,XMTRIES
- +4 ; Find 1st vacant bskt #
- IF 'XMK
- FOR XMK=2:1
- if '$DATA(^XMB(3.7,XMDUZ,2,XMK))
- QUIT
- +5 SET XMFDA(3.701,"+1,"_XMDUZ_",",.01)=XMKN
- +6 SET XMIEN(1)=XMK
- MTRY DO UPDATE^DIE("S","XMFDA","XMIEN")
- if '$DATA(DIERR)
- QUIT
- +1 SET XMTRIES=$GET(XMTRIES)+1
- +2 ; Try again if can't lock
- IF $DATA(^TMP("DIERR",$JOB,"E",110))
- HANG 1
- GOTO MTRY
- +3 QUIT
- DELBSKT(XMDUZ,XMK,XMFLAGS) ;
- +1 ; XMK Basket IEN
- +2 NEW XMNEW
- +3 KILL XMERR,^TMP("XMERR",$JOB)
- +4 IF XMDUZ=.6
- IF '$$POSTPRIV^XMXSEC
- QUIT
- +5 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +6 IF XMK'>1
- Begin DoDot:1
- +7 ; The '_IN/WASTE_' basket may not be deleted.
- DO ERRSET^XMXUTIL(37215.2,$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1))
- End DoDot:1
- QUIT
- +8 IF $GET(XMFLAGS)'["D"
- IF $$BMSGCT^XMXUTIL(XMDUZ,XMK)>0
- Begin DoDot:1
- +9 ; The '_x_' basket may not be deleted, because it still has messages in it.
- DO ERRSET^XMXUTIL(37215.4,$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1))
- End DoDot:1
- QUIT
- +10 SET XMNEW=$$BNMSGCT^XMXUTIL(XMDUZ,XMK)
- +11 LOCK +^XMB(3.7,XMDUZ):1
- +12 if XMNEW
- SET $PIECE(^(0),U,6)=$PIECE(^XMB(3.7,XMDUZ,0),U,6)-XMNEW
- +13 NEW XMFDA
- +14 SET XMFDA(3.701,XMK_","_XMDUZ_",",.01)="@"
- +15 DO FILE^DIE("","XMFDA")
- +16 LOCK -^XMB(3.7,XMDUZ)
- +17 QUIT
- LISTBSKT(XMDUZ,XMFLAGS,XMAMT,XMSTART,XMPART,XMTROOT) ;
- +1 NEW XMORDER,XMI,XMCNT,XMK,XMKREC,XMSCREEN,XMFMFLAG
- +2 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +3 IF $DATA(XMTROOT)
- IF XMTROOT'=""
- Begin DoDot:1
- +4 KILL @$$CREF^DILF(XMTROOT)
- +5 SET XMTROOT=$$OREF^DILF(XMTROOT)_"""XMLIST"","
- End DoDot:1
- +6 IF '$TEST
- Begin DoDot:1
- +7 KILL ^TMP("XMLIST",$JOB)
- +8 SET XMTROOT="^TMP(""XMLIST"",$J,"
- End DoDot:1
- +9 ; Only baskets w/new msgs
- IF $GET(XMFLAGS)["N"
- SET XMSCREEN="I $P(^(0),U,2)"
- +10 IF '$TEST
- SET XMSCREEN=""
- +11 SET XMFMFLAG="I"
- +12 IF $GET(XMFLAGS)["B"
- SET XMFMFLAG=XMFMFLAG_"B"
- +13 DO LIST^DIC(3.701,","_XMDUZ_",","",XMFMFLAG,.XMAMT,.XMSTART,.XMPART,"",XMSCREEN)
- +14 SET @(XMTROOT_"0)")=^TMP("DILIST",$JOB,0)
- +15 SET XMORDER=$SELECT($GET(XMFLAGS)["B":-1,1:1)
- +16 SET XMCNT=0
- SET XMI=""
- +17 FOR
- SET XMI=$ORDER(^TMP("DILIST",$JOB,2,XMI),XMORDER)
- if 'XMI
- QUIT
- SET XMK=^(XMI)
- Begin DoDot:1
- +18 SET XMCNT=XMCNT+1
- +19 SET XMKREC=^XMB(3.7,XMDUZ,2,XMK,0)
- +20 ; basket ien^basket name^# msgs^# new msgs
- SET @(XMTROOT_XMCNT_")")=XMK_U_$PIECE(XMKREC,U,1)_U_$$BMSGCT^XMXUTIL(XMDUZ,XMK)_U_+$PIECE(XMKREC,U,2)
- +21 IF '$GET(XMAMT)
- SET @(XMTROOT_"""BSKT"",$$UP^XLFSTR($P(XMKREC,U,1)),"_XMCNT_")")=""
- End DoDot:1
- +22 KILL ^TMP("DILIST",$JOB)
- +23 QUIT
- NAMEBSKT(XMDUZ,XMK,XMKN) ;
- +1 ; XMK Basket IEN
- +2 ; XMKN New basket name
- +3 KILL XMERR,^TMP("XMERR",$JOB)
- +4 IF XMDUZ=.6
- IF '$$POSTPRIV^XMXSEC
- QUIT
- +5 IF XMDUZ'=DUZ
- IF '$$WPRIV^XMXSEC
- QUIT
- +6 IF XMK'>1!(XMDUZ=.5&(XMK>999))
- Begin DoDot:1
- +7 ; The '_x_' basket name may not be changed.
- DO ERRSET^XMXUTIL(37201.2,$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1))
- End DoDot:1
- QUIT
- +8 NEW XMFDA
- +9 SET XMFDA(3.701,XMK_","_XMDUZ_",",.01)=XMKN
- +10 DO FILE^DIE("","XMFDA")
- +11 QUIT
- QBSKT(XMDUZ,XMK,XMMSG) ; Message counts for a mail basket
- +1 NEW XMKREC
- +2 KILL XMERR,^TMP("XMERR",$JOB)
- +3 SET XMMSG=""
- +4 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +5 SET XMKREC=^XMB(3.7,XMDUZ,2,XMK,0)
- +6 ; basket ien^basket name^# msgs^# new msgs
- SET XMMSG=XMK_U_$PIECE(XMKREC,U,1)_U_$$BMSGCT^XMXUTIL(XMDUZ,XMK)_U_+$PIECE(XMKREC,U,2)
- +7 QUIT
- RSEQBSKT(XMDUZ,XMK,XMMSG) ; Resequence message numbers
- +1 ; XMZ - Unique message number
- +2 ; XMK - basket number
- +3 ; XMKZ - Message number in basket
- +4 ; XMKZCNT - Number of messages in basket
- +5 ; (XMERROR is set in XMUT4)
- NEW XMKZCNT,XMERROR
- +6 KILL XMERR,^TMP("XMERR",$JOB)
- +7 SET XMMSG=""
- +8 ;I XMDUZ=.6,'$$POSTPRIV^XMXSEC Q ; Shouldn't need special privileges.
- +9 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +10 ; Basket integrity check
- DO BSKT^XMUT4(XMDUZ,XMK)
- +11 ; resequence
- DO RSEQ(XMDUZ,XMK,.XMKZCNT)
- +12 ; Resequenced from 1 to _XMKZCNT.
- SET XMMSG=$$EZBLD^DIALOG(37212.9,XMKZCNT)
- +13 QUIT
- RSEQ(XMDUZ,XMK,XMKZNEW) ; Internal MailMan entry point to resequence a basket
- +1 ; *** IN create date/xmz SEQUENCE ***
- +2 NEW XMKZ,XMZ,XMFDA,XMCRE8DT
- +3 KILL ^TMP("XM",$JOB,"RSEQ")
- +4 SET XMZ=0
- +5 FOR
- SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,XMZ))
- if XMZ'>0
- QUIT
- SET ^TMP("XM",$JOB,"RSEQ",+$PIECE($GET(^XMB(3.9,XMZ,.6)),U),XMZ)=""
- +6 SET XMKZNEW=0
- SET (XMCRE8DT,XMZ)=""
- +7 FOR
- SET XMCRE8DT=$ORDER(^TMP("XM",$JOB,"RSEQ",XMCRE8DT))
- if XMCRE8DT=""
- QUIT
- Begin DoDot:1
- +8 FOR
- SET XMZ=$ORDER(^TMP("XM",$JOB,"RSEQ",XMCRE8DT,XMZ))
- if 'XMZ
- QUIT
- Begin DoDot:2
- +9 SET XMKZ=$PIECE($GET(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,2)
- if 'XMKZ
- QUIT
- +10 SET XMKZNEW=XMKZNEW+1
- +11 if XMKZ=XMKZNEW
- QUIT
- +12 SET XMFDA(3.702,XMZ_","_XMK_","_XMDUZ_",",2)=XMKZNEW
- +13 ; Error resequencing the '_x_' basket.
- DO FILE^DIE("","XMFDA")
- IF $DATA(DIERR)
- DO ERRSET^XMXUTIL(37212.8,$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1))
- End DoDot:2
- if $DATA(XMERR)
- QUIT
- End DoDot:1
- if $DATA(XMERR)
- QUIT
- +14 KILL ^TMP("XM",$JOB,"RSEQ")
- +15 if $DATA(XMERR)
- QUIT
- +16 if +$PIECE($GET(^XMB(3.7,XMDUZ,2,XMK,1,0)),U,4)'=XMKZNEW
- SET $PIECE(^(0),U,4)=XMKZNEW
- +17 QUIT
- XRSEQ(XMDUZ,XMK,XMKZNEW) ; Internal MailMan entry point to resequence a basket
- +1 ; *** IN XMKZ SEQUENCE ***
- +2 NEW XMKZ,XMZ,XMFDA
- +3 SET (XMKZ,XMKZNEW)=0
- +4 FOR
- SET XMKZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ))
- if XMKZ'>0
- QUIT
- Begin DoDot:1
- +5 IF XMKZ'>XMKZNEW
- SET XMKZNEW=XMKZ-1
- +6 SET XMZ=0
- +7 FOR
- SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,XMZ))
- if XMZ'>0
- QUIT
- Begin DoDot:2
- +8 SET XMKZNEW=XMKZNEW+1
- +9 if XMKZ=XMKZNEW
- QUIT
- +10 SET XMFDA(3.702,XMZ_","_XMK_","_XMDUZ_",",2)=XMKZNEW
- +11 ; Error resequencing the '_x_' basket.
- DO FILE^DIE("","XMFDA")
- IF $DATA(DIERR)
- DO ERRSET^XMXUTIL(37212.8,$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1))
- End DoDot:2
- if $DATA(XMERR)
- QUIT
- End DoDot:1
- if $DATA(XMERR)
- QUIT
- +12 if $DATA(XMERR)
- QUIT
- +13 if +$PIECE($GET(^XMB(3.7,XMDUZ,2,XMK,1,0)),U,4)'=XMKZNEW
- SET $PIECE(^(0),U,4)=XMKZNEW
- +14 QUIT
- FLTRBSKT(XMDUZ,XMK,XMMSG) ; Filter a basket
- +1 ; XMZ - Unique message number
- +2 ; XMK - basket number
- +3 KILL XMERR,^TMP("XMERR",$JOB)
- +4 SET XMMSG=""
- +5 IF XMDUZ=.6
- IF '$$POSTPRIV^XMXSEC
- QUIT
- +6 IF XMDUZ'=DUZ
- IF '$$RPRIV^XMXSEC
- QUIT
- +7 IF XMK'=.5
- IF '$DATA(^XMB(3.7,XMDUZ,15,"AF"))
- Begin DoDot:1
- +8 ; You have / x has no message filters defined.
- DO ERRSET^XMXUTIL($SELECT(XMDUZ=DUZ:37204.1,1:37204.2),XMV("NAME"))
- End DoDot:1
- QUIT
- +9 IF XMDUZ=.5
- IF XMK>1000
- Begin DoDot:1
- +10 ; You may not do this with messages in the transmit queues.
- DO ERRSET^XMXUTIL(37251)
- End DoDot:1
- QUIT
- +11 NEW XMZ,XMKN
- +12 SET XMKN=$PIECE(^XMB(3.7,XMDUZ,2,XMK,0),U,1)
- +13 SET XMZ=0
- +14 FOR
- SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,XMZ))
- if XMZ'>0
- QUIT
- DO FLTR^XMXMSGS2(XMDUZ,XMK,XMKN,XMZ)
- +15 ; Basket filtered.
- SET XMMSG=$$EZBLD^DIALOG(34306.2)
- +16 QUIT