BPHRCHK ;GDIT/HS/ALA-PHR System Check ; 16 Feb 2018 11:42 AM
;;2.1;IHS PERSONAL HEALTH RECORD;**2**;Apr 01, 2014;Build 4
;
EN ;EP - Check PHR connection with a patient
NEW QFLG,RESULT,DFN,BPHREUID
S QFLG=0 D LIP Q:QFLG
I $P($G(^AUTTLOC(DUZ(2),21)),"^",5)="" D EN^DDIOL("Location "_$P(^DIC(4,DUZ(2),0),"^",1)_" does not have DIRECT email address.","","!!") Q
D PAT(.RESULT,"","","")
I $P($G(RESULT),"^",10)'="" D EN^DDIOL($P(RESULT,"^",10),"","!!") Q
I $P($G(RESULT),"^",1)=0 D EN^DDIOL("Patient is not signed up for PHR.","","!!") Q
I $P($G(RESULT),"^",1)=-1 D EN^DDIOL("Error occurred, please check error log.","","!!") Q
;accessed PHR (0=No, 1=Yes)^last date^used secure messaging (0=No, 1=Yes)^last date^direct address
I $P($G(RESULT),"^",3)=1 D EN^DDIOL("Patient last accessed PHR on "_$$FMTE^XLFDT($P($G(RESULT),"^",4)),"","!!")
I $P($G(RESULT),"^",7)'="" D EN^DDIOL("Patient has a DIRECT email address","","!!")
Q
;
EN1 ;EP - Check a patient
NEW QFLG,RESULT,DFN,BPHREUID,RANGE
S QFLG=0 D LIP Q:QFLG
I $P($G(^AUTTLOC(DUZ(2),21)),"^",5)="" D EN^DDIOL("Location does not have DIRECT email address.","","!!") Q
;Select provider
S QFLG=0 D PROV Q:QFLG
;
;Select date range
S QFLG=0,RANGE="" D DAT Q:QFLG
I $G(BDT)'="",$G(EDT)'="" D
. S RANGE=$$FMTE^XLFDT(BDT)_"-"_$$FMTE^XLFDT(EDT)_" "
. D EN^DDIOL("Report Calendar Year is "_RANGE,"","!?5")
;
;Select patient
D PAT(.RESULT,BDT,EDT,PROV)
I $P($G(RESULT),"^",10)'="" D EN^DDIOL($P(RESULT,"^",10),"","!!") Q
I $P($G(RESULT),"^",1)=0 D EN^DDIOL("Patient is not signed up for PHR.","","!!?5") Q
I $P($G(RESULT),"^",1)=-1 D EN^DDIOL("Error occurred, please check error log.","","!!?5") Q
;accessed PHR (0=No, 1=Yes)^last date^used secure messaging (0=No, 1=Yes)^last date^direct address
I $P($G(RESULT),"^",3)=1 D EN^DDIOL("Patient last accessed PHR during Calendar Year "_$$FMTE^XLFDT($P($G(RESULT),"^",4)),"","!!?5")
I $P($G(RESULT),"^",7)'="" D EN^DDIOL("Patient has a DIRECT email address","","!!?5")
I $P($G(RESULT),"^",6)'="" D EN^DDIOL("Patient's last DIRECT message during Calendar Year was "_$$FMTE^XLFDT($P($G(RESULT),"^",6)),"","!!?5")
I $P($G(RESULT),"^",6)="" D
. D EN^DDIOL("Patient does not have a record of a DIRECT message.","","!!?5")
D EN^DDIOL("Patient's Message Agents for Calendar Year "_RANGE_"are: ","","!!?5") D AGNT(DFN)
Q
;
LIP ;EN - Is this a Test or Production system
NEW PROD
S PROD=$$PROD^XUPROD()
; PROD=0 is a test system, PROD=1 is a production system
I 'PROD D
. NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
. S DIR("A")="This system has been designated as a TEST system. Is this correct",DIR(0)="Y"
. D ^DIR
. I Y'=1 D EN^DDIOL("Please contact the IHS HELP desk for this issue.","","!!") S QFLG=1
I PROD D
. NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
. S DIR("A")="This system has been designated as a PRODUCTION system. Is this correct",DIR(0)="Y"
. D ^DIR
. I Y'=1 D EN^DDIOL("Please contact the IHS HELP desk for this issue.","","!!") S QFLG=1
Q
;
PAT(RESULT,BDT,EDT,PROV) ;EP - Patient lookup
D GETPAT^APCDDMUP
I $G(DFN)="" D EN^DDIOL("No patient selected.","","!!") Q
S BPHREUID=$P($G(^DPT(DFN,"MPI")),U,1)
I BPHREUID="" D EN^DDIOL("Patient does not have an MPI EUID","","!!") Q
D PHR^BPHRMUPM(DFN,$G(BDT),$G(EDT),.RESULT,$G(PROV))
Q
;
DAT ; EP - Date range
NEW DIR,Y,X
S BDT="",EDT=""
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
D ^DIR I $D(DIRUT) S QFLG=1 Q
I Y<0 S QFLG=1 Q
I Y>DT W !!,"Future dates not allowed." G DAT
S BDT=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
D ^DIR G:Y<1 DAT
S EDT=Y
I EDT<BDT D G DAT
. D EN^DDIOL("Sorry, Ending Date MUST not be earlier than Beginning Date.","","!!?7")
S BDT=$E(BDT,1,3)_"0101",EDT=$E(BDT,1,3)_"1231"
Q
;
PROV ; EP - Select provider
NEW DIC,D,Y
D EN^DDIOL("Enter the name of the provider.","","!!")
S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER NAME: " D MIX^DIC1 K DIC,D
I Y<0 S QFLG=1 Q
S PROV=+Y
Q
;
AGNT(DFN) ;EP = Messaging Agent for Patient
NEW BDPCAT,BDPIEN,MSA,BPA,AGN,ADR,BPDATA,NBP,OK,LBP,CURR,CDT,QL
S ADDR=""
S BDPCAT=$$FIND1^DIC(90360.3,,"X","MESSAGE AGENT")
I BDPCAT="" Q ADDR
S BDPIEN=$O(^BDPRECN("AA",DFN,BDPCAT,""))
I BDPIEN="" Q ADDR
;
I $P(^BDPRECN(BDPIEN,0),"^",3)="" D EN^DDIOL("No Current Message Agent","","!?7")
S BPA=0
F S BPA=$O(^BDPRECN(BDPIEN,1,BPA)) Q:'BPA D
. S BPDATA=^BDPRECN(BDPIEN,1,BPA,0)
. S MSA=$P(^BDPRECN(BDPIEN,1,BPA,0),"^",1)
. S AGN(BPA)=MSA_"^"_$P(BPDATA,"^",3),LBP=BPA
. ; Check the next agent in the history
. S NBP=$O(^BDPRECN(BDPIEN,1,BPA)) I 'NBP D Q
.. S QL=0 D CMA
.. I 'QL S $P(AGN(BPA),"^",3)=DT Q
.. I QL S $P(AGN(BPA),"^",3)=CDT
. S $P(AGN(BPA),"^",3)=$P(^BDPRECN(BDPIEN,1,NBP,0),"^",3)
;
I CURR'="",$P(^BDPRECN(BDPIEN,1,LBP,0),"^",1)'=CURR D
. S AGN(LBP+1)=CURR_"^"_CDT_"^"_DT
;
S MS="" F S MS=$O(AGN(MS)) Q:MS="" D
. S OK=0
. I EDT<$P(AGN(MS),"^",2)!(BDT>$P(AGN(MS),"^",3)) Q
. I BDT'<$P(AGN(MS),"^",2),BDT'>$P(AGN(MS),"^",3) S OK=1
. I EDT'<$P(AGN(MS),"^",2),EDT'>$P(AGN(MS),"^",3) S OK=1
. ;
. I BDT'>$P(AGN(MS),"^",2),EDT'<$P(AGN(MS),"^",2) S OK=1
. I BDT'>$P(AGN(MS),"^",3),EDT'<$P(AGN(MS),"^",3) S OK=1
. ;
. I OK D
.. S MSA=$P(AGN(MS),"^",1)
.. S ADR=$$LOW^XLFSTR($P($G(^BDPMSGA(MSA,0)),"^",2))
.. I ADR'["direct" Q
.. D EN^DDIOL(ADR_" "_$$FMTE^XLFDT($P(AGN(MS),"^",2))_" - "_$$FMTE^XLFDT($P(AGN(MS),"^",3)),"","!?7")
Q
;
CMA ;EP - Check for current messaging agent
S CURR=$P(^BDPRECN(BDPIEN,0),"^",3),CDT=$P(^(0),"^",5)
I CURR="" Q
; If the current provider is matching the last provider in the history
I $P(^BDPRECN(BDPIEN,1,LBP,0),"^",1)=CURR Q
S QL=1
Q
BPHRCHK ;GDIT/HS/ALA-PHR System Check ; 16 Feb 2018 11:42 AM
+1 ;;2.1;IHS PERSONAL HEALTH RECORD;**2**;Apr 01, 2014;Build 4
+2 ;
EN ;EP - Check PHR connection with a patient
+1 NEW QFLG,RESULT,DFN,BPHREUID
+2 SET QFLG=0
DO LIP
IF QFLG
QUIT
+3 IF $PIECE($GET(^AUTTLOC(DUZ(2),21)),"^",5)=""
DO EN^DDIOL("Location "_$PIECE(^DIC(4,DUZ(2),0),"^",1)_" does not have DIRECT email address.","","!!")
QUIT
+4 DO PAT(.RESULT,"","","")
+5 IF $PIECE($GET(RESULT),"^",10)'=""
DO EN^DDIOL($PIECE(RESULT,"^",10),"","!!")
QUIT
+6 IF $PIECE($GET(RESULT),"^",1)=0
DO EN^DDIOL("Patient is not signed up for PHR.","","!!")
QUIT
+7 IF $PIECE($GET(RESULT),"^",1)=-1
DO EN^DDIOL("Error occurred, please check error log.","","!!")
QUIT
+8 ;accessed PHR (0=No, 1=Yes)^last date^used secure messaging (0=No, 1=Yes)^last date^direct address
+9 IF $PIECE($GET(RESULT),"^",3)=1
DO EN^DDIOL("Patient last accessed PHR on "_$$FMTE^XLFDT($PIECE($GET(RESULT),"^",4)),"","!!")
+10 IF $PIECE($GET(RESULT),"^",7)'=""
DO EN^DDIOL("Patient has a DIRECT email address","","!!")
+11 QUIT
+12 ;
EN1 ;EP - Check a patient
+1 NEW QFLG,RESULT,DFN,BPHREUID,RANGE
+2 SET QFLG=0
DO LIP
IF QFLG
QUIT
+3 IF $PIECE($GET(^AUTTLOC(DUZ(2),21)),"^",5)=""
DO EN^DDIOL("Location does not have DIRECT email address.","","!!")
QUIT
+4 ;Select provider
+5 SET QFLG=0
DO PROV
IF QFLG
QUIT
+6 ;
+7 ;Select date range
+8 SET QFLG=0
SET RANGE=""
DO DAT
IF QFLG
QUIT
+9 IF $GET(BDT)'=""
IF $GET(EDT)'=""
Begin DoDot:1
+10 SET RANGE=$$FMTE^XLFDT(BDT)_"-"_$$FMTE^XLFDT(EDT)_" "
+11 DO EN^DDIOL("Report Calendar Year is "_RANGE,"","!?5")
End DoDot:1
+12 ;
+13 ;Select patient
+14 DO PAT(.RESULT,BDT,EDT,PROV)
+15 IF $PIECE($GET(RESULT),"^",10)'=""
DO EN^DDIOL($PIECE(RESULT,"^",10),"","!!")
QUIT
+16 IF $PIECE($GET(RESULT),"^",1)=0
DO EN^DDIOL("Patient is not signed up for PHR.","","!!?5")
QUIT
+17 IF $PIECE($GET(RESULT),"^",1)=-1
DO EN^DDIOL("Error occurred, please check error log.","","!!?5")
QUIT
+18 ;accessed PHR (0=No, 1=Yes)^last date^used secure messaging (0=No, 1=Yes)^last date^direct address
+19 IF $PIECE($GET(RESULT),"^",3)=1
DO EN^DDIOL("Patient last accessed PHR during Calendar Year "_$$FMTE^XLFDT($PIECE($GET(RESULT),"^",4)),"","!!?5")
+20 IF $PIECE($GET(RESULT),"^",7)'=""
DO EN^DDIOL("Patient has a DIRECT email address","","!!?5")
+21 IF $PIECE($GET(RESULT),"^",6)'=""
DO EN^DDIOL("Patient's last DIRECT message during Calendar Year was "_$$FMTE^XLFDT($PIECE($GET(RESULT),"^",6)),"","!!?5")
+22 IF $PIECE($GET(RESULT),"^",6)=""
Begin DoDot:1
+23 DO EN^DDIOL("Patient does not have a record of a DIRECT message.","","!!?5")
End DoDot:1
+24 DO EN^DDIOL("Patient's Message Agents for Calendar Year "_RANGE_"are: ","","!!?5")
DO AGNT(DFN)
+25 QUIT
+26 ;
LIP ;EN - Is this a Test or Production system
+1 NEW PROD
+2 SET PROD=$$PROD^XUPROD()
+3 ; PROD=0 is a test system, PROD=1 is a production system
+4 IF 'PROD
Begin DoDot:1
+5 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+6 SET DIR("A")="This system has been designated as a TEST system. Is this correct"
SET DIR(0)="Y"
+7 DO ^DIR
+8 IF Y'=1
DO EN^DDIOL("Please contact the IHS HELP desk for this issue.","","!!")
SET QFLG=1
End DoDot:1
+9 IF PROD
Begin DoDot:1
+10 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+11 SET DIR("A")="This system has been designated as a PRODUCTION system. Is this correct"
SET DIR(0)="Y"
+12 DO ^DIR
+13 IF Y'=1
DO EN^DDIOL("Please contact the IHS HELP desk for this issue.","","!!")
SET QFLG=1
End DoDot:1
+14 QUIT
+15 ;
PAT(RESULT,BDT,EDT,PROV) ;EP - Patient lookup
+1 DO GETPAT^APCDDMUP
+2 IF $GET(DFN)=""
DO EN^DDIOL("No patient selected.","","!!")
QUIT
+3 SET BPHREUID=$PIECE($GET(^DPT(DFN,"MPI")),U,1)
+4 IF BPHREUID=""
DO EN^DDIOL("Patient does not have an MPI EUID","","!!")
QUIT
+5 DO PHR^BPHRMUPM(DFN,$GET(BDT),$GET(EDT),.RESULT,$GET(PROV))
+6 QUIT
+7 ;
DAT ; EP - Date range
+1 NEW DIR,Y,X
+2 SET BDT=""
SET EDT=""
+3 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date"
+4 DO ^DIR
IF $DATA(DIRUT)
SET QFLG=1
QUIT
+5 IF Y<0
SET QFLG=1
QUIT
+6 IF Y>DT
WRITE !!,"Future dates not allowed."
GOTO DAT
+7 SET BDT=Y
+8 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date"
+9 DO ^DIR
IF Y<1
GOTO DAT
+10 SET EDT=Y
+11 IF EDT<BDT
Begin DoDot:1
+12 DO EN^DDIOL("Sorry, Ending Date MUST not be earlier than Beginning Date.","","!!?7")
End DoDot:1
GOTO DAT
+13 SET BDT=$EXTRACT(BDT,1,3)_"0101"
SET EDT=$EXTRACT(BDT,1,3)_"1231"
+14 QUIT
+15 ;
PROV ; EP - Select provider
+1 NEW DIC,D,Y
+2 DO EN^DDIOL("Enter the name of the provider.","","!!")
+3 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET D="AK.PROVIDER"
SET DIC("A")="Enter PROVIDER NAME: "
DO MIX^DIC1
KILL DIC,D
+4 IF Y<0
SET QFLG=1
QUIT
+5 SET PROV=+Y
+6 QUIT
+7 ;
AGNT(DFN) ;EP = Messaging Agent for Patient
+1 NEW BDPCAT,BDPIEN,MSA,BPA,AGN,ADR,BPDATA,NBP,OK,LBP,CURR,CDT,QL
+2 SET ADDR=""
+3 SET BDPCAT=$$FIND1^DIC(90360.3,,"X","MESSAGE AGENT")
+4 IF BDPCAT=""
QUIT ADDR
+5 SET BDPIEN=$ORDER(^BDPRECN("AA",DFN,BDPCAT,""))
+6 IF BDPIEN=""
QUIT ADDR
+7 ;
+8 IF $PIECE(^BDPRECN(BDPIEN,0),"^",3)=""
DO EN^DDIOL("No Current Message Agent","","!?7")
+9 SET BPA=0
+10 FOR
SET BPA=$ORDER(^BDPRECN(BDPIEN,1,BPA))
IF 'BPA
QUIT
Begin DoDot:1
+11 SET BPDATA=^BDPRECN(BDPIEN,1,BPA,0)
+12 SET MSA=$PIECE(^BDPRECN(BDPIEN,1,BPA,0),"^",1)
+13 SET AGN(BPA)=MSA_"^"_$PIECE(BPDATA,"^",3)
SET LBP=BPA
+14 ; Check the next agent in the history
+15 SET NBP=$ORDER(^BDPRECN(BDPIEN,1,BPA))
IF 'NBP
Begin DoDot:2
+16 SET QL=0
DO CMA
+17 IF 'QL
SET $PIECE(AGN(BPA),"^",3)=DT
QUIT
+18 IF QL
SET $PIECE(AGN(BPA),"^",3)=CDT
End DoDot:2
QUIT
+19 SET $PIECE(AGN(BPA),"^",3)=$PIECE(^BDPRECN(BDPIEN,1,NBP,0),"^",3)
End DoDot:1
+20 ;
+21 IF CURR'=""
IF $PIECE(^BDPRECN(BDPIEN,1,LBP,0),"^",1)'=CURR
Begin DoDot:1
+22 SET AGN(LBP+1)=CURR_"^"_CDT_"^"_DT
End DoDot:1
+23 ;
+24 SET MS=""
FOR
SET MS=$ORDER(AGN(MS))
IF MS=""
QUIT
Begin DoDot:1
+25 SET OK=0
+26 IF EDT<$PIECE(AGN(MS),"^",2)!(BDT>$PIECE(AGN(MS),"^",3))
QUIT
+27 IF BDT'<$PIECE(AGN(MS),"^",2)
IF BDT'>$PIECE(AGN(MS),"^",3)
SET OK=1
+28 IF EDT'<$PIECE(AGN(MS),"^",2)
IF EDT'>$PIECE(AGN(MS),"^",3)
SET OK=1
+29 ;
+30 IF BDT'>$PIECE(AGN(MS),"^",2)
IF EDT'<$PIECE(AGN(MS),"^",2)
SET OK=1
+31 IF BDT'>$PIECE(AGN(MS),"^",3)
IF EDT'<$PIECE(AGN(MS),"^",3)
SET OK=1
+32 ;
+33 IF OK
Begin DoDot:2
+34 SET MSA=$PIECE(AGN(MS),"^",1)
+35 SET ADR=$$LOW^XLFSTR($PIECE($GET(^BDPMSGA(MSA,0)),"^",2))
+36 IF ADR'["direct"
QUIT
+37 DO EN^DDIOL(ADR_" "_$$FMTE^XLFDT($PIECE(AGN(MS),"^",2))_" - "_$$FMTE^XLFDT($PIECE(AGN(MS),"^",3)),"","!?7")
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
CMA ;EP - Check for current messaging agent
+1 SET CURR=$PIECE(^BDPRECN(BDPIEN,0),"^",3)
SET CDT=$PIECE(^(0),"^",5)
+2 IF CURR=""
QUIT
+3 ; If the current provider is matching the last provider in the history
+4 IF $PIECE(^BDPRECN(BDPIEN,1,LBP,0),"^",1)=CURR
QUIT
+5 SET QL=1
+6 QUIT
