- 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 Jan 18, 2025@03:39:01 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