BPHRCHK.m

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