BEHOPTP1 ;MSC/IND/DKM - Patient List Management ;16-Feb-2008 10:02;DKM
;;1.1;BEH COMPONENTS;**004004**;Mar 20, 2007
;=================================================================
; Return list of patients with clinic appt w/in range
CLINPTS(DATA,LOC,START,END,MAX) ;EP
I +$G(LOC)<1 S DATA(1)="^No clinic identified" Q
I '$$ACTLOC^BEHOENCX(LOC) S DATA(1)="^Clinic is not active" Q
N DFN,CNT,J,X,DAT,DATX,QUALS,VIEN,VSTR
S MAX=$G(MAX,200),CNT=0
D:START="" GETPAR^CIAVMRPC(.START,"ORLP DEFAULT CLINIC START DATE",,,"E")
D:END="" GETPAR^CIAVMRPC(.END,"ORLP DEFAULT CLINIC STOP DATE",,,"E")
D DT^DILF("T",START,.START,"","")
D DT^DILF("T",END,.END,"","")
I (START=-1)!(END=-1) S DATA(1)="^Error in date range." Q
S END=END\1+.9,DAT=START,LOC=+LOC,DATX=$S(START\1=(END\1):"",1:" ")
F S DAT=$O(^SC(LOC,"S",DAT)),J=0 Q:'DAT!(DAT>END) D:$L($G(^SC(LOC,"S",DAT,1,0))) Q:CNT'<MAX
.S:$L(DATX) DATX=" on "_$$ENTRY^CIAUDT(DAT)
.F S J=$O(^SC(+LOC,"S",DAT,1,J)) Q:'J!(CNT'<MAX) D
..S X=^SC(LOC,"S",DAT,1,J,0)
..Q:$P(X,U,9)="C" ; cancelled clinic availability
..S DFN=+X
..S X=$G(^DPT(DFN,"S",DAT,0))
..Q:+X'=LOC ; appt cancelled/resched
..I $P(X,U,2)'="NT",($P(X,U,2)["C")!($P(X,U,2)["N") Q ; quit if appt cancelled or no show
..S VIEN=+$P($G(^SCE(+$P(X,U,20),0)),U,5)
..I VIEN,$D(^AUPNVSIT(VIEN,0)) S VSTR=LOC_";"_+^(0)_";A;"_VIEN
..E S VSTR=LOC_";"_DAT_";A"
..S:$$ISACTIVE^BEHOPTCX(DFN,.QUALS) CNT=CNT+1,DATA(CNT)=DFN_U_$P(^DPT(DFN,0),U)_U_DATX_U_VSTR
I CNT'<MAX D ;maximum allowable appointments exceeded
.K DATA
.S DATA(1)="^Too many appointments found; please narrow search range."
S:'$D(DATA) DATA(1)="^No appointments."
Q
; Return appts for a patient between beginning and end dates for a clinic, if no clinic return all appointments
PTAPPTS(DATA,DFN,START,END,LOC) ;EP
I '$$ACTLOC^BEHOENCX(LOC) S DATA(1)="^Clinic is not active" Q
N VASD,VAERR,NUM,CNT,INVDT,INT,EXT,ORSRV
S NUM=0,CNT=0
I START="" D
.D:'$L(LOC) GETPAR^CIAVMRPC(.START,"ORQQAP SEARCH RANGE START",,,"E")
.S:START="" START="T" ;default start date across all clinics is today
I END="" D
.D:'$L(LOC) GETPAR^CIAVMRPC(.START,"ORQQAP SEARCH RANGE STOP",,,"E")
.S:END="" END="T" ;default end date across all clinics is today
D DT^DILF("T",START,.START,"","")
D DT^DILF("T",END,.END,"","")
I (START=-1)!(END=-1) S DATA(1)="^Error in date range." Q
S VASD("F")=START
S VASD("T")=END\1+.5
S:$L(LOC) VASD("C",LOC)=""
S DATA(1)="^No appointments."
D SDA^VADPT
Q:VAERR=1
F S NUM=$O(^UTILITY("VASD",$J,NUM)) Q:'NUM D
.S INT=^UTILITY("VASD",$J,NUM,"I"),INVDT=9999999-$P(INT,U)
.S EXT=^UTILITY("VASD",$J,NUM,"E")
.S CNT=CNT+1,DATA(CNT)=$P(INT,U)_U_$P(EXT,U,2)_U_$P(EXT,U,3)_U_$P(EXT,U,4)_U_INVDT
K ^UTILITY("VASD",$J)
Q
; Return provider list
PROVLST(DATA,FROM,DIR,MAX) ;EP
N IEN,CNT
S FROM=$G(FROM),DIR=$G(DIR,1),MAX=$G(MAX,44),CNT=0
F S FROM=$O(^VA(200,"B",FROM),DIR),IEN="" Q:FROM="" D:$E(FROM)'="*" Q:CNT'<MAX
.F S IEN=$O(^VA(200,"B",FROM,IEN),DIR) Q:'IEN D
..I $D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) S CNT=CNT+1,DATA(CNT)=IEN_U_FROM
Q
; Return list of patients associated w/ primary provider
PROVPTS(DATA,PROV) ;EP
I +$G(PROV)<1 S DATA(1)="^No provider identified" Q
N DFN,CNT,QUALS
S (CNT,DFN)=0,DATA(1)="^No patients found."
F S DFN=+$O(^DPT("APR",PROV,DFN)) Q:'DFN D
.S:$$ISACTIVE^BEHOPTCX(DFN,.QUALS) CNT=CNT+1,DATA(CNT)=DFN_U_$P(^DPT(DFN,0),U)
Q
; Return list of treating specialties
SPECLST(DATA,FROM,DIR,MAX) ;EP
N CNT,IEN
S FROM=$G(FROM),DIR=$G(DIR,1),MAX=$G(MAX,44),CNT=0
F S FROM=$O(^DIC(45.7,"B",FROM),DIR),IEN="" Q:FROM="" D Q:CNT'<MAX
.F S IEN=$O(^DIC(45.7,"B",FROM,IEN),DIR) Q:'IEN D
..S:$$ACTIVE^DGACT(45.7,IEN) CNT=CNT+1,DATA(CNT)=IEN_U_FROM
Q
; Return list of patients associated w/ treating specialty
SPECPTS(DATA,SPEC) ;EP
I +$G(SPEC)<1 S DATA(1)="^No specialty identified" Q
N CNT,DFN,QUALS
S (CNT,DFN)=0,DATA(1)="^No patients found."
F S DFN=+$O(^DPT("ATR",SPEC,DFN)) Q:'DFN D
.S:$$ISACTIVE^BEHOPTCX(DFN,.QUALS) CNT=CNT+1,DATA(CNT)=DFN_U_$P(^DPT(DFN,0),U)
Q
; Return list of patients on a ward
WARDPTS(DATA,LOC) ;EP
N CNT,DFN,WARD,QUALS
I +$G(LOC)<1 S DATA(1)="^No ward identified." Q
S WARD=+$G(^SC(+LOC,42))
I '$D(^DIC(42,WARD,0)) S DATA(1)="^Not a valid ward." Q
S (CNT,DFN)=0,WARD=$P(^DIC(42,WARD,0),U),DATA(1)="^No patients found."
F S DFN=+$O(^DPT("CN",WARD,DFN)) Q:'DFN D:$$ISACTIVE^BEHOPTCX(DFN,.QUALS)
.S CNT=CNT+1,DATA(CNT)=DFN_U_$P(^DPT(DFN,0),U)_U_$P($G(^DPT(DFN,.101)),U)
.S DATA(CNT)=DATA(CNT)_U_$P($$ADMITINF^BEHOENCX(DFN,^DPT("CN",WARD,DFN)),U)
Q
; Returns all teams to which a user belongs
; PER = If nonzero, return personal lists. Otherwise, return team lists.
TEAMLST(DATA,PER) ;EP
N CNT,IEN,X
S (CNT,IEN)=0,PER=''$G(PER)
F S IEN=$O(^OR(100.21,"C",DUZ,IEN)) Q:'IEN D
.S X=$G(^OR(100.21,IEN,0))
.S:$P(X,U,2)="P"=PER CNT=CNT+1,DATA(CNT)=IEN_U_X
Q
; Return list of patients belonging to a team
TEAMPTS(DATA,TEAM) ;EP
N CNT,IEN,DFN,QUALS
S DATA(1)="^No patients found.",(CNT,IEN)=0,TEAM=+TEAM
I '$D(^OR(100.21,TEAM,0)) S DATA(1)="^Not a valid team." Q
F S IEN=$O(^OR(100.21,TEAM,10,IEN)) Q:'IEN S DFN=+$G(^(IEN,0)) D
.S:$$ISACTIVE^BEHOPTCX(DFN,.QUALS) CNT=CNT+1,DATA(CNT)=DFN_U_$P(^DPT(DFN,0),U)
Q
; Return list of locations
HOSPLOC(DATA,FROM,DIR,MAX,TYPE,START,END) ;EP
D HOSPLOC^BEHOENCX(.DATA,.FROM,.DIR,.MAX,.TYPE,.START,.END)
Q
BEHOPTP1 ;MSC/IND/DKM - Patient List Management ;16-Feb-2008 10:02;DKM
+1 ;;1.1;BEH COMPONENTS;**004004**;Mar 20, 2007
+2 ;=================================================================
+3 ; Return list of patients with clinic appt w/in range
CLINPTS(DATA,LOC,START,END,MAX) ;EP
+1 IF +$GET(LOC)<1
SET DATA(1)="^No clinic identified"
QUIT
+2 IF '$$ACTLOC^BEHOENCX(LOC)
SET DATA(1)="^Clinic is not active"
QUIT
+3 NEW DFN,CNT,J,X,DAT,DATX,QUALS,VIEN,VSTR
+4 SET MAX=$GET(MAX,200)
SET CNT=0
+5 IF START=""
DO GETPAR^CIAVMRPC(.START,"ORLP DEFAULT CLINIC START DATE",,,"E")
+6 IF END=""
DO GETPAR^CIAVMRPC(.END,"ORLP DEFAULT CLINIC STOP DATE",,,"E")
+7 DO DT^DILF("T",START,.START,"","")
+8 DO DT^DILF("T",END,.END,"","")
+9 IF (START=-1)!(END=-1)
SET DATA(1)="^Error in date range."
QUIT
+10 SET END=END\1+.9
SET DAT=START
SET LOC=+LOC
SET DATX=$SELECT(START\1=(END\1):"",1:" ")
+11 FOR
SET DAT=$ORDER(^SC(LOC,"S",DAT))
SET J=0
IF 'DAT!(DAT>END)
QUIT
IF $LENGTH($GET(^SC(LOC,"S",DAT,1,0)))
Begin DoDot:1
+12 IF $LENGTH(DATX)
SET DATX=" on "_$$ENTRY^CIAUDT(DAT)
+13 FOR
SET J=$ORDER(^SC(+LOC,"S",DAT,1,J))
IF 'J!(CNT'<MAX)
QUIT
Begin DoDot:2
+14 SET X=^SC(LOC,"S",DAT,1,J,0)
+15 ; cancelled clinic availability
IF $PIECE(X,U,9)="C"
QUIT
+16 SET DFN=+X
+17 SET X=$GET(^DPT(DFN,"S",DAT,0))
+18 ; appt cancelled/resched
IF +X'=LOC
QUIT
+19 ; quit if appt cancelled or no show
IF $PIECE(X,U,2)'="NT"
IF ($PIECE(X,U,2)["C")!($PIECE(X,U,2)["N")
QUIT
+20 SET VIEN=+$PIECE($GET(^SCE(+$PIECE(X,U,20),0)),U,5)
+21 IF VIEN
IF $DATA(^AUPNVSIT(VIEN,0))
SET VSTR=LOC_";"_+^(0)_";A;"_VIEN
+22 IF '$TEST
SET VSTR=LOC_";"_DAT_";A"
+23 IF $$ISACTIVE^BEHOPTCX(DFN,.QUALS)
SET CNT=CNT+1
SET DATA(CNT)=DFN_U_$PIECE(^DPT(DFN,0),U)_U_DATX_U_VSTR
End DoDot:2
End DoDot:1
IF CNT'<MAX
QUIT
+24 ;maximum allowable appointments exceeded
IF CNT'<MAX
Begin DoDot:1
+25 KILL DATA
+26 SET DATA(1)="^Too many appointments found; please narrow search range."
End DoDot:1
+27 IF '$DATA(DATA)
SET DATA(1)="^No appointments."
+28 QUIT
+29 ; Return appts for a patient between beginning and end dates for a clinic, if no clinic return all appointments
PTAPPTS(DATA,DFN,START,END,LOC) ;EP
+1 IF '$$ACTLOC^BEHOENCX(LOC)
SET DATA(1)="^Clinic is not active"
QUIT
+2 NEW VASD,VAERR,NUM,CNT,INVDT,INT,EXT,ORSRV
+3 SET NUM=0
SET CNT=0
+4 IF START=""
Begin DoDot:1
+5 IF '$LENGTH(LOC)
DO GETPAR^CIAVMRPC(.START,"ORQQAP SEARCH RANGE START",,,"E")
+6 ;default start date across all clinics is today
IF START=""
SET START="T"
End DoDot:1
+7 IF END=""
Begin DoDot:1
+8 IF '$LENGTH(LOC)
DO GETPAR^CIAVMRPC(.START,"ORQQAP SEARCH RANGE STOP",,,"E")
+9 ;default end date across all clinics is today
IF END=""
SET END="T"
End DoDot:1
+10 DO DT^DILF("T",START,.START,"","")
+11 DO DT^DILF("T",END,.END,"","")
+12 IF (START=-1)!(END=-1)
SET DATA(1)="^Error in date range."
QUIT
+13 SET VASD("F")=START
+14 SET VASD("T")=END\1+.5
+15 IF $LENGTH(LOC)
SET VASD("C",LOC)=""
+16 SET DATA(1)="^No appointments."
+17 DO SDA^VADPT
+18 IF VAERR=1
QUIT
+19 FOR
SET NUM=$ORDER(^UTILITY("VASD",$JOB,NUM))
IF 'NUM
QUIT
Begin DoDot:1
+20 SET INT=^UTILITY("VASD",$JOB,NUM,"I")
SET INVDT=9999999-$PIECE(INT,U)
+21 SET EXT=^UTILITY("VASD",$JOB,NUM,"E")
+22 SET CNT=CNT+1
SET DATA(CNT)=$PIECE(INT,U)_U_$PIECE(EXT,U,2)_U_$PIECE(EXT,U,3)_U_$PIECE(EXT,U,4)_U_INVDT
End DoDot:1
+23 KILL ^UTILITY("VASD",$JOB)
+24 QUIT
+25 ; Return provider list
PROVLST(DATA,FROM,DIR,MAX) ;EP
+1 NEW IEN,CNT
+2 SET FROM=$GET(FROM)
SET DIR=$GET(DIR,1)
SET MAX=$GET(MAX,44)
SET CNT=0
+3 FOR
SET FROM=$ORDER(^VA(200,"B",FROM),DIR)
SET IEN=""
IF FROM=""
QUIT
IF $EXTRACT(FROM)'="*"
Begin DoDot:1
+4 FOR
SET IEN=$ORDER(^VA(200,"B",FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 IF $DATA(^XUSEC("PROVIDER",IEN))
IF $$ACTIVE^XUSER(IEN)
SET CNT=CNT+1
SET DATA(CNT)=IEN_U_FROM
End DoDot:2
End DoDot:1
IF CNT'<MAX
QUIT
+6 QUIT
+7 ; Return list of patients associated w/ primary provider
PROVPTS(DATA,PROV) ;EP
+1 IF +$GET(PROV)<1
SET DATA(1)="^No provider identified"
QUIT
+2 NEW DFN,CNT,QUALS
+3 SET (CNT,DFN)=0
SET DATA(1)="^No patients found."
+4 FOR
SET DFN=+$ORDER(^DPT("APR",PROV,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 IF $$ISACTIVE^BEHOPTCX(DFN,.QUALS)
SET CNT=CNT+1
SET DATA(CNT)=DFN_U_$PIECE(^DPT(DFN,0),U)
End DoDot:1
+6 QUIT
+7 ; Return list of treating specialties
SPECLST(DATA,FROM,DIR,MAX) ;EP
+1 NEW CNT,IEN
+2 SET FROM=$GET(FROM)
SET DIR=$GET(DIR,1)
SET MAX=$GET(MAX,44)
SET CNT=0
+3 FOR
SET FROM=$ORDER(^DIC(45.7,"B",FROM),DIR)
SET IEN=""
IF FROM=""
QUIT
Begin DoDot:1
+4 FOR
SET IEN=$ORDER(^DIC(45.7,"B",FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 IF $$ACTIVE^DGACT(45.7,IEN)
SET CNT=CNT+1
SET DATA(CNT)=IEN_U_FROM
End DoDot:2
End DoDot:1
IF CNT'<MAX
QUIT
+6 QUIT
+7 ; Return list of patients associated w/ treating specialty
SPECPTS(DATA,SPEC) ;EP
+1 IF +$GET(SPEC)<1
SET DATA(1)="^No specialty identified"
QUIT
+2 NEW CNT,DFN,QUALS
+3 SET (CNT,DFN)=0
SET DATA(1)="^No patients found."
+4 FOR
SET DFN=+$ORDER(^DPT("ATR",SPEC,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 IF $$ISACTIVE^BEHOPTCX(DFN,.QUALS)
SET CNT=CNT+1
SET DATA(CNT)=DFN_U_$PIECE(^DPT(DFN,0),U)
End DoDot:1
+6 QUIT
+7 ; Return list of patients on a ward
WARDPTS(DATA,LOC) ;EP
+1 NEW CNT,DFN,WARD,QUALS
+2 IF +$GET(LOC)<1
SET DATA(1)="^No ward identified."
QUIT
+3 SET WARD=+$GET(^SC(+LOC,42))
+4 IF '$DATA(^DIC(42,WARD,0))
SET DATA(1)="^Not a valid ward."
QUIT
+5 SET (CNT,DFN)=0
SET WARD=$PIECE(^DIC(42,WARD,0),U)
SET DATA(1)="^No patients found."
+6 FOR
SET DFN=+$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
IF $$ISACTIVE^BEHOPTCX(DFN,.QUALS)
Begin DoDot:1
+7 SET CNT=CNT+1
SET DATA(CNT)=DFN_U_$PIECE(^DPT(DFN,0),U)_U_$PIECE($GET(^DPT(DFN,.101)),U)
+8 SET DATA(CNT)=DATA(CNT)_U_$PIECE($$ADMITINF^BEHOENCX(DFN,^DPT("CN",WARD,DFN)),U)
End DoDot:1
+9 QUIT
+10 ; Returns all teams to which a user belongs
+11 ; PER = If nonzero, return personal lists. Otherwise, return team lists.
TEAMLST(DATA,PER) ;EP
+1 NEW CNT,IEN,X
+2 SET (CNT,IEN)=0
SET PER=''$GET(PER)
+3 FOR
SET IEN=$ORDER(^OR(100.21,"C",DUZ,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET X=$GET(^OR(100.21,IEN,0))
+5 IF $PIECE(X,U,2)="P"=PER
SET CNT=CNT+1
SET DATA(CNT)=IEN_U_X
End DoDot:1
+6 QUIT
+7 ; Return list of patients belonging to a team
TEAMPTS(DATA,TEAM) ;EP
+1 NEW CNT,IEN,DFN,QUALS
+2 SET DATA(1)="^No patients found."
SET (CNT,IEN)=0
SET TEAM=+TEAM
+3 IF '$DATA(^OR(100.21,TEAM,0))
SET DATA(1)="^Not a valid team."
QUIT
+4 FOR
SET IEN=$ORDER(^OR(100.21,TEAM,10,IEN))
IF 'IEN
QUIT
SET DFN=+$GET(^(IEN,0))
Begin DoDot:1
+5 IF $$ISACTIVE^BEHOPTCX(DFN,.QUALS)
SET CNT=CNT+1
SET DATA(CNT)=DFN_U_$PIECE(^DPT(DFN,0),U)
End DoDot:1
+6 QUIT
+7 ; Return list of locations
HOSPLOC(DATA,FROM,DIR,MAX,TYPE,START,END) ;EP
+1 DO HOSPLOC^BEHOENCX(.DATA,.FROM,.DIR,.MAX,.TYPE,.START,.END)
+2 QUIT
