VAQUTL4 ;ALB/JRP - UTILITY ROUTINES;10-JUN-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
MAILGRP(NAME,TYPE,SELF,RESTRICT,DESCRIBE) ;ADD/EDIT BASIC MAIL GROUP INFO
;INPUT : NAME - Name of new mail group
; TYPE - Flag indicating type of mail group
; 0 = public (default)
; 1 = private
; SELF - Flag indicating if self enrollment is allowed
; 0 = no
; 1 = yes (default)
; RESTRICT - Flag indicating restriction of mail group
; 0 to 7 - refer to data dictionary for definitions
; 0 (unrestricted) is default
; DESCRIBE - Array containing description (full global ref)
; (optional)
; DUZ - Current user
;OUTPUT : IFN^0 - Entry number of mail group edited
; IFN^1 - Entry number of mail group added
; -1^ErrorText - Error
;NOTES : If editing an existing mail group, the basic information
; already defined in the mail group will be overwritten. The
; current description will be deleted before the new
; description is added. If a new description is not passed,
; the current description will not be deleted.
; : The organizer of the mail group will be the current user.
;
;CHECK INPUT
Q:($G(NAME)="") "-1^Did not pass name of mail group to create"
Q:(($L(NAME)<3)!($L(NAME)>30)) "-1^Did not pass valid mail group name"
S TYPE=+$G(TYPE)
S:($G(SELF)="") SELF=1
S:(SELF'=1) SELF=0
S RESTRICT=+$G(RESTRICT)
S:((RESTRICT<0)!(RESTRICT>7)) RESTRICT=0
Q:('$G(DUZ)) "-1^You are not identified (NO DUZ)"
;DECLARE VARIABLES
N DIC,X,Y,LINE,ADDED,IFN,DIE,DA,DR,DIK,DA
;SEE IF MAIL GROUP ALREADY EXISTS
S ADDED=0
S DIC="^XMB(3.8,"
S DIC(0)="MX"
S X=NAME
D ^DIC K DIC
S IFN=+Y
;CREATE STUB MAIL GROUP
I (IFN<0) D Q:(IFN<0) IFN
.S ADDED=1
.S DIC="^XMB(3.8,"
.S DIC(0)="L"
.S X=NAME
.K DD,DO
.D FILE^DICN K DIC
.S IFN=+Y
.S:(IFN<0) IFN="-1^Unable to create mail group"
;LOCK ENTRY
S X=0
L +^XMB(3.8,IFN):60 S:('$T) X=1
;COULDN'T LOCK (ERROR)
I (X) D Q Y
.;ENTRY NOT CREATED
.I ('ADDED) S Y="-1^Mail group was being edited by another user" Q
.;DELETE ENTRY CREATED
.S DIK="^XMB(3.8,"
.S DA=IFN
.D ^DIK
.;COULDN'T DELETE NEW ENTRY
.I ($D(^XMB(3.8,IFN))) S Y="-1^Error creating mail group; unable to delete (IFN:"_IFN_")" Q
.;NEW ENTRY DELETED
.S Y="-1^Error creating mail group; entry deleted"
;EDIT ENTRY
S DIE="^XMB(3.8,"
S DA=IFN
S DR="4///"_$S(TYPE:"private",1:"public")
S DR(1,3.8,5)="5////"_DUZ
S DR(1,3.8,7)="7///"_$S(SELF:"YES",1:"NO")
S X="UNRESTRICTED^ORGANIZER ONLY^LOCAL^ORGANIZER/LOCAL^INDIVIDUALS^INDIV/ORGANIZER^INDIV/LOCAL^INDIV/LOCAL/ORGANIZER"
S Y=$P(X,"^",(RESTRICT+1))
S:(Y="") Y=$P(X,"^",1)
S DR(1,3.8,10)="10///"_Y
I ($G(DESCRIBE)'="") I ($D(@DESCRIBE)) D
.;DELETES CURRENT DESCRIPTION
.S DR(1,3.8,3)="3///@"
.;ADDS NEW DESCRIPTION
.S LINE=""
.F X=1:1 S LINE=$O(@DESCRIBE@(LINE)) Q:(LINE="") D
..S Y=$G(@DESCRIBE@(LINE))
..S:(Y="") Y=" "
..S DR(1,3.8,(300+X))="3///+"_Y
K X,Y D ^DIE
;UNLOCK ENTRY AND QUIT
L -^XMB(3.8,IFN)
Q IFN_"^"_ADDED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQUTL4 3236 printed Nov 22, 2024@17:37:01 Page 2
VAQUTL4 ;ALB/JRP - UTILITY ROUTINES;10-JUN-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
MAILGRP(NAME,TYPE,SELF,RESTRICT,DESCRIBE) ;ADD/EDIT BASIC MAIL GROUP INFO
+1 ;INPUT : NAME - Name of new mail group
+2 ; TYPE - Flag indicating type of mail group
+3 ; 0 = public (default)
+4 ; 1 = private
+5 ; SELF - Flag indicating if self enrollment is allowed
+6 ; 0 = no
+7 ; 1 = yes (default)
+8 ; RESTRICT - Flag indicating restriction of mail group
+9 ; 0 to 7 - refer to data dictionary for definitions
+10 ; 0 (unrestricted) is default
+11 ; DESCRIBE - Array containing description (full global ref)
+12 ; (optional)
+13 ; DUZ - Current user
+14 ;OUTPUT : IFN^0 - Entry number of mail group edited
+15 ; IFN^1 - Entry number of mail group added
+16 ; -1^ErrorText - Error
+17 ;NOTES : If editing an existing mail group, the basic information
+18 ; already defined in the mail group will be overwritten. The
+19 ; current description will be deleted before the new
+20 ; description is added. If a new description is not passed,
+21 ; the current description will not be deleted.
+22 ; : The organizer of the mail group will be the current user.
+23 ;
+24 ;CHECK INPUT
+25 if ($GET(NAME)="")
QUIT "-1^Did not pass name of mail group to create"
+26 if (($LENGTH(NAME)<3)!($LENGTH(NAME)>30))
QUIT "-1^Did not pass valid mail group name"
+27 SET TYPE=+$GET(TYPE)
+28 if ($GET(SELF)="")
SET SELF=1
+29 if (SELF'=1)
SET SELF=0
+30 SET RESTRICT=+$GET(RESTRICT)
+31 if ((RESTRICT<0)!(RESTRICT>7))
SET RESTRICT=0
+32 if ('$GET(DUZ))
QUIT "-1^You are not identified (NO DUZ)"
+33 ;DECLARE VARIABLES
+34 NEW DIC,X,Y,LINE,ADDED,IFN,DIE,DA,DR,DIK,DA
+35 ;SEE IF MAIL GROUP ALREADY EXISTS
+36 SET ADDED=0
+37 SET DIC="^XMB(3.8,"
+38 SET DIC(0)="MX"
+39 SET X=NAME
+40 DO ^DIC
KILL DIC
+41 SET IFN=+Y
+42 ;CREATE STUB MAIL GROUP
+43 IF (IFN<0)
Begin DoDot:1
+44 SET ADDED=1
+45 SET DIC="^XMB(3.8,"
+46 SET DIC(0)="L"
+47 SET X=NAME
+48 KILL DD,DO
+49 DO FILE^DICN
KILL DIC
+50 SET IFN=+Y
+51 if (IFN<0)
SET IFN="-1^Unable to create mail group"
End DoDot:1
if (IFN<0)
QUIT IFN
+52 ;LOCK ENTRY
+53 SET X=0
+54 LOCK +^XMB(3.8,IFN):60
if ('$TEST)
SET X=1
+55 ;COULDN'T LOCK (ERROR)
+56 IF (X)
Begin DoDot:1
+57 ;ENTRY NOT CREATED
+58 IF ('ADDED)
SET Y="-1^Mail group was being edited by another user"
QUIT
+59 ;DELETE ENTRY CREATED
+60 SET DIK="^XMB(3.8,"
+61 SET DA=IFN
+62 DO ^DIK
+63 ;COULDN'T DELETE NEW ENTRY
+64 IF ($DATA(^XMB(3.8,IFN)))
SET Y="-1^Error creating mail group; unable to delete (IFN:"_IFN_")"
QUIT
+65 ;NEW ENTRY DELETED
+66 SET Y="-1^Error creating mail group; entry deleted"
End DoDot:1
QUIT Y
+67 ;EDIT ENTRY
+68 SET DIE="^XMB(3.8,"
+69 SET DA=IFN
+70 SET DR="4///"_$SELECT(TYPE:"private",1:"public")
+71 SET DR(1,3.8,5)="5////"_DUZ
+72 SET DR(1,3.8,7)="7///"_$SELECT(SELF:"YES",1:"NO")
+73 SET X="UNRESTRICTED^ORGANIZER ONLY^LOCAL^ORGANIZER/LOCAL^INDIVIDUALS^INDIV/ORGANIZER^INDIV/LOCAL^INDIV/LOCAL/ORGANIZER"
+74 SET Y=$PIECE(X,"^",(RESTRICT+1))
+75 if (Y="")
SET Y=$PIECE(X,"^",1)
+76 SET DR(1,3.8,10)="10///"_Y
+77 IF ($GET(DESCRIBE)'="")
IF ($DATA(@DESCRIBE))
Begin DoDot:1
+78 ;DELETES CURRENT DESCRIPTION
+79 SET DR(1,3.8,3)="3///@"
+80 ;ADDS NEW DESCRIPTION
+81 SET LINE=""
+82 FOR X=1:1
SET LINE=$ORDER(@DESCRIBE@(LINE))
if (LINE="")
QUIT
Begin DoDot:2
+83 SET Y=$GET(@DESCRIBE@(LINE))
+84 if (Y="")
SET Y=" "
+85 SET DR(1,3.8,(300+X))="3///+"_Y
End DoDot:2
End DoDot:1
+86 KILL X,Y
DO ^DIE
+87 ;UNLOCK ENTRY AND QUIT
+88 LOCK -^XMB(3.8,IFN)
+89 QUIT IFN_"^"_ADDED
