CIAUUSR.m

CIAUUSR ;MSC/IND/DKM - Parse recipient list;04-May-2006 08:19;DKM

 ;;1.2;CIA UTILITIES;;Mar 20, 2007

 ;;Copyright 2000-2006, Medsphere Systems Corporation

 ;=================================================================

 ; Takes a list of recipients (which may be DUZ #'s, names,

 ; mail groups, or special tokens) as input and produces an

 ; array of DUZ's as output.  If a list element is found in

 ; in the token list CIALST, the value of the token entry will

 ; be substituted.

 ; Inputs:

 ;     CIAUSR = Semicolon-delimited list of recipients

 ;     CIALST = Special token list

 ; Outputs:

 ;     CIAOUT = Local array to receive DUZ list

 ;=================================================================

ENTRY(CIAUSR,CIAOUT,CIALST) ;

 N CIAZ,CIAZ1,CIAZ2

 K CIAOUT

 F CIAZ=1:1:$L(CIAUSR,";") S CIAZ1=$P(CIAUSR,";",CIAZ) D:CIAZ1'=""  S:CIAZ1 CIAOUT(+CIAZ1)=""

 .S:$D(CIALST(CIAZ1)) CIAZ1=CIALST(CIAZ1)

 .Q:CIAZ1?.N

 .I CIAZ1?1"-"1.N D MGRP(-CIAZ1) S CIAZ1=0 Q

 .S CIAZ2=$E(CIAZ1,1,2)

 .I CIAZ2="G." D MGRP($E(CIAZ1,3,999)) Q

 .I CIAZ2="L." D LIST($E(CIAZ1,3,999)) Q

 .S CIAZ1=$$LKP(CIAZ1)

 Q

LKP(CIANAME) ;

 N CIAZ,CIAZ1

 I $D(^VA(200,"B",CIANAME)) S CIAZ=CIANAME G L1

 S CIAZ=$O(^(CIANAME)),CIAZ1=$O(^(CIAZ))

 Q:(CIAZ="")!(CIANAME'=$E(CIAZ,1,$L(CIANAME))) 0

 Q:(CIAZ1'="")&(CIANAME=$E(CIAZ1,1,$L(CIANAME))) 0

L1 S CIAZ1=$O(^(CIAZ,0)),CIAZ=$O(^(CIAZ1))

 Q:'CIAZ1!CIAZ 0

 Q CIAZ1

LIST(CIALIST) ;

 Q:CIALIST=""

 S:CIALIST'=+CIALIST CIALIST=+$O(^CCCDSS(25193.6,"B",CIALIST,0))

 S @$$TRAP^CIAUOS("LERR^CIAUUSR")

 X:$D(^CCCDSS(25193.6,CIALIST,1)) ^(1)

LERR Q

MGRP(CIAMGRP) ;

 N CIAX

 S CIAX(0)=""

 D MGRP2(CIAMGRP)

 Q

MGRP2(CIAMGRP) ;

 N CIAZ,CIAZ1

 Q:CIAMGRP=""

 S:CIAMGRP'=+CIAMGRP CIAMGRP=+$O(^XMB(3.8,"B",CIAMGRP,0))

 Q:$D(CIAX(CIAMGRP))

 S CIAX(CIAMGRP)=""

 F CIAZ=0:0 S CIAZ=+$O(^XMB(3.8,CIAMGRP,1,CIAZ)) Q:'CIAZ  S CIAOUT(+^(CIAZ,0))=""

 F CIAZ=0:0 S CIAZ=+$O(^XMB(3.8,CIAMGRP,5,CIAZ)) Q:'CIAZ  D MGRP2(^(CIAZ,0))

 Q

CIAUUSR   ;MSC/IND/DKM - Parse recipient list;04-May-2006 08:19;DKM

 +1       ;;1.2;CIA UTILITIES;;Mar 20, 2007

 +2       ;;Copyright 2000-2006, Medsphere Systems Corporation

 +3       ;=================================================================

 +4       ; Takes a list of recipients (which may be DUZ #'s, names,

 +5       ; mail groups, or special tokens) as input and produces an

 +6       ; array of DUZ's as output.  If a list element is found in

 +7       ; in the token list CIALST, the value of the token entry will

 +8       ; be substituted.

 +9       ; Inputs:

 +10      ;     CIAUSR = Semicolon-delimited list of recipients

 +11      ;     CIALST = Special token list

 +12      ; Outputs:

 +13      ;     CIAOUT = Local array to receive DUZ list

 +14      ;=================================================================

ENTRY(CIAUSR,CIAOUT,CIALST) ;

 +1        NEW CIAZ,CIAZ1,CIAZ2

 +2        KILL CIAOUT

 +3        FOR CIAZ=1:1:$LENGTH(CIAUSR,";")

               SET CIAZ1=$PIECE(CIAUSR,";",CIAZ)

               IF CIAZ1'=""

                   Begin DoDot:1

 +4                    IF $DATA(CIALST(CIAZ1))

                           SET CIAZ1=CIALST(CIAZ1)

 +5                    IF CIAZ1?.N

                           QUIT 

 +6                    IF CIAZ1?1"-"1.N

                           DO MGRP(-CIAZ1)

                           SET CIAZ1=0

                           QUIT 

 +7                    SET CIAZ2=$EXTRACT(CIAZ1,1,2)

 +8                    IF CIAZ2="G."

                           DO MGRP($EXTRACT(CIAZ1,3,999))

                           QUIT 

 +9                    IF CIAZ2="L."

                           DO LIST($EXTRACT(CIAZ1,3,999))

                           QUIT 

 +10                   SET CIAZ1=$$LKP(CIAZ1)

                   End DoDot:1

               IF CIAZ1

                   SET CIAOUT(+CIAZ1)=""

 +11       QUIT 

LKP(CIANAME) ;

 +1        NEW CIAZ,CIAZ1

 +2        IF $DATA(^VA(200,"B",CIANAME))

               SET CIAZ=CIANAME

               GOTO L1

 +3        SET CIAZ=$ORDER(^(CIANAME))

           SET CIAZ1=$ORDER(^(CIAZ))

 +4        IF (CIAZ="")!(CIANAME'=$EXTRACT(CIAZ,1,$LENGTH(CIANAME)))

               QUIT 0

 +5        IF (CIAZ1'="")&(CIANAME=$EXTRACT(CIAZ1,1,$LENGTH(CIANAME)))

               QUIT 0

L1         SET CIAZ1=$ORDER(^(CIAZ,0))

           SET CIAZ=$ORDER(^(CIAZ1))

 +1        IF 'CIAZ1!CIAZ

               QUIT 0

 +2        QUIT CIAZ1

LIST(CIALIST) ;

 +1        IF CIALIST=""

               QUIT 

 +2        IF CIALIST'=+CIALIST

               SET CIALIST=+$ORDER(^CCCDSS(25193.6,"B",CIALIST,0))

 +3        SET @$$TRAP^CIAUOS("LERR^CIAUUSR")

 +4        IF $DATA(^CCCDSS(25193.6,CIALIST,1))

               XECUTE ^(1)

LERR       QUIT 

MGRP(CIAMGRP) ;

 +1        NEW CIAX

 +2        SET CIAX(0)=""

 +3        DO MGRP2(CIAMGRP)

 +4        QUIT 

MGRP2(CIAMGRP) ;

 +1        NEW CIAZ,CIAZ1

 +2        IF CIAMGRP=""

               QUIT 

 +3        IF CIAMGRP'=+CIAMGRP

               SET CIAMGRP=+$ORDER(^XMB(3.8,"B",CIAMGRP,0))

 +4        IF $DATA(CIAX(CIAMGRP))

               QUIT 

 +5        SET CIAX(CIAMGRP)=""

 +6        FOR CIAZ=0:0

               SET CIAZ=+$ORDER(^XMB(3.8,CIAMGRP,1,CIAZ))

               IF 'CIAZ

                   QUIT 

               SET CIAOUT(+^(CIAZ,0))=""

 +7        FOR CIAZ=0:0

               SET CIAZ=+$ORDER(^XMB(3.8,CIAMGRP,5,CIAZ))

               IF 'CIAZ

                   QUIT 

               DO MGRP2(^(CIAZ,0))

 +8        QUIT