CRHD9 ; CAIRO/CLC - HANDOFF TEAM LIST ;4/24/08 12:49
;;1.0;CRHD;**2,7**;Jan 28, 2008;Build 1
;=================================================================
;04/22/2009 BAY/KAM CRHD*1*2 Remedy Call 264027 Correct Issue of not
; being able to display/print patients
; with identical names
HOTMSAVE(CRHDRTN,CRHDTM) ;
;create a team name
N CRHDFDA,CRHDOUT,CRHDERR
K CRHDRTN
S CRHDRTN=0
I (CRHDTM'?1A.E)&(CRHDTM'?1N.E) Q
S CRHDFDA(183.3,"?+1,",.01)=CRHDTM
D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
I '$D(CRHDERR) S CRHDRTN=CRHDOUT(1)
Q
HOTMDEL(CRHDRTN,CRHDTM) ;
;delete a Hand off team
N DIK,DA
K CRHDRTN
S CRHDRTN=0
I +CRHDTM S DIK="^CRHD(183.3,",DA=+CRHDTM D ^DIK S CRHDRTN=1
Q
HOLIST(CRHDRTN) ;
;return a list of teams
N CRHDX,CRHDX1,CRHDTDT,CRHDCT
K CRHDRTN
S CRHDX=""
S CRHDCT=0
S CRHDRTN(0)="0^No List Found"
F S CRHDX=$O(^CRHD(183.3,"B",CRHDX)) Q:CRHDX="" D
.S CRHDX1=0
.F S CRHDX1=$O(^CRHD(183.3,"B",CRHDX,CRHDX1)) Q:'CRHDX1 D
..;check to see if team list is active, if date is less then today then inactive
..S CRHDTDT=$P($G(^CRHD(183.3,CRHDX1,0)),"^",2)
..I CRHDTDT&(CRHDTDT<$$DT^XLFDT) Q
..S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDX1_"^"_CRHDX_"^"_"HOTEAM"
I CRHDCT>0 K CRHDRTN(0)
Q
HOPLIST(CRHDRTN,CRHDTM) ;
;Get list of Patients for a HO team
N CRHDX,CRHDPT,CRHDPD,CRHDTLST,CRHDCT,CRHDPD2,VAIP,DFN,DIE,DA,DR
K CRHDRTN
;p.7 HPS/MWA "No Patients Found" is expected to be in the second piece...added "^"
S CRHDRTN(1)="^No Patients Found"
Q:'CRHDTM
I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
S CRHDX=0
F S CRHDX=$O(^CRHD(183.3,+CRHDTM,1,CRHDX)) Q:'CRHDX D
.S CRHDPT=+$G(^CRHD(183.3,+CRHDTM,1,CRHDX,0))
.;check to see if patient has been discharged, if so delete from list
.S DFN=CRHDPT D IN5^VADPT
.I VAIP(1)="" D Q
..S DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",1,",DA=CRHDX,DR=".01///@" D ^DIE
.S CRHDPD=$$PATDATA(CRHDPT)
.K CRHDPD2
.D PATPRV(.CRHDPD2,CRHDTM,CRHDPT)
. ;04/22/2009 BAY/KAM CRHD*1*2 Remedy Call 264027 Concatenated the
. ; patient IEN to the subscript for
. ; uniqueness in the next two lines
. I $P(CRHDPD,"^",1)'="" S CRHDTLST($P(CRHDPD,"^",2)_$P(CRHDPD,"^",1))=CRHDPD
. ;I $P(CRHDPD,"^",1)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDPD ; ORIGINAL CODE
. I $G(CRHDPD2)'="" S CRHDTLST($P(CRHDPD,"^",2)_$P(CRHDPD,"^",1))=CRHDTLST($P(CRHDPD,"^",2)_$P(CRHDPD,"^",1))_"^*"_CRHDPD2
. ;I $G(CRHDPD2)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDTLST($P(CRHDPD,"^",2))_"^*"_CRHDPD2 ; ORIGINAL CODE
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
PATDATA(DFN) ;
;
N CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE,CRHDSEX,VAIP,VADM
K VAIP,VADM
D DEM^VADPT,IN5^VADPT
S CRHDNAME=VADM(1),CRHDSSN=$P(VADM(2),U,1),CRHDDOB=$P(VADM(3),U,1)
S CRHDAGE=VADM(4),CRHDSEX=$P(VADM(5),U,1)
K VAIP,VADM
Q DFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
;
HODLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a HO team
N CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
N CRHDPX,CRHDPX0,CRHDNAM
K CRHDRTN
I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
S CRHDX=0
F S CRHDX=$O(^CRHD(183.3,+CRHDTM,2,CRHDX)) Q:'CRHDX D
.S CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
.S CRHDNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
.;Delete Provider if inactive, 1st check to see if assigned to a patient, if so remove
.I '$$ACTIVE^XUSER(+CRHDPRV) D Q
..S CRHDPX=0 F S CRHDPX=$O(^CRHD(183.3,+CRHDTM,1,CRHDPX)) Q:'CRHDPX D
...S CRHDPX0=^CRHD(183.3,+CRHDTM,1,CRHDPX,0)
...I CRHDPX0[+CRHDPRV F CRHDI=2:1:$L(CRHDPX0,"^") I $P(CRHDPX0,"^",CRHDI)=+CRHDPRV S $P(^CRHD(183.3,+CRHDTM,1,CRHDPX,0),"^",CRHDI)=""
..S DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",2,",DA=CRHDX,DR=".01///@" D ^DIE
.I CRHDNAM'="" D
..S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDX,0))
..S CRHDUT=$P(CRHDZ0,"^",2)
..I CRHDUT="" S CRHDUT="ZNOTYPE"
..S CRHDSORT(CRHDUT,CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
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)
..;S CRHDTLST(CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
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
CANEDIT(CRHDRTN,CRHDTM,DUZ) ;
;Can user edit team list
N CRHDPRV,CRHDMGR,CRHDA
Q:CRHDTM=""
;S CRHDRTN="1^1"
S CRHDA=$$GET1^DIQ(200,+DUZ,3,"I")
S CRHDRTN="0^0"
I CRHDA["@" S CRHDRTN="1^1" Q
D HOTMMGR^CRHD1(.CRHDMGR,DUZ)
I CRHDMGR S CRHDRTN="1^1" Q
S CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
I 'CRHDPRV Q
E S CRHDRTN=+$P($G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",3)_"^"_+$P($G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",4)
Q
PATPRV(CRHDRTN,CRHDTM,CRHDDFN) ;
;return Providers assigned to patient on list
N CRHDPAT,CRHDNAM,CRHDZ0,CRHDP,CRHDATTN,CRHDRES,CRHDINT,CRHDFEL,CRHDMST,CRHDNUR,CRHDVP,CRHDI,CRHDI2
S CRHDVP="^CRHDATTN^CRHDRES^CRHDINT^CRHDFEL^CRHDMST^CRHDNUR"
S CRHDPAT=$O(^CRHD(183.3,+CRHDTM,1,"B",+CRHDDFN,0))
I 'CRHDPAT Q
S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,1,+CRHDPAT,0))
;I need to add, if the physician is not on team list delete from patient.
F CRHDI=2:1:7 S CRHDP=$P(CRHDZ0,"^",CRHDI) D
.I '$D(@$P(CRHDVP,"^",CRHDI)) S @$P(CRHDVP,"^",CRHDI)=""
.I CRHDP["," D
..F CRHDI2=1:1:$L(CRHDP,",") D
...I '$D(^CRHD(183.3,CRHDTM,2,"B",$P(CRHDP,",",CRHDI2))) Q
...S CRHDNAM=$$GET1^DIQ(200,+$P(CRHDP,",",CRHDI2),.01,"E")
...S @$P(CRHDVP,"^",CRHDI)=@$P(CRHDVP,"^",CRHDI)_+$P(CRHDP,",",CRHDI2)_"^"_CRHDNAM_"+"
.;E S:+CRHDP&($D(^CRHD(183.3,+CRHDTM,2,"B",+CRHDP))) @$P(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
.E S:+CRHDP @$P(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
F CRHDI=2:1:7 I $E(@$P(CRHDVP,"^",CRHDI),$L(@$P(CRHDVP,"^",CRHDI)))="+" S @$P(CRHDVP,"^",CRHDI)=$E(@$P(CRHDVP,"^",CRHDI),1,$L(@$P(CRHDVP,"^",CRHDI))-1)
S CRHDRTN=CRHDDFN_";"_$G(CRHDATTN)_";"_$G(CRHDRES)_";"_$G(CRHDINT)_";"_$G(CRHDFEL)_";"_$G(CRHDMST)_";"_$G(CRHDNUR)
Q
USERPHPG(CRHDRTN,DUZ) ;
N CRHDOP,CRHDPG
S CRHDOP=$$GET1^DIQ(200,+DUZ_",",.132,"E") ;OFFICE PHONE
S CRHDPG=$$GET1^DIQ(200,+DUZ_",",.138,"E") ;PAGER
S CRHDRTN=$S($L(CRHDOP)>2:CRHDOP,1:"")_"^"_$S($L(CRHDPG)>2:CRHDPG,1:"")
Q
PRVINFO(CRHDRTN,CRHDTM,DUZ) ;
;return user information
N CRHDPRV,CRHDZ0,CRHDMGR
Q:CRHDTM=""
;S CRHDRTN(1)="0^0"
S CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
I 'CRHDPRV Q
S CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0))
D MGR^CRHD7(.CRHDMGR,DUZ)
I ($$GET1^DIQ(200,+DUZ,3,"E")["@")!(+CRHDMGR) S $P(CRHDZ0,"^",3)=1,$P(CRHDZ0,"^",4)=1
S CRHDRTN=$P(CRHDZ0,"^",1)_"^"_$$GET1^DIQ(200,+CRHDZ0,.01,"E")_"^"_$P(CRHDZ0,"^",2,$L(CRHDZ0,"^"))
Q
MOD(CRHDRTN,CRHDTM,CRHDLTYP,CRHDTXT,CRHDKFG) ;
N CRHDX,CRHDFDA,CRHDOUT,CRHDERR
K CRHDRTN
S CRHDRTN(0)=0
I '$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
I CRHDLTYP="P" D
.K:CRHDKFG ^CRHD(183.3,+CRHDTM,1)
.S CRHDX=0
.F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
..I CRHDTXT(CRHDX)["~" S CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=+$P(CRHDTXT(CRHDX),"^",1)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=+$P(CRHDTXT(CRHDX),";",2)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=+$P(CRHDTXT(CRHDX),";",3)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=+$P(CRHDTXT(CRHDX),";",4)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=+$P(CRHDTXT(CRHDX),";",5)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=+$P(CRHDTXT(CRHDX),";",6)
..S CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",6)=+$P(CRHDTXT(CRHDX),";",7)
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDRTN(0)=1
.E S CRHDRTN(1)=1
I CRHDLTYP="D" D
.K:CRHDKFG ^CRHD(183.3,+CRHDTM,2)
.S CRHDX=0
.F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
..I CRHDTXT(CRHDX)["~" S CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=$P(CRHDTXT(CRHDX),"^",1)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=$P(CRHDTXT(CRHDX),"^",3)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=$P(CRHDTXT(CRHDX),"^",4)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=$P(CRHDTXT(CRHDX),"^",5)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=$P(CRHDTXT(CRHDX),"^",6)
..S CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=$P(CRHDTXT(CRHDX),"^",7)
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDRTN(0)=1
.E S CRHDRTN(1)=1
K CRHDFDA,CRHDOUT,CRHDERR
Q
FILENSAV(CRHDRTN,CRHDTM,CRHDFNM) ;
;save filename for a team
N CRHDFDA,CRHDOUT,CRHDERR,CRHDA
K CRHDRTN
S CRHDRTN=0
;I CRHDTM'?1A.E Q
S CRHDFDA(183.4,"?+1,",.01)=$P(CRHDTM,"^",2)
D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
I '$D(CRHDERR) D
.S CRHDA=CRHDOUT(1)
.K CRHDFDA,CRHDOUT
.I CRHDA D
..S CRHDFDA(183.4,CRHDA_",",2)=CRHDFNM
..D FILE^DIE("","CRHDFDA")
..S CRHDRTN=1
Q
FILENGET(CRHDRTN,CRHDTM) ;
;get filename for a team
S CRHDRTN=$$GET1^DIQ(183.4,+$$FIND1^DIC(183.4,"","X",$P(CRHDTM,"^",2),"","","ERR")_",",2,"I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD9 9572 printed Dec 13, 2024@02:37:54 Page 2
CRHD9 ; CAIRO/CLC - HANDOFF TEAM LIST ;4/24/08 12:49
+1 ;;1.0;CRHD;**2,7**;Jan 28, 2008;Build 1
+2 ;=================================================================
+3 ;04/22/2009 BAY/KAM CRHD*1*2 Remedy Call 264027 Correct Issue of not
+4 ; being able to display/print patients
+5 ; with identical names
HOTMSAVE(CRHDRTN,CRHDTM) ;
+1 ;create a team name
+2 NEW CRHDFDA,CRHDOUT,CRHDERR
+3 KILL CRHDRTN
+4 SET CRHDRTN=0
+5 IF (CRHDTM'?1A.E)&(CRHDTM'?1N.E)
QUIT
+6 SET CRHDFDA(183.3,"?+1,",.01)=CRHDTM
+7 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+8 IF '$DATA(CRHDERR)
SET CRHDRTN=CRHDOUT(1)
+9 QUIT
HOTMDEL(CRHDRTN,CRHDTM) ;
+1 ;delete a Hand off team
+2 NEW DIK,DA
+3 KILL CRHDRTN
+4 SET CRHDRTN=0
+5 IF +CRHDTM
SET DIK="^CRHD(183.3,"
SET DA=+CRHDTM
DO ^DIK
SET CRHDRTN=1
+6 QUIT
HOLIST(CRHDRTN) ;
+1 ;return a list of teams
+2 NEW CRHDX,CRHDX1,CRHDTDT,CRHDCT
+3 KILL CRHDRTN
+4 SET CRHDX=""
+5 SET CRHDCT=0
+6 SET CRHDRTN(0)="0^No List Found"
+7 FOR
SET CRHDX=$ORDER(^CRHD(183.3,"B",CRHDX))
if CRHDX=""
QUIT
Begin DoDot:1
+8 SET CRHDX1=0
+9 FOR
SET CRHDX1=$ORDER(^CRHD(183.3,"B",CRHDX,CRHDX1))
if 'CRHDX1
QUIT
Begin DoDot:2
+10 ;check to see if team list is active, if date is less then today then inactive
+11 SET CRHDTDT=$PIECE($GET(^CRHD(183.3,CRHDX1,0)),"^",2)
+12 IF CRHDTDT&(CRHDTDT<$$DT^XLFDT)
QUIT
+13 SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDX1_"^"_CRHDX_"^"_"HOTEAM"
End DoDot:2
End DoDot:1
+14 IF CRHDCT>0
KILL CRHDRTN(0)
+15 QUIT
HOPLIST(CRHDRTN,CRHDTM) ;
+1 ;Get list of Patients for a HO team
+2 NEW CRHDX,CRHDPT,CRHDPD,CRHDTLST,CRHDCT,CRHDPD2,VAIP,DFN,DIE,DA,DR
+3 KILL CRHDRTN
+4 ;p.7 HPS/MWA "No Patients Found" is expected to be in the second piece...added "^"
+5 SET CRHDRTN(1)="^No Patients Found"
+6 if 'CRHDTM
QUIT
+7 IF '$DATA(^CRHD(183.3,"B",$PIECE(CRHDTM,"^",2),+CRHDTM))
QUIT
+8 SET CRHDX=0
+9 FOR
SET CRHDX=$ORDER(^CRHD(183.3,+CRHDTM,1,CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+10 SET CRHDPT=+$GET(^CRHD(183.3,+CRHDTM,1,CRHDX,0))
+11 ;check to see if patient has been discharged, if so delete from list
+12 SET DFN=CRHDPT
DO IN5^VADPT
+13 IF VAIP(1)=""
Begin DoDot:2
+14 SET DA(1)=+CRHDTM
SET DIE="^CRHD(183.3,"_DA(1)_",1,"
SET DA=CRHDX
SET DR=".01///@"
DO ^DIE
End DoDot:2
QUIT
+15 SET CRHDPD=$$PATDATA(CRHDPT)
+16 KILL CRHDPD2
+17 DO PATPRV(.CRHDPD2,CRHDTM,CRHDPT)
+18 ;04/22/2009 BAY/KAM CRHD*1*2 Remedy Call 264027 Concatenated the
+19 ; patient IEN to the subscript for
+20 ; uniqueness in the next two lines
+21 IF $PIECE(CRHDPD,"^",1)'=""
SET CRHDTLST($PIECE(CRHDPD,"^",2)_$PIECE(CRHDPD,"^",1))=CRHDPD
+22 ;I $P(CRHDPD,"^",1)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDPD ; ORIGINAL CODE
+23 IF $GET(CRHDPD2)'=""
SET CRHDTLST($PIECE(CRHDPD,"^",2)_$PIECE(CRHDPD,"^",1))=CRHDTLST($PIECE(CRHDPD,"^",2)_$PIECE(CRHDPD,"^",1))_"^*"_CRHDPD2
+24 ;I $G(CRHDPD2)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDTLST($P(CRHDPD,"^",2))_"^*"_CRHDPD2 ; ORIGINAL CODE
End DoDot:1
+25 IF $DATA(CRHDTLST)
Begin DoDot:1
+26 SET CRHDCT=0
+27 SET CRHDX=""
+28 FOR
SET CRHDX=$ORDER(CRHDTLST(CRHDX))
if CRHDX=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
End DoDot:1
+29 QUIT
PATDATA(DFN) ;
+1 ;
+2 NEW CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE,CRHDSEX,VAIP,VADM
+3 KILL VAIP,VADM
+4 DO DEM^VADPT
DO IN5^VADPT
+5 SET CRHDNAME=VADM(1)
SET CRHDSSN=$PIECE(VADM(2),U,1)
SET CRHDDOB=$PIECE(VADM(3),U,1)
+6 SET CRHDAGE=VADM(4)
SET CRHDSEX=$PIECE(VADM(5),U,1)
+7 KILL VAIP,VADM
+8 QUIT DFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
+9 ;
HODLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a HO team
+1 NEW CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
+2 NEW CRHDPX,CRHDPX0,CRHDNAM
+3 KILL CRHDRTN
+4 IF '$DATA(^CRHD(183.3,"B",$PIECE(CRHDTM,"^",2),+CRHDTM))
QUIT
+5 SET CRHDX=0
+6 FOR
SET CRHDX=$ORDER(^CRHD(183.3,+CRHDTM,2,CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+7 SET CRHDPRV=+$GET(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
+8 SET CRHDNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
+9 ;Delete Provider if inactive, 1st check to see if assigned to a patient, if so remove
+10 IF '$$ACTIVE^XUSER(+CRHDPRV)
Begin DoDot:2
+11 SET CRHDPX=0
FOR
SET CRHDPX=$ORDER(^CRHD(183.3,+CRHDTM,1,CRHDPX))
if 'CRHDPX
QUIT
Begin DoDot:3
+12 SET CRHDPX0=^CRHD(183.3,+CRHDTM,1,CRHDPX,0)
+13 IF CRHDPX0[+CRHDPRV
FOR CRHDI=2:1:$LENGTH(CRHDPX0,"^")
IF $PIECE(CRHDPX0,"^",CRHDI)=+CRHDPRV
SET $PIECE(^CRHD(183.3,+CRHDTM,1,CRHDPX,0),"^",CRHDI)=""
End DoDot:3
+14 SET DA(1)=+CRHDTM
SET DIE="^CRHD(183.3,"_DA(1)_",2,"
SET DA=CRHDX
SET DR=".01///@"
DO ^DIE
End DoDot:2
QUIT
+15 IF CRHDNAM'=""
Begin DoDot:2
+16 SET CRHDZ0=$GET(^CRHD(183.3,+CRHDTM,2,+CRHDX,0))
+17 SET CRHDUT=$PIECE(CRHDZ0,"^",2)
+18 IF CRHDUT=""
SET CRHDUT="ZNOTYPE"
+19 SET CRHDSORT(CRHDUT,CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$PIECE(CRHDZ0,"^",2)_"^"_+$PIECE(CRHDZ0,"^",3)_"^"_+$PIECE(CRHDZ0,"^",4)_"^"_$PIECE(CRHDZ0,"^",5)_"^"_$PIECE(CRHDZ0,"^",6)
End DoDot:2
End DoDot:1
+20 SET CRHDI=""
+21 FOR
SET CRHDI=$ORDER(CRHDSORT(CRHDI))
if CRHDI=""
QUIT
Begin DoDot:1
+22 SET CRHDPRV=""
+23 FOR
SET CRHDPRV=$ORDER(CRHDSORT(CRHDI,CRHDPRV))
if CRHDPRV=""
QUIT
Begin DoDot:2
+24 SET CRHDTLST(CRHDPRV)=CRHDSORT(CRHDI,CRHDPRV)
+25 ;S CRHDTLST(CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
End DoDot:2
End DoDot:1
+26 IF $DATA(CRHDTLST)
Begin DoDot:1
+27 SET CRHDCT=0
+28 SET CRHDX=""
+29 FOR
SET CRHDX=$ORDER(CRHDTLST(CRHDX))
if CRHDX=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
End DoDot:1
+30 QUIT
CANEDIT(CRHDRTN,CRHDTM,DUZ) ;
+1 ;Can user edit team list
+2 NEW CRHDPRV,CRHDMGR,CRHDA
+3 if CRHDTM=""
QUIT
+4 ;S CRHDRTN="1^1"
+5 SET CRHDA=$$GET1^DIQ(200,+DUZ,3,"I")
+6 SET CRHDRTN="0^0"
+7 IF CRHDA["@"
SET CRHDRTN="1^1"
QUIT
+8 DO HOTMMGR^CRHD1(.CRHDMGR,DUZ)
+9 IF CRHDMGR
SET CRHDRTN="1^1"
QUIT
+10 SET CRHDPRV=$ORDER(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
+11 IF 'CRHDPRV
QUIT
+12 IF '$TEST
SET CRHDRTN=+$PIECE($GET(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",3)_"^"_+$PIECE($GET(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0)),"^",4)
+13 QUIT
PATPRV(CRHDRTN,CRHDTM,CRHDDFN) ;
+1 ;return Providers assigned to patient on list
+2 NEW CRHDPAT,CRHDNAM,CRHDZ0,CRHDP,CRHDATTN,CRHDRES,CRHDINT,CRHDFEL,CRHDMST,CRHDNUR,CRHDVP,CRHDI,CRHDI2
+3 SET CRHDVP="^CRHDATTN^CRHDRES^CRHDINT^CRHDFEL^CRHDMST^CRHDNUR"
+4 SET CRHDPAT=$ORDER(^CRHD(183.3,+CRHDTM,1,"B",+CRHDDFN,0))
+5 IF 'CRHDPAT
QUIT
+6 SET CRHDZ0=$GET(^CRHD(183.3,+CRHDTM,1,+CRHDPAT,0))
+7 ;I need to add, if the physician is not on team list delete from patient.
+8 FOR CRHDI=2:1:7
SET CRHDP=$PIECE(CRHDZ0,"^",CRHDI)
Begin DoDot:1
+9 IF '$DATA(@$PIECE(CRHDVP,"^",CRHDI))
SET @$PIECE(CRHDVP,"^",CRHDI)=""
+10 IF CRHDP[","
Begin DoDot:2
+11 FOR CRHDI2=1:1:$LENGTH(CRHDP,",")
Begin DoDot:3
+12 IF '$DATA(^CRHD(183.3,CRHDTM,2,"B",$PIECE(CRHDP,",",CRHDI2)))
QUIT
+13 SET CRHDNAM=$$GET1^DIQ(200,+$PIECE(CRHDP,",",CRHDI2),.01,"E")
+14 SET @$PIECE(CRHDVP,"^",CRHDI)=@$PIECE(CRHDVP,"^",CRHDI)_+$PIECE(CRHDP,",",CRHDI2)_"^"_CRHDNAM_"+"
End DoDot:3
End DoDot:2
+15 ;E S:+CRHDP&($D(^CRHD(183.3,+CRHDTM,2,"B",+CRHDP))) @$P(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
+16 IF '$TEST
if +CRHDP
SET @$PIECE(CRHDVP,"^",CRHDI)=+CRHDP_"^"_$$GET1^DIQ(200,+CRHDP,.01,"E")
End DoDot:1
+17 FOR CRHDI=2:1:7
IF $EXTRACT(@$PIECE(CRHDVP,"^",CRHDI),$LENGTH(@$PIECE(CRHDVP,"^",CRHDI)))="+"
SET @$PIECE(CRHDVP,"^",CRHDI)=$EXTRACT(@$PIECE(CRHDVP,"^",CRHDI),1,$LENGTH(@$PIECE(CRHDVP,"^",CRHDI))-1)
+18 SET CRHDRTN=CRHDDFN_";"_$GET(CRHDATTN)_";"_$GET(CRHDRES)_";"_$GET(CRHDINT)_";"_$GET(CRHDFEL)_";"_$GET(CRHDMST)_";"_$GET(CRHDNUR)
+19 QUIT
USERPHPG(CRHDRTN,DUZ) ;
+1 NEW CRHDOP,CRHDPG
+2 ;OFFICE PHONE
SET CRHDOP=$$GET1^DIQ(200,+DUZ_",",.132,"E")
+3 ;PAGER
SET CRHDPG=$$GET1^DIQ(200,+DUZ_",",.138,"E")
+4 SET CRHDRTN=$SELECT($LENGTH(CRHDOP)>2:CRHDOP,1:"")_"^"_$SELECT($LENGTH(CRHDPG)>2:CRHDPG,1:"")
+5 QUIT
PRVINFO(CRHDRTN,CRHDTM,DUZ) ;
+1 ;return user information
+2 NEW CRHDPRV,CRHDZ0,CRHDMGR
+3 if CRHDTM=""
QUIT
+4 ;S CRHDRTN(1)="0^0"
+5 SET CRHDPRV=$ORDER(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
+6 IF 'CRHDPRV
QUIT
+7 SET CRHDZ0=$GET(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0))
+8 DO MGR^CRHD7(.CRHDMGR,DUZ)
+9 IF ($$GET1^DIQ(200,+DUZ,3,"E")["@")!(+CRHDMGR)
SET $PIECE(CRHDZ0,"^",3)=1
SET $PIECE(CRHDZ0,"^",4)=1
+10 SET CRHDRTN=$PIECE(CRHDZ0,"^",1)_"^"_$$GET1^DIQ(200,+CRHDZ0,.01,"E")_"^"_$PIECE(CRHDZ0,"^",2,$LENGTH(CRHDZ0,"^"))
+11 QUIT
MOD(CRHDRTN,CRHDTM,CRHDLTYP,CRHDTXT,CRHDKFG) ;
+1 NEW CRHDX,CRHDFDA,CRHDOUT,CRHDERR
+2 KILL CRHDRTN
+3 SET CRHDRTN(0)=0
+4 IF '$DATA(^CRHD(183.3,"B",$PIECE(CRHDTM,"^",2),+CRHDTM))
QUIT
+5 IF CRHDLTYP="P"
Begin DoDot:1
+6 if CRHDKFG
KILL ^CRHD(183.3,+CRHDTM,1)
+7 SET CRHDX=0
+8 FOR
SET CRHDX=$ORDER(CRHDTXT(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+9 IF CRHDTXT(CRHDX)["~"
SET CRHDTXT(CRHDX)=$PIECE(CRHDTXT(CRHDX),"~",2)
+10 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=+$PIECE(CRHDTXT(CRHDX),"^",1)
+11 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=+$PIECE(CRHDTXT(CRHDX),";",2)
+12 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=+$PIECE(CRHDTXT(CRHDX),";",3)
+13 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=+$PIECE(CRHDTXT(CRHDX),";",4)
+14 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=+$PIECE(CRHDTXT(CRHDX),";",5)
+15 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=+$PIECE(CRHDTXT(CRHDX),";",6)
+16 SET CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",6)=+$PIECE(CRHDTXT(CRHDX),";",7)
End DoDot:2
+17 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+18 IF '$DATA(CRHDERR)
SET CRHDRTN(0)=1
+19 IF '$TEST
SET CRHDRTN(1)=1
End DoDot:1
+20 IF CRHDLTYP="D"
Begin DoDot:1
+21 if CRHDKFG
KILL ^CRHD(183.3,+CRHDTM,2)
+22 SET CRHDX=0
+23 FOR
SET CRHDX=$ORDER(CRHDTXT(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+24 IF CRHDTXT(CRHDX)["~"
SET CRHDTXT(CRHDX)=$PIECE(CRHDTXT(CRHDX),"~",2)
+25 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=$PIECE(CRHDTXT(CRHDX),"^",1)
+26 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=$PIECE(CRHDTXT(CRHDX),"^",3)
+27 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=$PIECE(CRHDTXT(CRHDX),"^",4)
+28 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=$PIECE(CRHDTXT(CRHDX),"^",5)
+29 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=$PIECE(CRHDTXT(CRHDX),"^",6)
+30 SET CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=$PIECE(CRHDTXT(CRHDX),"^",7)
End DoDot:2
+31 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+32 IF '$DATA(CRHDERR)
SET CRHDRTN(0)=1
+33 IF '$TEST
SET CRHDRTN(1)=1
End DoDot:1
+34 KILL CRHDFDA,CRHDOUT,CRHDERR
+35 QUIT
FILENSAV(CRHDRTN,CRHDTM,CRHDFNM) ;
+1 ;save filename for a team
+2 NEW CRHDFDA,CRHDOUT,CRHDERR,CRHDA
+3 KILL CRHDRTN
+4 SET CRHDRTN=0
+5 ;I CRHDTM'?1A.E Q
+6 SET CRHDFDA(183.4,"?+1,",.01)=$PIECE(CRHDTM,"^",2)
+7 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+8 IF '$DATA(CRHDERR)
Begin DoDot:1
+9 SET CRHDA=CRHDOUT(1)
+10 KILL CRHDFDA,CRHDOUT
+11 IF CRHDA
Begin DoDot:2
+12 SET CRHDFDA(183.4,CRHDA_",",2)=CRHDFNM
+13 DO FILE^DIE("","CRHDFDA")
+14 SET CRHDRTN=1
End DoDot:2
End DoDot:1
+15 QUIT
FILENGET(CRHDRTN,CRHDTM) ;
+1 ;get filename for a team
+2 SET CRHDRTN=$$GET1^DIQ(183.4,+$$FIND1^DIC(183.4,"","X",$PIECE(CRHDTM,"^",2),"","","ERR")_",",2,"I")
+3 QUIT
