- XMJBU ;ISC-SF/GMB-Basket utilities ;04/06/2002 08:56
- ;;8.0;MailMan;;Jun 28, 2002
- ; (ISC-WASH/CAP/THM)
- SELBSKT(XMDUZ,XMPROMPT,XMLAYGO,XMDIC,XMK,XMKN) ; Select a basket (Replaces S^XMA1B)
- ; XMPROMPT (in) Verbage for prompt
- ; XMLAYGO (in) "L" - the user may create a new basket
- ; "" - the user may not create a new basket
- ; XMK (out) basket number (=^ if user up-arrows out)
- ; XMKN (out) basket name
- N DIC,DINUM,DA,Y,X
- I $G(XMLAYGO)["L" D
- . ; Find the first vacant basket spot.
- . F DINUM=2:1 Q:'$D(^XMB(3.7,XMDUZ,2,DINUM))
- . ; Postmaster baskets numbered above 999 are reserved for message queues.
- . I XMDUZ=.5,DINUM>999 S XMLAYGO=$TR(XMLAYGO,"L")
- ; Postmaster may not save a queued msg to his own basket. ***
- S DIC="^XMB(3.7,"_XMDUZ_",2,"
- S DA(1)=XMDUZ
- S DIC(0)="AEQ"_$G(XMLAYGO)
- I $G(XMPROMPT)'="" S DIC("A")=$S(+XMPROMPT=XMPROMPT:$$EZBLD^DIALOG(XMPROMPT),1:XMPROMPT)
- ; XMDIC("B")="@" means don't give a default
- I $G(XMDIC("B"))'="@" D
- . I $D(XMDIC("B")) S DIC("B")=XMDIC("B") Q
- . I $$BMSGCT^XMXUTIL(XMDUZ,1) S DIC("B")=$$EZBLD^DIALOG(37005) Q ; IN
- . W !!,$$EZBLD^DIALOG(34044,$$EZBLD^DIALOG(37005)) ; No messages in 'IN' basket.
- S:$D(XMDIC("S")) DIC("S")=XMDIC("S")
- S:$D(XMDIC("W")) DIC("W")=XMDIC("W")
- D ^DIC I Y=-1 S XMK=U Q
- S XMK=$P(Y,U,1)
- S XMKN=$P(Y,U,2)
- Q
- CHKXMKN(X) ; Input transform for file 3.7 (3.701,.01 BASKET)
- I X=+X,$D(^XMB(3.7,$G(XMDUZ,DUZ),2,X)) S X="`"_X Q
- K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
- Q
- NAMEBSKT(XMDUZ,XMK,XMKN) ; Rename an existing basket (Replaces REN^XMA11)
- ; XMK (in) basket number
- ; XMKN (in/out) basket name
- N DIR,X,XMFDA,XMKX
- I XMK'>1!(XMDUZ=.5&(XMK>999)) D Q
- . W !,$$EZBLD^DIALOG(37201.1) ; The name of this basket may not be changed.
- ; *** I would rather use a ^DIE call, if I were sure that the user
- ; *** could not delete the basket or create a duplicate basket name.
- S DIR("A")=$$EZBLD^DIALOG(34048) ; Enter a new basket name
- S DIR("B")=XMKN
- S DIR(0)="3.701,.01"
- F D ^DIR Q:$D(DIRUT) D Q:$D(X)
- . I X=XMKN D Q
- . . W !,$C(7),$$EZBLD^DIALOG(34048.8) ; That's the same name.
- . . K X
- . S XMKX=$$FIND1^DIC(3.701,","_XMDUZ_",","X",X)
- . I XMKX,XMKX'=XMK D Q
- . . W !,$C(7),$$EZBLD^DIALOG(34048.9) ; You already have a basket by this name.
- . . K X
- . S XMKN=X
- . S XMFDA(3.701,XMK_","_XMDUZ_",",.01)=XMKN
- . D FILE^DIE("","XMFDA")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMJBU 2428 printed Feb 18, 2025@23:37:59 Page 2
- XMJBU ;ISC-SF/GMB-Basket utilities ;04/06/2002 08:56
- +1 ;;8.0;MailMan;;Jun 28, 2002
- +2 ; (ISC-WASH/CAP/THM)
- SELBSKT(XMDUZ,XMPROMPT,XMLAYGO,XMDIC,XMK,XMKN) ; Select a basket (Replaces S^XMA1B)
- +1 ; XMPROMPT (in) Verbage for prompt
- +2 ; XMLAYGO (in) "L" - the user may create a new basket
- +3 ; "" - the user may not create a new basket
- +4 ; XMK (out) basket number (=^ if user up-arrows out)
- +5 ; XMKN (out) basket name
- +6 NEW DIC,DINUM,DA,Y,X
- +7 IF $GET(XMLAYGO)["L"
- Begin DoDot:1
- +8 ; Find the first vacant basket spot.
- +9 FOR DINUM=2:1
- if '$DATA(^XMB(3.7,XMDUZ,2,DINUM))
- QUIT
- +10 ; Postmaster baskets numbered above 999 are reserved for message queues.
- +11 IF XMDUZ=.5
- IF DINUM>999
- SET XMLAYGO=$TRANSLATE(XMLAYGO,"L")
- End DoDot:1
- +12 ; Postmaster may not save a queued msg to his own basket. ***
- +13 SET DIC="^XMB(3.7,"_XMDUZ_",2,"
- +14 SET DA(1)=XMDUZ
- +15 SET DIC(0)="AEQ"_$GET(XMLAYGO)
- +16 IF $GET(XMPROMPT)'=""
- SET DIC("A")=$SELECT(+XMPROMPT=XMPROMPT:$$EZBLD^DIALOG(XMPROMPT),1:XMPROMPT)
- +17 ; XMDIC("B")="@" means don't give a default
- +18 IF $GET(XMDIC("B"))'="@"
- Begin DoDot:1
- +19 IF $DATA(XMDIC("B"))
- SET DIC("B")=XMDIC("B")
- QUIT
- +20 ; IN
- IF $$BMSGCT^XMXUTIL(XMDUZ,1)
- SET DIC("B")=$$EZBLD^DIALOG(37005)
- QUIT
- +21 ; No messages in 'IN' basket.
- WRITE !!,$$EZBLD^DIALOG(34044,$$EZBLD^DIALOG(37005))
- End DoDot:1
- +22 if $DATA(XMDIC("S"))
- SET DIC("S")=XMDIC("S")
- +23 if $DATA(XMDIC("W"))
- SET DIC("W")=XMDIC("W")
- +24 DO ^DIC
- IF Y=-1
- SET XMK=U
- QUIT
- +25 SET XMK=$PIECE(Y,U,1)
- +26 SET XMKN=$PIECE(Y,U,2)
- +27 QUIT
- CHKXMKN(X) ; Input transform for file 3.7 (3.701,.01 BASKET)
- +1 IF X=+X
- IF $DATA(^XMB(3.7,$GET(XMDUZ,DUZ),2,X))
- SET X="`"_X
- QUIT
- +2 if X[""""!($ASCII(X)=45)
- KILL X
- IF $DATA(X)
- if $LENGTH(X)>30!($LENGTH(X)<3)
- KILL X
- +3 QUIT
- NAMEBSKT(XMDUZ,XMK,XMKN) ; Rename an existing basket (Replaces REN^XMA11)
- +1 ; XMK (in) basket number
- +2 ; XMKN (in/out) basket name
- +3 NEW DIR,X,XMFDA,XMKX
- +4 IF XMK'>1!(XMDUZ=.5&(XMK>999))
- Begin DoDot:1
- +5 ; The name of this basket may not be changed.
- WRITE !,$$EZBLD^DIALOG(37201.1)
- End DoDot:1
- QUIT
- +6 ; *** I would rather use a ^DIE call, if I were sure that the user
- +7 ; *** could not delete the basket or create a duplicate basket name.
- +8 ; Enter a new basket name
- SET DIR("A")=$$EZBLD^DIALOG(34048)
- +9 SET DIR("B")=XMKN
- +10 SET DIR(0)="3.701,.01"
- +11 FOR
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- Begin DoDot:1
- +12 IF X=XMKN
- Begin DoDot:2
- +13 ; That's the same name.
- WRITE !,$CHAR(7),$$EZBLD^DIALOG(34048.8)
- +14 KILL X
- End DoDot:2
- QUIT
- +15 SET XMKX=$$FIND1^DIC(3.701,","_XMDUZ_",","X",X)
- +16 IF XMKX
- IF XMKX'=XMK
- Begin DoDot:2
- +17 ; You already have a basket by this name.
- WRITE !,$CHAR(7),$$EZBLD^DIALOG(34048.9)
- +18 KILL X
- End DoDot:2
- QUIT
- +19 SET XMKN=X
- +20 SET XMFDA(3.701,XMK_","_XMDUZ_",",.01)=XMKN
- +21 DO FILE^DIE("","XMFDA")
- End DoDot:1
- if $DATA(X)
- QUIT
- +22 QUIT