Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: CRHD9

CRHD9.m

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