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")
