BEHOPTP3.m

BEHOPTP3 ;MSC/IND/MGH - Patient List Management ;30-Mar-2012 19:10;DU

 ;;1.1;BEH COMPONENTS;**004004,004008**;Mar 20, 2007

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

 ; Call logic to manage team lists

MANAGE(DATA,LIST,ACTION,NAME,VAL) ;

 D EXEC(12)

 Q

 ; Execute logic at specified node

EXEC(NODE) ;

 N $ET

 S $ET="",@$$TRAP^CIAUOS("EXECERR^BEHOPTPL")

 X $G(^BEHOPT(90460.03,+LIST,NODE))

 Q

 ; List management API

MAN2(DATA,LIST,ACTION,NAME,VAL) ;EP

 S DATA=""

 I ACTION="S"!(ACTION="P")!(ACTION="D") S DATA(1)=$$VALIDATE(NAME)

 I ACTION="C" S DATA=$$VALIDATE(NAME,1)

 Q:DATA(1)

 I ACTION="T" D GETTEAM(.DATA) Q

 I ACTION="P" D GETLST(.DATA,NAME) Q

 I ACTION="C" D CRLST(.DATA,NAME) Q

 I ACTION="S" D SETLST(.DATA,NAME,.VAL) Q

 I ACTION="D" D DELETE(.DATA,NAME) Q

 S DATA(1)="-1^Unknown action"

 Q

 ;Return the list of providers for this list

GETLST(DATA,NAME) ;EP

 N CNT,IEN,PRV,QUALS,DATE,PAT

 K DATA

 S DATA(1)="^No Users found.",(CNT,IEN)=0

 S DATE="TODAY",DATE=$$DT^CIAU(DATE)

 S TEAM=$$GETIEN(NAME)

 I '$D(^OR(100.21,TEAM,0)) S DATA(1)="^Not a valid team." Q

 F  S IEN=$O(^OR(100.21,TEAM,1,IEN)) Q:'IEN  S PRV=+$G(^(IEN,0)) D

 .S X=$$ACTIVE^BEHOUSCX(PRV,DATE)

 .I X=1 S CNT=CNT+1,DATA(CNT)=PRV_U_$P(^VA(200,PRV,0),U)_U_"U"

 .I X=0 S CNT=CNT+1,DATA(CNT)=PRV_"*"_U_$P(^VA(200,PRV,0),U)_U_"U"

 S IEN=0 F  S IEN=$O(^OR(100.21,TEAM,10,IEN)) Q:'IEN  S PAT=+$G(^(IEN,0)) D

 .S CNT=CNT+1,DATA(CNT)=PAT_U_$P(^DPT(PAT,0),U)_U_"M"

 Q

 ; Validate list name

VALIDATE(NAME,DUP) ;

 N L

 S NAME=$$TRIM^CIAU(NAME),L=$L(NAME),DUP=+$G(DUP)

 Q:L<3!(L>30) "-1^List name must be 3-30 characters in length."

 Q:NAME'?.(1A,1N,1"_",1" ") "-1^List name contains invalid characters."

 I DUP,$$GETIEN(NAME) Q "-1^List name already exists."

 I 'DUP,'$$GETIEN(NAME) Q "-1^List name not found."

 Q ""

CRLST(DATA,NAME) ;EP Create a new team list

 N DATE,FNUM,FDA,IEN

 K DATA

 S DATE="TODAY",DATE=$$DT^CIAU(DATE)

 S FNUM=100.21

 S FDA=$NA(FDA(FNUM,"+1,"))

 S @FDA@(.01)=NAME

 S @FDA@(.1)=$$UPPER(NAME)

 S @FDA@(1)="TM"

 S @FDA@(1.6)=DUZ

 S @FDA@(1.65)=DATE

 S @FDA@(1.7)="Y"

 S DATA(1)=$$UPDATE^BGOUTL(.FDA,"",.IEN)

 S:'DATA(1) DATA(1)=IEN(1)

 I $D(IEN(1)) D

 .S FDA=$NA(FDA(100.212,"+1,"_IEN(1)_","))

 .S @FDA@(.01)=DUZ

 .D UPDATE^DIE("","FDA","IEN","ERR")

 Q

 ; Set List

SETLST(DATA,NAME,VAL) ;EP

 N TEAM,FDA,FNUM,ERR,IEN,CNTU,CNTM,NUM

 K DATA

 Q:'$L(NAME)

 S TEAM=$$GETIEN(NAME)

 S CNTU=0,CNTM=0

 I '$D(^OR(100.21,TEAM,0)) S DATA(1)="^Not a valid team." Q

 D DELLST(.DATA,NAME)

 S NUM="" F  S NUM=$O(VAL(NUM)) Q:NUM=""  D

 .I $P(VAL(NUM),U,3)="U"  D

 ..K FDA,IEN,ERR

 ..S FDA=$NA(FDA(100.212,"+1,"_TEAM_","))

 ..S @FDA@(.01)=$P(VAL(NUM),U,1)

 ..D UPDATE^DIE("","FDA","IEN","ERR")

 .I $P(VAL(NUM),U,3)="M"  D

 ..K FDA,IEN,ERR

 ..S FDA=$NA(FDA(100.2101,"+1,"_TEAM_","))

 ..S @FDA@(.01)=$P(VAL(NUM),U,1)_";DPT("

 ..D UPDATE^DIE("","FDA","IEN","ERR")

 Q

GETIEN(NAME) ;Get the IEN of the list

 N IEN

 S IEN="" S IEN=$O(^OR(100.21,"B",NAME,IEN))

 Q IEN

DELLST(DATA,NAME) ;EP

 N TEAM,FDA,FNUM,PRV,DA,DIK,MEM

 Q:'$L(NAME)

 S TEAM=$$GETIEN(NAME)

 S DATA=0

 I '$D(^OR(100.21,TEAM,0)) S DATA(1)="^Not a valid team." Q

 S PRV=0 F  S PRV=$O(^OR(100.21,TEAM,1,PRV)) Q:PRV=""  D

 .S DA(1)=TEAM,DA=PRV

 .S DIK="^OR(100.21,DA(1),1,"

 .S:DA DATA=$$DELETE^BGOUTL(DIK,.DA)

 S MEM=0 F  S MEM=$O(^OR(100.21,TEAM,10,MEM)) Q:MEM=""  D

 .S DA(1)=TEAM,DA=MEM

 .S DIK="^OR(100.21,DA(1),10,"

 .S:DA DATA=$$DELETE^BGOUTL(DIK,.DA)

 I DATA="" S DATA=0

 Q DATA

DELETE(DATA,NAME) ;Delete entire team

 N FNUM,IEN

 K DATA

 Q:'$L(NAME)

 S TEAM=$$GETIEN(NAME)

 S FNUM=100.21,IEN=TEAM

 S DATA=$$DELETE^BGOUTL(FNUM,IEN)

 Q

GETTEAM(DATA) ;Get the teams with this user

 N CNT,IEN,X

 S (CNT,IEN)=0

 F  S IEN=$O(^OR(100.21,"C",DUZ,IEN)) Q:'IEN  D

 .S X=$G(^OR(100.21,IEN,0))

 .S:$P(X,U,2)="TM" CNT=CNT+1,DATA(CNT)=IEN_U_X

 Q

UPPER(X) ; Convert lower case X to UPPER CASE

 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

BEHOPTP3  ;MSC/IND/MGH - Patient List Management ;30-Mar-2012 19:10;DU

 +1       ;;1.1;BEH COMPONENTS;**004004,004008**;Mar 20, 2007

 +2       ;=================================================================

 +3       ; Call logic to manage team lists

MANAGE(DATA,LIST,ACTION,NAME,VAL) ;

 +1        DO EXEC(12)

 +2        QUIT 

 +3       ; Execute logic at specified node

EXEC(NODE) ;

 +1        NEW $ETRAP

 +2        SET $ETRAP=""

           SET @$$TRAP^CIAUOS("EXECERR^BEHOPTPL")

 +3        XECUTE $GET(^BEHOPT(90460.03,+LIST,NODE))

 +4        QUIT 

 +5       ; List management API

MAN2(DATA,LIST,ACTION,NAME,VAL) ;EP

 +1        SET DATA=""

 +2        IF ACTION="S"!(ACTION="P")!(ACTION="D")

               SET DATA(1)=$$VALIDATE(NAME)

 +3        IF ACTION="C"

               SET DATA=$$VALIDATE(NAME,1)

 +4        IF DATA(1)

               QUIT 

 +5        IF ACTION="T"

               DO GETTEAM(.DATA)

               QUIT 

 +6        IF ACTION="P"

               DO GETLST(.DATA,NAME)

               QUIT 

 +7        IF ACTION="C"

               DO CRLST(.DATA,NAME)

               QUIT 

 +8        IF ACTION="S"

               DO SETLST(.DATA,NAME,.VAL)

               QUIT 

 +9        IF ACTION="D"

               DO DELETE(.DATA,NAME)

               QUIT 

 +10       SET DATA(1)="-1^Unknown action"

 +11       QUIT 

 +12      ;Return the list of providers for this list

GETLST(DATA,NAME) ;EP

 +1        NEW CNT,IEN,PRV,QUALS,DATE,PAT

 +2        KILL DATA

 +3        SET DATA(1)="^No Users found."

           SET (CNT,IEN)=0

 +4        SET DATE="TODAY"

           SET DATE=$$DT^CIAU(DATE)

 +5        SET TEAM=$$GETIEN(NAME)

 +6        IF '$DATA(^OR(100.21,TEAM,0))

               SET DATA(1)="^Not a valid team."

               QUIT 

 +7        FOR 

               SET IEN=$ORDER(^OR(100.21,TEAM,1,IEN))

               IF 'IEN

                   QUIT 

               SET PRV=+$GET(^(IEN,0))

               Begin DoDot:1

 +8                SET X=$$ACTIVE^BEHOUSCX(PRV,DATE)

 +9                IF X=1

                       SET CNT=CNT+1

                       SET DATA(CNT)=PRV_U_$PIECE(^VA(200,PRV,0),U)_U_"U"

 +10               IF X=0

                       SET CNT=CNT+1

                       SET DATA(CNT)=PRV_"*"_U_$PIECE(^VA(200,PRV,0),U)_U_"U"

               End DoDot:1

 +11       SET IEN=0

           FOR 

               SET IEN=$ORDER(^OR(100.21,TEAM,10,IEN))

               IF 'IEN

                   QUIT 

               SET PAT=+$GET(^(IEN,0))

               Begin DoDot:1

 +12               SET CNT=CNT+1

                   SET DATA(CNT)=PAT_U_$PIECE(^DPT(PAT,0),U)_U_"M"

               End DoDot:1

 +13       QUIT 

 +14      ; Validate list name

VALIDATE(NAME,DUP) ;

 +1        NEW L

 +2        SET NAME=$$TRIM^CIAU(NAME)

           SET L=$LENGTH(NAME)

           SET DUP=+$GET(DUP)

 +3        IF L<3!(L>30)

               QUIT "-1^List name must be 3-30 characters in length."

 +4        IF NAME'?.(1A,1N,1"_",1" ")

               QUIT "-1^List name contains invalid characters."

 +5        IF DUP

               IF $$GETIEN(NAME)

                   QUIT "-1^List name already exists."

 +6        IF 'DUP

               IF '$$GETIEN(NAME)

                   QUIT "-1^List name not found."

 +7        QUIT ""

CRLST(DATA,NAME) ;EP Create a new team list

 +1        NEW DATE,FNUM,FDA,IEN

 +2        KILL DATA

 +3        SET DATE="TODAY"

           SET DATE=$$DT^CIAU(DATE)

 +4        SET FNUM=100.21

 +5        SET FDA=$NAME(FDA(FNUM,"+1,"))

 +6        SET @FDA@(.01)=NAME

 +7        SET @FDA@(.1)=$$UPPER(NAME)

 +8        SET @FDA@(1)="TM"

 +9        SET @FDA@(1.6)=DUZ

 +10       SET @FDA@(1.65)=DATE

 +11       SET @FDA@(1.7)="Y"

 +12       SET DATA(1)=$$UPDATE^BGOUTL(.FDA,"",.IEN)

 +13       IF 'DATA(1)

               SET DATA(1)=IEN(1)

 +14       IF $DATA(IEN(1))

               Begin DoDot:1

 +15               SET FDA=$NAME(FDA(100.212,"+1,"_IEN(1)_","))

 +16               SET @FDA@(.01)=DUZ

 +17               DO UPDATE^DIE("","FDA","IEN","ERR")

               End DoDot:1

 +18       QUIT 

 +19      ; Set List

SETLST(DATA,NAME,VAL) ;EP

 +1        NEW TEAM,FDA,FNUM,ERR,IEN,CNTU,CNTM,NUM

 +2        KILL DATA

 +3        IF '$LENGTH(NAME)

               QUIT 

 +4        SET TEAM=$$GETIEN(NAME)

 +5        SET CNTU=0

           SET CNTM=0

 +6        IF '$DATA(^OR(100.21,TEAM,0))

               SET DATA(1)="^Not a valid team."

               QUIT 

 +7        DO DELLST(.DATA,NAME)

 +8        SET NUM=""

           FOR 

               SET NUM=$ORDER(VAL(NUM))

               IF NUM=""

                   QUIT 

               Begin DoDot:1

 +9                IF $PIECE(VAL(NUM),U,3)="U"

                       Begin DoDot:2

 +10                       KILL FDA,IEN,ERR

 +11                       SET FDA=$NAME(FDA(100.212,"+1,"_TEAM_","))

 +12                       SET @FDA@(.01)=$PIECE(VAL(NUM),U,1)

 +13                       DO UPDATE^DIE("","FDA","IEN","ERR")

                       End DoDot:2

 +14               IF $PIECE(VAL(NUM),U,3)="M"

                       Begin DoDot:2

 +15                       KILL FDA,IEN,ERR

 +16                       SET FDA=$NAME(FDA(100.2101,"+1,"_TEAM_","))

 +17                       SET @FDA@(.01)=$PIECE(VAL(NUM),U,1)_";DPT("

 +18                       DO UPDATE^DIE("","FDA","IEN","ERR")

                       End DoDot:2

               End DoDot:1

 +19       QUIT 

GETIEN(NAME) ;Get the IEN of the list

 +1        NEW IEN

 +2        SET IEN=""

           SET IEN=$ORDER(^OR(100.21,"B",NAME,IEN))

 +3        QUIT IEN

DELLST(DATA,NAME) ;EP

 +1        NEW TEAM,FDA,FNUM,PRV,DA,DIK,MEM

 +2        IF '$LENGTH(NAME)

               QUIT 

 +3        SET TEAM=$$GETIEN(NAME)

 +4        SET DATA=0

 +5        IF '$DATA(^OR(100.21,TEAM,0))

               SET DATA(1)="^Not a valid team."

               QUIT 

 +6        SET PRV=0

           FOR 

               SET PRV=$ORDER(^OR(100.21,TEAM,1,PRV))

               IF PRV=""

                   QUIT 

               Begin DoDot:1

 +7                SET DA(1)=TEAM

                   SET DA=PRV

 +8                SET DIK="^OR(100.21,DA(1),1,"

 +9                IF DA

                       SET DATA=$$DELETE^BGOUTL(DIK,.DA)

               End DoDot:1

 +10       SET MEM=0

           FOR 

               SET MEM=$ORDER(^OR(100.21,TEAM,10,MEM))

               IF MEM=""

                   QUIT 

               Begin DoDot:1

 +11               SET DA(1)=TEAM

                   SET DA=MEM

 +12               SET DIK="^OR(100.21,DA(1),10,"

 +13               IF DA

                       SET DATA=$$DELETE^BGOUTL(DIK,.DA)

               End DoDot:1

 +14       IF DATA=""

               SET DATA=0

 +15       QUIT DATA

DELETE(DATA,NAME) ;Delete entire team

 +1        NEW FNUM,IEN

 +2        KILL DATA

 +3        IF '$LENGTH(NAME)

               QUIT 

 +4        SET TEAM=$$GETIEN(NAME)

 +5        SET FNUM=100.21

           SET IEN=TEAM

 +6        SET DATA=$$DELETE^BGOUTL(FNUM,IEN)

 +7        QUIT 

GETTEAM(DATA) ;Get the teams with this user

 +1        NEW CNT,IEN,X

 +2        SET (CNT,IEN)=0

 +3        FOR 

               SET IEN=$ORDER(^OR(100.21,"C",DUZ,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +4                SET X=$GET(^OR(100.21,IEN,0))

 +5                IF $PIECE(X,U,2)="TM"

                       SET CNT=CNT+1

                       SET DATA(CNT)=IEN_U_X

               End DoDot:1

 +6        QUIT 

UPPER(X)  ; Convert lower case X to UPPER CASE

 +1        QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")