CRHD10 ; CAIRO/CLC - ASSIGN PROVIDERS TO A TEAM LIST ;04-Mar-2008 16:00;CLC
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
TMDELAPV(CRHDRTN,CRHDTM) ;
;delete all providers from list, delete entry.
N DA,DIK
K CRHDRTN
S CRHDRTN=0
I +CRHDTM S DIK="^CRHD(183.4,",DA=+CRHDTM D ^DIK S CRHDRTN=1
Q
TMLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a team
N CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
N CRHDI,CRHDTM6,CRHDPNAM
K CRHDRTN
S CRHDRTN(1)="No list found"
Q:'CRHDTM
Q:$P($G(CRHDTM),"^",2)=""
I '$D(^CRHD(183.4,"B",$P(CRHDTM,"^",2))) Q
S CRHDTM6=$O(^CRHD(183.4,"B",$P(CRHDTM,"^",2),0))
I 'CRHDTM6 S CRHDRTN(1)=0 Q
S CRHDX=0
F S CRHDX=$O(^CRHD(183.4,+CRHDTM6,1,CRHDX)) Q:'CRHDX D
.S CRHDPRV=+$G(^CRHD(183.4,+CRHDTM6,1,CRHDX,0))
.S CRHDPNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
.I CRHDPNAM'="" D
..S CRHDZ0=$G(^CRHD(183.4,+CRHDTM6,1,+CRHDX,0))
..S CRHDUT=$P(CRHDZ0,"^",2)
..I CRHDUT="" S CRHDUT="ZNOTYPE"
..S CRHDSORT(CRHDUT,CRHDPNAM)=CRHDPRV_"^"_CRHDPNAM_"^"_$P(CRHDZ0,"^",2)_"^"_$P(CRHDZ0,"^",3)_"^"_$P(CRHDZ0,"^",4)
S CRHDI=""
F S CRHDI=$O(CRHDSORT(CRHDI)) Q:CRHDI="" D
.S CRHDPRV=""
.F S CRHDPRV=$O(CRHDSORT(CRHDI,CRHDPRV)) Q:CRHDPRV="" D
..S CRHDTLST(CRHDPRV)=CRHDSORT(CRHDI,CRHDPRV)
I $D(CRHDTLST) D
.S CRHDCT=0
.S CRHDX=""
.F S CRHDX=$O(CRHDTLST(CRHDX)) Q:CRHDX="" S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
Q
TMPRVINF(CRHDRTN,CRHDTM,CRHDPHY) ;
;return user information
N CRHDPRV,CRHDZ0,CRHDMGR,CRHDMN,CRHDPNAM
Q:CRHDTM=""
S CRHDMN=$O(^CRHD(183.4,"B",$P(CRHDTM,"^",2),0))
S CRHDPRV=$O(^CRHD(183.4,+CRHDMN,1,"B",+CRHDPHY,0))
I 'CRHDPRV Q
S CRHDZ0=$G(^CRHD(183.4,+CRHDMN,1,+CRHDPRV,0))
S CRHDPNAM=$$GET1^DIQ(200,+CRHDZ0,.01,"E")
S CRHDRTN=$P(CRHDZ0,"^",1)_"^"_CRHDPNAM_"^"_$P(CRHDZ0,"^",2)_"^^^"_$P(CRHDZ0,"^",3,99)
Q
TMMOD(CRHDRTN,CRHDTM,CRHDTXT,CRHDKFG) ;
N CRHDX,CRHDFDA,CRHDOUT,CRHDERR,CRHDMN,CRHDPG,CRHDPL,CRHDOP
K CRHDRTN
S CRHDRTN(0)=0
I '$D(^CRHD(183.4,"B",$P(CRHDTM,"^",2),+CRHDTM)) D
.S CRHDFDA(183.4,"?+1,",.01)=$P(CRHDTM,"^",2)
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
A .I '$D(CRHDERR) S CRHDMN=CRHDOUT(1) K CRHDFDA,CRHDOUT
Q:'CRHDMN
K:CRHDKFG ^CRHD(183.4,CRHDMN,1)
S CRHDX=0
F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
.S CRHDPL=$L(CRHDTXT(CRHDX),"^"),CRHDPG=$P(CRHDTXT(CRHDX),"^",CRHDPL)
.S CRHDOP=$P(CRHDTXT(CRHDX),"^",CRHDPL-1)
.S CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",.01)=$P(CRHDTXT(CRHDX),"^",1)
.S CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",1)=$P(CRHDTXT(CRHDX),"^",3)
.S CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",2)=CRHDOP
.S CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",3)=CRHDPG
D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
I '$D(CRHDERR) S CRHDRTN(0)=1
E S CRHDRTN(1)=1
K CRHDFDA,CRHDOUT,CRHDERR
Q
TMCOMB(CRHDRTN) ;return list of teams for a user with a combination list
N CRHDS,CRHDF,CRHDFN,CRHDSRC,CRHDCT
Q:'$G(DUZ)
S CRHDCT=0
S CRHDSRC=0
F S CRHDSRC=$O(^OR(100.24,DUZ,.01,CRHDSRC)) Q:'CRHDSRC D
.S CRHDS=$G(^OR(100.24,DUZ,.01,CRHDSRC,0))
.I CRHDS D
..S CRHDFN=+$P($P(CRHDS,";",2),"(",2)
..S CRHDF=+CRHDS
..S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDS_"^"_$$GET1^DIQ(CRHDFN,CRHDF,.01,"E")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD10 3296 printed Nov 22, 2024@17:47:39 Page 2
CRHD10 ; CAIRO/CLC - ASSIGN PROVIDERS TO A TEAM LIST ;04-Mar-2008 16:00;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
TMDELAPV(CRHDRTN,CRHDTM) ;
+1 ;delete all providers from list, delete entry.
+2 NEW DA,DIK
+3 KILL CRHDRTN
+4 SET CRHDRTN=0
+5 IF +CRHDTM
SET DIK="^CRHD(183.4,"
SET DA=+CRHDTM
DO ^DIK
SET CRHDRTN=1
+6 QUIT
TMLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a team
+1 NEW CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
+2 NEW CRHDI,CRHDTM6,CRHDPNAM
+3 KILL CRHDRTN
+4 SET CRHDRTN(1)="No list found"
+5 if 'CRHDTM
QUIT
+6 if $PIECE($GET(CRHDTM),"^",2)=""
QUIT
+7 IF '$DATA(^CRHD(183.4,"B",$PIECE(CRHDTM,"^",2)))
QUIT
+8 SET CRHDTM6=$ORDER(^CRHD(183.4,"B",$PIECE(CRHDTM,"^",2),0))
+9 IF 'CRHDTM6
SET CRHDRTN(1)=0
QUIT
+10 SET CRHDX=0
+11 FOR
SET CRHDX=$ORDER(^CRHD(183.4,+CRHDTM6,1,CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+12 SET CRHDPRV=+$GET(^CRHD(183.4,+CRHDTM6,1,CRHDX,0))
+13 SET CRHDPNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
+14 IF CRHDPNAM'=""
Begin DoDot:2
+15 SET CRHDZ0=$GET(^CRHD(183.4,+CRHDTM6,1,+CRHDX,0))
+16 SET CRHDUT=$PIECE(CRHDZ0,"^",2)
+17 IF CRHDUT=""
SET CRHDUT="ZNOTYPE"
+18 SET CRHDSORT(CRHDUT,CRHDPNAM)=CRHDPRV_"^"_CRHDPNAM_"^"_$PIECE(CRHDZ0,"^",2)_"^"_$PIECE(CRHDZ0,"^",3)_"^"_$PIECE(CRHDZ0,"^",4)
End DoDot:2
End DoDot:1
+19 SET CRHDI=""
+20 FOR
SET CRHDI=$ORDER(CRHDSORT(CRHDI))
if CRHDI=""
QUIT
Begin DoDot:1
+21 SET CRHDPRV=""
+22 FOR
SET CRHDPRV=$ORDER(CRHDSORT(CRHDI,CRHDPRV))
if CRHDPRV=""
QUIT
Begin DoDot:2
+23 SET CRHDTLST(CRHDPRV)=CRHDSORT(CRHDI,CRHDPRV)
End DoDot:2
End DoDot:1
+24 IF $DATA(CRHDTLST)
Begin DoDot:1
+25 SET CRHDCT=0
+26 SET CRHDX=""
+27 FOR
SET CRHDX=$ORDER(CRHDTLST(CRHDX))
if CRHDX=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
End DoDot:1
+28 QUIT
TMPRVINF(CRHDRTN,CRHDTM,CRHDPHY) ;
+1 ;return user information
+2 NEW CRHDPRV,CRHDZ0,CRHDMGR,CRHDMN,CRHDPNAM
+3 if CRHDTM=""
QUIT
+4 SET CRHDMN=$ORDER(^CRHD(183.4,"B",$PIECE(CRHDTM,"^",2),0))
+5 SET CRHDPRV=$ORDER(^CRHD(183.4,+CRHDMN,1,"B",+CRHDPHY,0))
+6 IF 'CRHDPRV
QUIT
+7 SET CRHDZ0=$GET(^CRHD(183.4,+CRHDMN,1,+CRHDPRV,0))
+8 SET CRHDPNAM=$$GET1^DIQ(200,+CRHDZ0,.01,"E")
+9 SET CRHDRTN=$PIECE(CRHDZ0,"^",1)_"^"_CRHDPNAM_"^"_$PIECE(CRHDZ0,"^",2)_"^^^"_$PIECE(CRHDZ0,"^",3,99)
+10 QUIT
TMMOD(CRHDRTN,CRHDTM,CRHDTXT,CRHDKFG) ;
+1 NEW CRHDX,CRHDFDA,CRHDOUT,CRHDERR,CRHDMN,CRHDPG,CRHDPL,CRHDOP
+2 KILL CRHDRTN
+3 SET CRHDRTN(0)=0
+4 IF '$DATA(^CRHD(183.4,"B",$PIECE(CRHDTM,"^",2),+CRHDTM))
Begin DoDot:1
+5 SET CRHDFDA(183.4,"?+1,",.01)=$PIECE(CRHDTM,"^",2)
+6 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
A IF '$DATA(CRHDERR)
SET CRHDMN=CRHDOUT(1)
KILL CRHDFDA,CRHDOUT
End DoDot:1
+1 if 'CRHDMN
QUIT
+2 if CRHDKFG
KILL ^CRHD(183.4,CRHDMN,1)
+3 SET CRHDX=0
+4 FOR
SET CRHDX=$ORDER(CRHDTXT(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+5 SET CRHDPL=$LENGTH(CRHDTXT(CRHDX),"^")
SET CRHDPG=$PIECE(CRHDTXT(CRHDX),"^",CRHDPL)
+6 SET CRHDOP=$PIECE(CRHDTXT(CRHDX),"^",CRHDPL-1)
+7 SET CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",.01)=$PIECE(CRHDTXT(CRHDX),"^",1)
+8 SET CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",1)=$PIECE(CRHDTXT(CRHDX),"^",3)
+9 SET CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",2)=CRHDOP
+10 SET CRHDFDA(183.41,"?+"_(CRHDX+1)_","_+CRHDMN_","_"",3)=CRHDPG
End DoDot:1
+11 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+12 IF '$DATA(CRHDERR)
SET CRHDRTN(0)=1
+13 IF '$TEST
SET CRHDRTN(1)=1
+14 KILL CRHDFDA,CRHDOUT,CRHDERR
+15 QUIT
TMCOMB(CRHDRTN) ;return list of teams for a user with a combination list
+1 NEW CRHDS,CRHDF,CRHDFN,CRHDSRC,CRHDCT
+2 if '$GET(DUZ)
QUIT
+3 SET CRHDCT=0
+4 SET CRHDSRC=0
+5 FOR
SET CRHDSRC=$ORDER(^OR(100.24,DUZ,.01,CRHDSRC))
if 'CRHDSRC
QUIT
Begin DoDot:1
+6 SET CRHDS=$GET(^OR(100.24,DUZ,.01,CRHDSRC,0))
+7 IF CRHDS
Begin DoDot:2
+8 SET CRHDFN=+$PIECE($PIECE(CRHDS,";",2),"(",2)
+9 SET CRHDF=+CRHDS
+10 SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDS_"^"_$$GET1^DIQ(CRHDFN,CRHDF,.01,"E")
End DoDot:2
End DoDot:1
+11 QUIT
