ORWTPT ; SLC/STAFF Personal Preference - Teams ;05/27/14 18:31
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243,377**;Oct 24, 2000;Build 582
;
; External Reference
; DBIA 1917 $$TPTM^SCAPMC
; DBIA 1917 $$PRTP^SCAPMC
;
GETTEAM(USERS,TEAM) ; RPC
; returns members of a team
N CNT,NAME,NUM,USER K USERS
S TEAM=+$G(TEAM),CNT=0
S NUM=0 F S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1 S USER=+$G(^(NUM,0)) D
.S NAME=$P($G(^VA(200,USER,0)),U)
.I '$L(NAME) Q
.S CNT=CNT+1
.S USERS(CNT)=USER_U_NAME
Q
;
GETPTEAM(MEMBERS,TEAM) ; RPC
; TDP - Added 5/21/2014
; returns members of a team\
; (Should be using $$PRTM^SCAPMC to return team members for a
; specific team. However, it does not work correctly. So, we
; improvised a work around solution.)
N CNT,DATA,NAME,NUM,ORRSLT,POSIEN,SUB,USER
K MEMBERS,^TMP("ORPCMMPOS",$J),^TMP("SCERR",$J)
S TEAM=+$G(TEAM)
; Get list of team positions for specified team
S ORRSLT=$$TPTM^SCAPMC(TEAM,,,,"^TMP(""ORPCMMPOS"",$J)",)
I '$D(^TMP("ORPCMMPOS",$J)) Q
S CNT=0
S NUM=0
F S NUM=$O(^TMP("ORPCMMPOS",$J,NUM)) Q:NUM<1 D
. K ^TMP("ORPCMMBRS",$J),^TMP("SCERR",$J)
. S POSIEN=+$G(^TMP("ORPCMMPOS",$J,NUM))
. ; Get list of team members occupying team positions
. S ORRSLT=$$PRTP^SCAPMC(POSIEN,,"^TMP(""ORPCMMBRS"",$J)",,0,0)
. I ORRSLT=0 Q
. S SUB=0
. F S SUB=$O(^TMP("ORPCMMBRS",$J,SUB)) Q:SUB<1 D
.. S DATA=$P(^TMP("ORPCMMBRS",$J,SUB),U,1,2)
.. I $P(DATA,U,2)="" Q ;No name, so quit
.. S CNT=CNT+1
.. S MEMBERS(CNT)=DATA
K ^TMP("ORPCMMBRS",$J),^TMP("ORPCMMPOS",$J),^TMP("SCERR",$J)
Q
;
TEAMS(TEAMS,USER) ; from ORWTPP
; returns all teams a user is a member of (exculdes personal lists)
N CNT,NUM,ZERO K TEAMS
S USER=+$G(USER),CNT=0
S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D
.S ZERO=$G(^OR(100.21,NUM,0))
.I $P(ZERO,U,2)="P" Q
.S CNT=CNT+1
.S TEAMS(CNT)=NUM_U_ZERO
Q
;
PLISTS(TEAMS,USER) ; from ORWTPP
; returns a user's personal lists
N CNT,NUM,ZERO K TEAMS
S USER=+$G(USER),CNT=0
S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D
.S ZERO=$G(^OR(100.21,NUM,0))
.I $P(ZERO,U,2)'="P" Q
.S CNT=CNT+1
.N VIS S VIS=$P($G(^OR(100.21,NUM,11)),U)
.I '$L(VIS) S VIS=1
.S TEAMS(CNT)=NUM_U_ZERO_U_VIS
Q
;
PLTEAMS(TEAMS,USER) ; from ORWTPP
; returns all teams and personal lists for a user
N CNT,NUM,ZERO K TEAMS
S USER=+$G(USER),CNT=0
S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D
.S ZERO=$G(^OR(100.21,NUM,0))
.S CNT=CNT+1
.S TEAMS(CNT)=NUM_U_ZERO
Q
;
PCMTEAMS(TEAMS,USER) ; from ORWTPP
; TDP - Added 5/21/2014
; returns all PCMM teams for a user
N CNT,DATA,NUM,UNAME K TEAMS
S USER=+$G(USER),CNT=0
D PTEAMPR^ORQPTQ1(.TEAMS,USER)
I TEAMS(1)="^No PCMM teams found." Q
S NUM=0 F S NUM=$O(TEAMS(NUM)) Q:NUM="" D
. S DATA=$P(TEAMS(NUM),U,1,2)
. S UNAME=$$UP^XLFSTR($P(DATA,U,2))
. S TEAMS(NUM)=DATA_"^E^"_UNAME_"^^^^"
Q
;
ATEAMS(TEAMS) ; RPC
; all teams available to subscribe to
N CNT,NAME,NODE,NUM K TEAMS
S CNT=0
S NUM=0 F S NUM=$O(^OR(100.21,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D
.I $P(NODE,U,6)'="Y" Q
.I $P(NODE,U,2)="P" Q
.S CNT=CNT+1
.S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U)
Q
;
ADDLIST(OK,VALUE,USER) ; from ORWTPP
; adds a user to a team
N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO
S USER=+$G(USER)
S DA=USER,DA(1)=+$G(VALUE),OK=1
I '$D(^OR(100.21,DA(1),0)) Q
S DIC(0)="LM"
S DLAYGO=100.212
S X=$P($G(^VA(200,USER,0)),U)
S DIC="^OR(100.21,"_DA(1)_",1,"
D
.L +^OR(100.21,DA(1)):5 I '$T Q
.D ^DIC
.L -^OR(100.21,DA(1))
I Y=-1 S OK=0
K DA,DIC,DLAYGO
Q
;
REMLIST(OK,VALUE,USER) ; from ORWTPP
; removes a user from a team
N DA,DIK K DA
S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1
I '$D(^OR(100.21,DA(1),0)) Q
S DIK="^OR(100.21,"_DA(1)_",1,"
D
.L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q
.D ^DIK
.L -^OR(100.21,DA(1))
K DA,DIK
Q
;
GETCOMBO(VALUES,USER) ; from ORWTPP
; get user's combo list definition
N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES
S USER=+$G(USER)
I '$D(^OR(100.24,USER,0)) Q
S CNT=0
S NUM=0 F S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D
.I '$L(NODE) Q
.S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME=""
.D
..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q
..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q
..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q
..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q
..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q
..I SOURCE="SCTM(404.51," D
...S SOURCE="PCMM"
...N DIC,DLAYGO,X,Y
...S DIC="^SCTM(404.51,"
...S DIC(0)=""
...S X="`"_IEN
...D ^DIC
...S NAME=$P(Y,U,2)
.I '$L(NAME) Q
.S CNT=CNT+1
.S VALUES(CNT)=SOURCE_U_NAME_U_IEN
Q
;
SETCOMBO(OK,VALUES,USER) ; from ORWTPP
; set user's combo list definition
N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES
S USER=+$G(USER),OK=1
I 'USER Q
S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D
.S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE=""
.I 'IEN Q
.I SOURCENM="WARD" S SOURCE=";DIC(42,"
.I SOURCENM="PROVIDER" S SOURCE=";VA(200,"
.I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7,"
.I SOURCENM="LIST" S SOURCE=";OR(100.21,"
.I SOURCENM="PCMM" S SOURCE=";SCTM(404.51,"
.I SOURCENM="CLINIC" S SOURCE=";SC("
.I '$L(SOURCE) Q
.S NVALUES(NUM)=IEN_SOURCE
I '$D(^OR(100.24,USER,0)) D I '$D(^OR(100.24,USER,0)) Q
.L +^OR(100.24,0):5 I '$T S OK=0 Q
.S ^OR(100.24,USER,0)=USER
.S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER
.L -^OR(100.24,0)
S CNT=0,DA=USER,DIK="^OR(100.24,"
L +^OR(100.24,USER,0):5 I '$T Q
K ^OR(100.24,USER,.01)
S NUM=0 F S NUM=$O(NVALUES(NUM)) Q:NUM<1 D
.S CNT=CNT+1
.S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM)
S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT
D IX1^DIK
L -^OR(100.24,USER,0)
K NVALUES
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWTPT 5988 printed Apr 09, 2024@21:44:20 Page 2
ORWTPT ; SLC/STAFF Personal Preference - Teams ;05/27/14 18:31
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243,377**;Oct 24, 2000;Build 582
+2 ;
+3 ; External Reference
+4 ; DBIA 1917 $$TPTM^SCAPMC
+5 ; DBIA 1917 $$PRTP^SCAPMC
+6 ;
GETTEAM(USERS,TEAM) ; RPC
+1 ; returns members of a team
+2 NEW CNT,NAME,NUM,USER
KILL USERS
+3 SET TEAM=+$GET(TEAM)
SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.21,TEAM,1,NUM))
if NUM<1
QUIT
SET USER=+$GET(^(NUM,0))
Begin DoDot:1
+5 SET NAME=$PIECE($GET(^VA(200,USER,0)),U)
+6 IF '$LENGTH(NAME)
QUIT
+7 SET CNT=CNT+1
+8 SET USERS(CNT)=USER_U_NAME
End DoDot:1
+9 QUIT
+10 ;
GETPTEAM(MEMBERS,TEAM) ; RPC
+1 ; TDP - Added 5/21/2014
+2 ; returns members of a team\
+3 ; (Should be using $$PRTM^SCAPMC to return team members for a
+4 ; specific team. However, it does not work correctly. So, we
+5 ; improvised a work around solution.)
+6 NEW CNT,DATA,NAME,NUM,ORRSLT,POSIEN,SUB,USER
+7 KILL MEMBERS,^TMP("ORPCMMPOS",$JOB),^TMP("SCERR",$JOB)
+8 SET TEAM=+$GET(TEAM)
+9 ; Get list of team positions for specified team
+10 SET ORRSLT=$$TPTM^SCAPMC(TEAM,,,,"^TMP(""ORPCMMPOS"",$J)",)
+11 IF '$DATA(^TMP("ORPCMMPOS",$JOB))
QUIT
+12 SET CNT=0
+13 SET NUM=0
+14 FOR
SET NUM=$ORDER(^TMP("ORPCMMPOS",$JOB,NUM))
if NUM<1
QUIT
Begin DoDot:1
+15 KILL ^TMP("ORPCMMBRS",$JOB),^TMP("SCERR",$JOB)
+16 SET POSIEN=+$GET(^TMP("ORPCMMPOS",$JOB,NUM))
+17 ; Get list of team members occupying team positions
+18 SET ORRSLT=$$PRTP^SCAPMC(POSIEN,,"^TMP(""ORPCMMBRS"",$J)",,0,0)
+19 IF ORRSLT=0
QUIT
+20 SET SUB=0
+21 FOR
SET SUB=$ORDER(^TMP("ORPCMMBRS",$JOB,SUB))
if SUB<1
QUIT
Begin DoDot:2
+22 SET DATA=$PIECE(^TMP("ORPCMMBRS",$JOB,SUB),U,1,2)
+23 ;No name, so quit
IF $PIECE(DATA,U,2)=""
QUIT
+24 SET CNT=CNT+1
+25 SET MEMBERS(CNT)=DATA
End DoDot:2
End DoDot:1
+26 KILL ^TMP("ORPCMMBRS",$JOB),^TMP("ORPCMMPOS",$JOB),^TMP("SCERR",$JOB)
+27 QUIT
+28 ;
TEAMS(TEAMS,USER) ; from ORWTPP
+1 ; returns all teams a user is a member of (exculdes personal lists)
+2 NEW CNT,NUM,ZERO
KILL TEAMS
+3 SET USER=+$GET(USER)
SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.21,"C",USER,NUM))
if NUM<1
QUIT
Begin DoDot:1
+5 SET ZERO=$GET(^OR(100.21,NUM,0))
+6 IF $PIECE(ZERO,U,2)="P"
QUIT
+7 SET CNT=CNT+1
+8 SET TEAMS(CNT)=NUM_U_ZERO
End DoDot:1
+9 QUIT
+10 ;
PLISTS(TEAMS,USER) ; from ORWTPP
+1 ; returns a user's personal lists
+2 NEW CNT,NUM,ZERO
KILL TEAMS
+3 SET USER=+$GET(USER)
SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.21,"C",USER,NUM))
if NUM<1
QUIT
Begin DoDot:1
+5 SET ZERO=$GET(^OR(100.21,NUM,0))
+6 IF $PIECE(ZERO,U,2)'="P"
QUIT
+7 SET CNT=CNT+1
+8 NEW VIS
SET VIS=$PIECE($GET(^OR(100.21,NUM,11)),U)
+9 IF '$LENGTH(VIS)
SET VIS=1
+10 SET TEAMS(CNT)=NUM_U_ZERO_U_VIS
End DoDot:1
+11 QUIT
+12 ;
PLTEAMS(TEAMS,USER) ; from ORWTPP
+1 ; returns all teams and personal lists for a user
+2 NEW CNT,NUM,ZERO
KILL TEAMS
+3 SET USER=+$GET(USER)
SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.21,"C",USER,NUM))
if NUM<1
QUIT
Begin DoDot:1
+5 SET ZERO=$GET(^OR(100.21,NUM,0))
+6 SET CNT=CNT+1
+7 SET TEAMS(CNT)=NUM_U_ZERO
End DoDot:1
+8 QUIT
+9 ;
PCMTEAMS(TEAMS,USER) ; from ORWTPP
+1 ; TDP - Added 5/21/2014
+2 ; returns all PCMM teams for a user
+3 NEW CNT,DATA,NUM,UNAME
KILL TEAMS
+4 SET USER=+$GET(USER)
SET CNT=0
+5 DO PTEAMPR^ORQPTQ1(.TEAMS,USER)
+6 IF TEAMS(1)="^No PCMM teams found."
QUIT
+7 SET NUM=0
FOR
SET NUM=$ORDER(TEAMS(NUM))
if NUM=""
QUIT
Begin DoDot:1
+8 SET DATA=$PIECE(TEAMS(NUM),U,1,2)
+9 SET UNAME=$$UP^XLFSTR($PIECE(DATA,U,2))
+10 SET TEAMS(NUM)=DATA_"^E^"_UNAME_"^^^^"
End DoDot:1
+11 QUIT
+12 ;
ATEAMS(TEAMS) ; RPC
+1 ; all teams available to subscribe to
+2 NEW CNT,NAME,NODE,NUM
KILL TEAMS
+3 SET CNT=0
+4 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.21,NUM))
if NUM<1
QUIT
SET NODE=$GET(^(NUM,0))
Begin DoDot:1
+5 IF $PIECE(NODE,U,6)'="Y"
QUIT
+6 IF $PIECE(NODE,U,2)="P"
QUIT
+7 SET CNT=CNT+1
+8 ;$P(NODE,U)
SET TEAMS(CNT)=NUM_U_NODE
End DoDot:1
+9 QUIT
+10 ;
ADDLIST(OK,VALUE,USER) ; from ORWTPP
+1 ; adds a user to a team
+2 NEW DA,DIC,DLAYGO,X,Y
KILL DA,DIC,DLAYGO
+3 SET USER=+$GET(USER)
+4 SET DA=USER
SET DA(1)=+$GET(VALUE)
SET OK=1
+5 IF '$DATA(^OR(100.21,DA(1),0))
QUIT
+6 SET DIC(0)="LM"
+7 SET DLAYGO=100.212
+8 SET X=$PIECE($GET(^VA(200,USER,0)),U)
+9 SET DIC="^OR(100.21,"_DA(1)_",1,"
+10 Begin DoDot:1
+11 LOCK +^OR(100.21,DA(1)):5
IF '$TEST
QUIT
+12 DO ^DIC
+13 LOCK -^OR(100.21,DA(1))
End DoDot:1
+14 IF Y=-1
SET OK=0
+15 KILL DA,DIC,DLAYGO
+16 QUIT
+17 ;
REMLIST(OK,VALUE,USER) ; from ORWTPP
+1 ; removes a user from a team
+2 NEW DA,DIK
KILL DA
+3 SET DA=+$GET(USER)
SET DA(1)=+$GET(VALUE)
SET OK=1
+4 IF '$DATA(^OR(100.21,DA(1),0))
QUIT
+5 SET DIK="^OR(100.21,"_DA(1)_",1,"
+6 Begin DoDot:1
+7 LOCK +^OR(100.21,DA(1)):5
IF '$TEST
SET OK=0
QUIT
+8 DO ^DIK
+9 LOCK -^OR(100.21,DA(1))
End DoDot:1
+10 KILL DA,DIK
+11 QUIT
+12 ;
GETCOMBO(VALUES,USER) ; from ORWTPP
+1 ; get user's combo list definition
+2 NEW CNT,IEN,NAME,NODE,NUM,SOURCE
KILL VALUES
+3 SET USER=+$GET(USER)
+4 IF '$DATA(^OR(100.24,USER,0))
QUIT
+5 SET CNT=0
+6 SET NUM=0
FOR
SET NUM=$ORDER(^OR(100.24,USER,.01,NUM))
if NUM<1
QUIT
SET NODE=$GET(^(NUM,0))
Begin DoDot:1
+7 IF '$LENGTH(NODE)
QUIT
+8 SET IEN=+NODE
SET SOURCE=$PIECE(NODE,";",2)
SET NAME=""
+9 Begin DoDot:2
+10 IF SOURCE="DIC(42,"
SET SOURCE="WARD"
SET NAME=$PIECE($GET(^DIC(42,IEN,0)),U)
QUIT
+11 IF SOURCE="VA(200,"
SET SOURCE="PROVIDER"
SET NAME=$PIECE($GET(^VA(200,IEN,0)),U)
QUIT
+12 IF SOURCE="DIC(45.7,"
SET SOURCE="SPECIALTY"
SET NAME=$PIECE($GET(^DIC(45.7,IEN,0)),U)
QUIT
+13 IF SOURCE="OR(100.21,"
SET SOURCE="LIST"
SET NAME=$PIECE($GET(^OR(100.21,IEN,0)),U)
QUIT
+14 IF SOURCE="SC("
SET SOURCE="CLINIC"
SET NAME=$PIECE($GET(^SC(IEN,0)),U)
QUIT
+15 IF SOURCE="SCTM(404.51,"
Begin DoDot:3
+16 SET SOURCE="PCMM"
+17 NEW DIC,DLAYGO,X,Y
+18 SET DIC="^SCTM(404.51,"
+19 SET DIC(0)=""
+20 SET X="`"_IEN
+21 DO ^DIC
+22 SET NAME=$PIECE(Y,U,2)
End DoDot:3
End DoDot:2
+23 IF '$LENGTH(NAME)
QUIT
+24 SET CNT=CNT+1
+25 SET VALUES(CNT)=SOURCE_U_NAME_U_IEN
End DoDot:1
+26 QUIT
+27 ;
SETCOMBO(OK,VALUES,USER) ; from ORWTPP
+1 ; set user's combo list definition
+2 NEW CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM
KILL NVALUES
+3 SET USER=+$GET(USER)
SET OK=1
+4 IF 'USER
QUIT
+5 SET NUM=0
FOR
SET NUM=$ORDER(VALUES(NUM))
if NUM<1
QUIT
Begin DoDot:1
+6 SET IEN=+VALUES(NUM)
SET SOURCENM=$$UP^XLFSTR($PIECE(VALUES(NUM),U,2))
SET SOURCE=""
+7 IF 'IEN
QUIT
+8 IF SOURCENM="WARD"
SET SOURCE=";DIC(42,"
+9 IF SOURCENM="PROVIDER"
SET SOURCE=";VA(200,"
+10 IF SOURCENM="SPECIALTY"
SET SOURCE=";DIC(45.7,"
+11 IF SOURCENM="LIST"
SET SOURCE=";OR(100.21,"
+12 IF SOURCENM="PCMM"
SET SOURCE=";SCTM(404.51,"
+13 IF SOURCENM="CLINIC"
SET SOURCE=";SC("
+14 IF '$LENGTH(SOURCE)
QUIT
+15 SET NVALUES(NUM)=IEN_SOURCE
End DoDot:1
+16 IF '$DATA(^OR(100.24,USER,0))
Begin DoDot:1
+17 LOCK +^OR(100.24,0):5
IF '$TEST
SET OK=0
QUIT
+18 SET ^OR(100.24,USER,0)=USER
+19 SET $PIECE(^OR(100.24,0),U,4)=$PIECE(^OR(100.24,0),U,4)+1
SET $PIECE(^(0),U,3)=USER
+20 LOCK -^OR(100.24,0)
End DoDot:1
IF '$DATA(^OR(100.24,USER,0))
QUIT
+21 SET CNT=0
SET DA=USER
SET DIK="^OR(100.24,"
+22 LOCK +^OR(100.24,USER,0):5
IF '$TEST
QUIT
+23 KILL ^OR(100.24,USER,.01)
+24 SET NUM=0
FOR
SET NUM=$ORDER(NVALUES(NUM))
if NUM<1
QUIT
Begin DoDot:1
+25 SET CNT=CNT+1
+26 SET ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM)
End DoDot:1
+27 SET ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT
+28 DO IX1^DIK
+29 LOCK -^OR(100.24,USER,0)
+30 KILL NVALUES
+31 QUIT
