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
 
CRHDFDA,CRHDOUT,CRHDERR
 
CRHDRTN
 
CRHDRTN=0
 
(CRHDTM'?1A.E)&(CRHDTM'?1N.EQ
 S 
CRHDFDA(183.3,"?+1,",.01)=CRHDTM
 
UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
 
'$D(CRHDERRCRHDRTN=CRHDOUT(1)
 
Q
HOTMDEL(CRHDRTN,CRHDTM) ;
 ;delete a Hand off team
 
DIK,DA
 
CRHDRTN
 
CRHDRTN=0
 
+CRHDTM DIK="^CRHD(183.3,",DA=+CRHDTM ^DIK CRHDRTN=1
 
Q
HOLIST(CRHDRTN) ;
 ;return a list of teams
 
CRHDX,CRHDX1,CRHDTDT,CRHDCT
 
CRHDRTN
 
CRHDX=""
 
CRHDCT=0
 
CRHDRTN(0)="0^No List Found"
 
F  S CRHDX=$O(^CRHD(183.3,"B",CRHDX)) Q:CRHDX=""  D
 
.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
 
..CRHDTDT=$P($G(^CRHD(183.3,CRHDX1,0)),"^",2)
 ..
CRHDTDT&(CRHDTDT<$$DT^XLFDT) Q
 
..CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDX1_"^"_CRHDX_"^"_"HOTEAM"
 
CRHDCT>0 CRHDRTN(0)
 
Q
HOPLIST(CRHDRTN,CRHDTM) ;
 ;Get list of Patients for a HO team
 
CRHDX,CRHDPT,CRHDPD,CRHDTLST,CRHDCT,CRHDPD2,VAIP,DFN,DIE,DA,DR
 
CRHDRTN
 
;p.7 HPS/MWA "No Patients Found" is expected to be in the second piece...added "^"
 
CRHDRTN(1)="^No Patients Found"
 
Q:'CRHDTM
 
'$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
 
.CRHDPT=+$G(^CRHD(183.3,+CRHDTM,1,CRHDX,0))
 .
;check to see if patient has been discharged, if so delete from list
 
.DFN=CRHDPT IN5^VADPT
 .
VAIP(1)="" D  Q
 
..DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",1,",DA=CRHDX,DR=".01///@" ^DIE
 .
CRHDPD=$$PATDATA(CRHDPT)
 .
CRHDPD2
 
.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)'="" CRHDTLST($P(CRHDPD,"^",2)_$P(CRHDPD,"^",1))=CRHDPD
 
;I $P(CRHDPD,"^",1)'="" S CRHDTLST($P(CRHDPD,"^",2))=CRHDPD ; ORIGINAL CODE
 
I $G(CRHDPD2)'="" 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(CRHDTLSTD
 
.CRHDCT=0
 .
CRHDX=""
 
.F  S CRHDX=$O(CRHDTLST(CRHDX)) Q:CRHDX=""  CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
 
Q
PATDATA(DFN) ;
 ;
 
CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE,CRHDSEX,VAIP,VADM
 
VAIP,VADM
 
DEM^VADPT,IN5^VADPT
 
CRHDNAME=VADM(1),CRHDSSN=$P(VADM(2),U,1),CRHDDOB=$P(VADM(3),U,1)
 
CRHDAGE=VADM(4),CRHDSEX=$P(VADM(5),U,1)
 
VAIP,VADM
 
DFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
 
;
HODLIST(CRHDRTN,CRHDTM) ;Get list of Providers for a HO team
 
CRHDX,CRHDPRV,CRHDTLST,CRHDCT,CRHDZ0,CRHDSORT,CRHDUT
 
CRHDPX,CRHDPX0,CRHDNAM
 
CRHDRTN
 
'$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
 
.CRHDPRV=+$G(^CRHD(183.3,+CRHDTM,2,CRHDX,0))
 .
CRHDNAM=$$GET1^DIQ(200,+CRHDPRV,.01,"E")
 .
;Delete Provider if inactive, 1st check to see if assigned to a patient, if so remove
 
.'$$ACTIVE^XUSER(+CRHDPRVD  Q
 
..CRHDPX=0 F  S CRHDPX=$O(^CRHD(183.3,+CRHDTM,1,CRHDPX)) Q:'CRHDPX  D
 
...CRHDPX0=^CRHD(183.3,+CRHDTM,1,CRHDPX,0)
 ...
CRHDPX0[+CRHDPRV CRHDI=2:1:$L(CRHDPX0,"^"I $P(CRHDPX0,"^",CRHDI)=+CRHDPRV S $P(^CRHD(183.3,+CRHDTM,1,CRHDPX,0),"^",CRHDI)=""
 
..DA(1)=+CRHDTM,DIE="^CRHD(183.3,"_DA(1)_",2,",DA=CRHDX,DR=".01///@" ^DIE
 .
CRHDNAM'="" D
 
..CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDX,0))
 ..
CRHDUT=$P(CRHDZ0,"^",2)
 ..
CRHDUT="" CRHDUT="ZNOTYPE"
 
..CRHDSORT(CRHDUT,CRHDNAM)=CRHDPRV_"^"_CRHDNAM_"^"_$P(CRHDZ0,"^",2)_"^"_+$P(CRHDZ0,"^",3)_"^"_+$P(CRHDZ0,"^",4)_"^"_$P(CRHDZ0,"^",5)_"^"_$P(CRHDZ0,"^",6)
 
CRHDI=""
 
F  S CRHDI=$O(CRHDSORT(CRHDI)) Q:CRHDI=""  D
 
.CRHDPRV=""
 
.F  S CRHDPRV=$O(CRHDSORT(CRHDI,CRHDPRV)) Q:CRHDPRV=""  D
 
..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(CRHDTLSTD
 
.CRHDCT=0
 .
CRHDX=""
 
.F  S CRHDX=$O(CRHDTLST(CRHDX)) Q:CRHDX=""  CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTLST(CRHDX)
 
Q
CANEDIT(CRHDRTN,CRHDTM,DUZ) ;
 ;Can user edit team list
 
CRHDPRV,CRHDMGR,CRHDA
 
Q:CRHDTM=""
 ;S CRHDRTN="1^1"
 
CRHDA=$$GET1^DIQ(200,+DUZ,3,"I")
 
CRHDRTN="0^0"
 
CRHDA["@" CRHDRTN="1^1" Q
 D 
HOTMMGR^CRHD1(.CRHDMGR,DUZ)
 
CRHDMGR CRHDRTN="1^1" Q
 S 
CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
 
'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
 
CRHDPAT,CRHDNAM,CRHDZ0,CRHDP,CRHDATTN,CRHDRES,CRHDINT,CRHDFEL,CRHDMST,CRHDNUR,CRHDVP,CRHDI,CRHDI2
 
CRHDVP="^CRHDATTN^CRHDRES^CRHDINT^CRHDFEL^CRHDMST^CRHDNUR"
 
CRHDPAT=$O(^CRHD(183.3,+CRHDTM,1,"B",+CRHDDFN,0))
 
'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.
 
CRHDI=2:1:7 CRHDP=$P(CRHDZ0,"^",CRHDID
 
.'$D(@$P(CRHDVP,"^",CRHDI)) @$P(CRHDVP,"^",CRHDI)=""
 
.CRHDP["," D
 
..CRHDI2=1:1:$L(CRHDP,","D
 
...'$D(^CRHD(183.3,CRHDTM,2,"B",$P(CRHDP,",",CRHDI2))) Q
 
...CRHDNAM=$$GET1^DIQ(200,+$P(CRHDP,",",CRHDI2),.01,"E")
 ...
@$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")
 
CRHDI=2:1:7 I $E(@$P(CRHDVP,"^",CRHDI),$L(@$P(CRHDVP,"^",CRHDI)))="+" @$P(CRHDVP,"^",CRHDI)=$E(@$P(CRHDVP,"^",CRHDI),1,$L(@$P(CRHDVP,"^",CRHDI))-1)
 
CRHDRTN=CRHDDFN_";"_$G(CRHDATTN)_";"_$G(CRHDRES)_";"_$G(CRHDINT)_";"_$G(CRHDFEL)_";"_$G(CRHDMST)_";"_$G(CRHDNUR)
 
Q
USERPHPG(CRHDRTN,DUZ) ;
 
CRHDOP,CRHDPG
 
CRHDOP=$$GET1^DIQ(200,+DUZ_",",.132,"E")             ;OFFICE PHONE
 
CRHDPG=$$GET1^DIQ(200,+DUZ_",",.138,"E")             ;PAGER
 
CRHDRTN=$S($L(CRHDOP)>2:CRHDOP,1:"")_"^"_$S($L(CRHDPG)>2:CRHDPG,1:"")
 
Q
PRVINFO(CRHDRTN,CRHDTM,DUZ) ;
 ;return user information
 
CRHDPRV,CRHDZ0,CRHDMGR
 
Q:CRHDTM=""
 ;S CRHDRTN(1)="0^0"
 
CRHDPRV=$O(^CRHD(183.3,+CRHDTM,2,"B",+DUZ,0))
 
'CRHDPRV Q
 S 
CRHDZ0=$G(^CRHD(183.3,+CRHDTM,2,+CRHDPRV,0))
 
MGR^CRHD7(.CRHDMGR,DUZ)
 
($$GET1^DIQ(200,+DUZ,3,"E")["@")!(+CRHDMGRS $P(CRHDZ0,"^",3)=1,$P(CRHDZ0,"^",4)=1
 
CRHDRTN=$P(CRHDZ0,"^",1)_"^"_$$GET1^DIQ(200,+CRHDZ0,.01,"E")_"^"_$P(CRHDZ0,"^",2,$L(CRHDZ0,"^"))
 
Q
MOD(CRHDRTN,CRHDTM,CRHDLTYP,CRHDTXT,CRHDKFG) ;
 
CRHDX,CRHDFDA,CRHDOUT,CRHDERR
 
CRHDRTN
 
CRHDRTN(0)=0
 
'$D(^CRHD(183.3,"B",$P(CRHDTM,"^",2),+CRHDTM)) Q
 I 
CRHDLTYP="P" D
 
.K:CRHDKFG ^CRHD(183.3,+CRHDTM,1)
 .
CRHDX=0
 .
F  S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX  D
 
..CRHDTXT(CRHDX)["~" CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=+$P(CRHDTXT(CRHDX),"^",1)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=+$P(CRHDTXT(CRHDX),";",2)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=+$P(CRHDTXT(CRHDX),";",3)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=+$P(CRHDTXT(CRHDX),";",4)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=+$P(CRHDTXT(CRHDX),";",5)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=+$P(CRHDTXT(CRHDX),";",6)
 ..
CRHDFDA(183.31,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",6)=+$P(CRHDTXT(CRHDX),";",7)
 .
UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
 .
'$D(CRHDERRCRHDRTN(0)=1
 .
E  S CRHDRTN(1)=1
 
CRHDLTYP="D" D
 
.K:CRHDKFG ^CRHD(183.3,+CRHDTM,2)
 .
CRHDX=0
 .
F  S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX  D
 
..CRHDTXT(CRHDX)["~" CRHDTXT(CRHDX)=$P(CRHDTXT(CRHDX),"~",2)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",.01)=$P(CRHDTXT(CRHDX),"^",1)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",1)=$P(CRHDTXT(CRHDX),"^",3)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",2)=$P(CRHDTXT(CRHDX),"^",4)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",3)=$P(CRHDTXT(CRHDX),"^",5)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",4)=$P(CRHDTXT(CRHDX),"^",6)
 ..
CRHDFDA(183.32,"?+"_(CRHDX+1)_","_+CRHDTM_","_"",5)=$P(CRHDTXT(CRHDX),"^",7)
 .
UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
 .
'$D(CRHDERRCRHDRTN(0)=1
 .
E  S CRHDRTN(1)=1
 
CRHDFDA,CRHDOUT,CRHDERR
 
Q
FILENSAV(CRHDRTN,CRHDTM,CRHDFNM) ;
 ;save filename for a team
 
CRHDFDA,CRHDOUT,CRHDERR,CRHDA
 
CRHDRTN
 
CRHDRTN=0
 
;I CRHDTM'?1A.E Q
 
CRHDFDA(183.4,"?+1,",.01)=$P(CRHDTM,"^",2)
 
UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
 
'$D(CRHDERRD
 
.CRHDA=CRHDOUT(1)
 .
CRHDFDA,CRHDOUT
 
.CRHDA D
 
..CRHDFDA(183.4,CRHDA_",",2)=CRHDFNM
 
..FILE^DIE("","CRHDFDA")
 ..
CRHDRTN=1
 
Q
FILENGET(CRHDRTN,CRHDTM) ;
 ;get filename for a team
 
CRHDRTN=$$GET1^DIQ(183.4,+$$FIND1^DIC(183.4,"","X",$P(CRHDTM,"^",2),"","","ERR")_",",2,"I")
 
Q