BDPAMA ;IHS/CMI/LAB - ASSIGN MESSAGE AGENT ; 05 Jun 2018 11:09 AM
;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34
;
; Subscripted BDPREC is EXTERNAL form.
; BDPREC("PAT NAME")=patient name
; BDPREC("PROV TYPE")=Provider Category Type
; BDPDFN=patient ien
; BDPRDATE=date in internal FileMan form
; BDPRIEN=Designated Provider ien
;
START ;
;
D INFORM ;Data Entry Explanation
;
D MAIN Q:BDPQ D HDR^BDP
D EOJ
Q
;
MAIN ;
S BDPQ=0,BDPYI=0
D OLDPROV ; get Old Existing Provider
Q:BDPQ
D COUNT
Q:BDPQ ;Quit No Records for this Provider
;D ASK
;Q:BDPQ
S DIC="^BDPTCAT(",X="MESSAGE AGENT",DIC(0)="MQ" D ^DIC K DIC
I Y=-1 W !!,"can't find message agent category" Q
S BDPTYPE=+Y
D MA
I BDPQ=1 G MAIN
;
D ASKGO ; add new Designated Provider record
S BDPQ=0
Q
;
OLDPROV ; GET OLD EXISTING PROVIDER
;
S BDPOPROV="",BDPQ=0
W !!,"Select the Provider for whose patients you want to assign a message agent."
S DIC("A")="Select Provider: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA S:$D(DUOUT) DIRUT=1,BDPQ=1
I +Y<1 S BDPQ=1 Q
Q:$D(DIRUT)
S BDPOPROV=+Y,BDPOPRVP=$P(Y,U,2)
S BDPOPRVP=$P(^VA(200,BDPOPROV,0),U,1) ;Provider Print Name
S BDPQ=0
Q
;
COUNT ;Count of # Patients for this Old Provider
S BDPI="",BDPQ=0,BDPYI=0
F S BDPI=$O(^BDPRECN("AC",BDPOPROV,BDPI)) Q:BDPI="" S BDPYI=BDPYI+1
W !!?10,"There are ",BDPYI," patients currently assigned to this Provider."
I BDPYI=0 S BDPQ=1 ;More than one patient exists for Provider
K BDPI,BDPYI
W !
W !
Q
;
;
ASK ;Ask to Continue
S BDPQ=0
W !! S DIR(0)="Y",DIR("A")="Do you want to continue changing the Designated Provider for each Patient?",DIR("B")="Y" K DA D ^DIR K DIR
I $D(DIRUT) S BDPQ=1 Q
I 'Y S BDPQ=1 Q
Q
;
;
TYPE ; GET CATEGORY TYPE FOR DESIGNATED PROVIDER
W !
S BDPQ=1
S DIR(0)="90360.1,.01",DIR("B")="DPCP" K DA D ^DIR K DIR
Q:$D(DIRUT)
S BDPTYPE=+Y,BDPREC("PROV TYPE")=Y(0)
I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",'$D(^BDPMSGA("B",BDPPROV)) D G TYPE
.W !!,"The provider you selected is not listed as a Message Agent, he/she must "
.W !,"be added to the Message Agent List using the option on the Manager's "
.W !,"Menu before they can be assigned as a message agent.",!
I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",$P($G(^BDPMSGA(BDPPROV,0)),U,3) D G TYPE
.W !!,"The provider you selected has been inactivated as a message agent, he/she"
.W !," must be reactivated using the option on the Manager's Menu before they can "
.W !,"be assigned as a message agent.",!
;
S BDPQ=0
Q
MA ; GET MESSAGE
S BDPPROV="",BDPQ=0
S DIC("A")="Select Message Agent: ",DIC="^BDPMSGA(",DIC("S")="I '$P(^(0),U,3)",DIC(0)="AEMQ" D ^DIC K DIC,DA S:$D(DUOUT) DIRUT=1,BDPQ=1
Q:$D(DIRUT)
I +Y<1 S BDPQ=1 Q
S BDPPROV=+Y,BDPRPROV=$P(Y,U,2)
S BDPRPRVP=$P(^VA(200,BDPPROV,0),U,1) ;Provider Print Name
S BDPQ=0
Q
;
ASKGO ;Ask to continue
;
W !!!,?8,"*****************************************************************",!
W !!,?8,"Okay, you have selected Provider : ",BDPOPRVP,!
W ?8,"Patients who have that provider assigned to them will be",!
W ?8,"assigned Message Agent: ",$$VAL^XBDIQ1(200,BDPPROV,.01) W !!
W !,?8,"*********************************************************************",!
;
;
S DIR(0)="Y",DIR("A")="Do you wish to Continue to add the Message Agent to each patient",DIR("?")="Enter Y for Yes or N for NO",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S BDPQ=1 Q
I Y=0 S BDPQ=1 Q
;
;
UPDATE ;Update Records
;
S BDPIEN="" F S BDPIEN=$O(^BDPRECN("AC",BDPOPROV,BDPIEN)) Q:BDPIEN'=+BDPIEN D
. Q:BDPIEN=""
. ;S BDPTYPEM=$P($G(^BDPRECN(BDPIEN,0)),U) ;Type to Match On
. ;Q:BDPTYPEM=""
. ;Q:BDPTYPE=""
. ;I BDPTYPE'=BDPTYPEM Q ;Quit if No Match
. S BDPPAT=$P($G(^BDPRECN(BDPIEN,0)),U,2) ;Patient
. Q:BDPPAT=""
. Q:BDPPROV="" ;Quit if No New Provider
. S X=$$CREATE(BDPPAT,BDPTYPE,BDPPROV) Q
;
Q
;
CREATE(BDPDFN,BDPTYPE,BDPRPRVP) ;EP - Entry Point to Create
;
N BDPRR,BDPLINKI,BDPLPROV,BDPRIEN,BDPLINKI
;
S BDPQ=1
S BDPLINKI=1 ;tell xrefs we are in bdp
S BDPRPROV=$P($G(^VA(200,BDPRPRVP,0)),U) ;Provider Text Name
S BDPRR=$O(^BDPRECN("AA",BDPDFN,BDPTYPE,"")) ;Check to see if this Patient already has Type
I BDPRR="" D ADDNEW Q BDPQ ;NONE OF THIS TYPE
S BDPLPROV=$P($G(^BDPRECN(BDPRR,0)),U,3) ;Current Provider
Q:BDPLPROV=BDPRPRVP 0 ;Quit if Same Provider Selected as Current
S BDPRIEN=BDPRR D MOD Q 0
Q 0
;
ADDNEW ;Add a new Record
K DIC S DIC="^BDPRECN(",DIC(0)="L",DLAYGO=90360.1,DIC("DR")=".02////"_BDPDFN,X=BDPTYPE
D FILE^BDPFMC
K DIC,DLAYGO,DIADD
I Y<0 W !,"Error creating DESIGNATED PROVIDER.",!,"Notify programmer.",! D EOP^BDP Q
;
S BDPRIEN=+Y
;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2),DIC("DR")=".04////"_DT D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK ;IHS/CMI/LAB - PATCH 21 ADDED SETTING OF .04 EFFECTIVE DATE
S BDPQ=0
K BDPLINKI
Q
;
MOD ;Modify an Existing Provider Type for this Patient
S BDPLINKI=1
;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
S Z=0,X=0 F S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X S Z=X
I Z,$P(^BDPRECN(BDPRIEN,1,Z,0),U,5)="" S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=Z,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM,X,Y,Z
;now add new one
S DIADD=1,X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2),DIC("DR")=".04////"_DT D ^DIC K DIC,DIADD,DR
I Y=-1 S BDPQ=0 Q
K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK ;IHS/CIM/LAB - ADDED SETTING OF .04 EFFECTIVE DATE PATCH 21
;
S DIE="^BDPRECN(",DA=BDPRIEN,DR=".03///`"_BDPRPRVP_";.04////"_DUZ_";.05////"_DT D ^DIE,^XBFMK
S BDPQ=0
K BDPLINKI
Q
;
MSGEND ;End of Add Message
W !!!!,"Okay - I have changed all Patient Records - as follows: ",! D Q
.W !,"Patients that had: ",BDPOPRVP," assigned to them.",!
. W "Have been assigned Message Agent:"_BDPRPRVP W !
. D PAUSE^BDP
S BDPQ=0
Q
;
;
EOJ ; END OF JOB
D ^BDPKILL
Q
;
INFORM ;Data Entry Explanation
;
W !,?3,"This option is used to assign a Message Agent to any patient who"
W !,"has a particular provider assigned to them. For example, if you want"
W !,"to assign message agent Mary Smith, RN to all of Dr. Miller's patients"
W !,"you can do so with this option."
W !!!,"PLEASE NOTE: If the patient already has a message agent assigned"
W !,"this option will replace that message agent with the new one you are"
W !,"assigning.",!
Q
BDPAMA ;IHS/CMI/LAB - ASSIGN MESSAGE AGENT ; 05 Jun 2018 11:09 AM
+1 ;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34
+2 ;
+3 ; Subscripted BDPREC is EXTERNAL form.
+4 ; BDPREC("PAT NAME")=patient name
+5 ; BDPREC("PROV TYPE")=Provider Category Type
+6 ; BDPDFN=patient ien
+7 ; BDPRDATE=date in internal FileMan form
+8 ; BDPRIEN=Designated Provider ien
+9 ;
START ;
+1 ;
+2 ;Data Entry Explanation
DO INFORM
+3 ;
+4 DO MAIN
IF BDPQ
QUIT
DO HDR^BDP
+5 DO EOJ
+6 QUIT
+7 ;
MAIN ;
+1 SET BDPQ=0
SET BDPYI=0
+2 ; get Old Existing Provider
DO OLDPROV
+3 IF BDPQ
QUIT
+4 DO COUNT
+5 ;Quit No Records for this Provider
IF BDPQ
QUIT
+6 ;D ASK
+7 ;Q:BDPQ
+8 SET DIC="^BDPTCAT("
SET X="MESSAGE AGENT"
SET DIC(0)="MQ"
DO ^DIC
KILL DIC
+9 IF Y=-1
WRITE !!,"can't find message agent category"
QUIT
+10 SET BDPTYPE=+Y
+11 DO MA
+12 IF BDPQ=1
GOTO MAIN
+13 ;
+14 ; add new Designated Provider record
DO ASKGO
+15 SET BDPQ=0
+16 QUIT
+17 ;
OLDPROV ; GET OLD EXISTING PROVIDER
+1 ;
+2 SET BDPOPROV=""
SET BDPQ=0
+3 WRITE !!,"Select the Provider for whose patients you want to assign a message agent."
+4 SET DIC("A")="Select Provider: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
IF $DATA(DUOUT)
SET DIRUT=1
SET BDPQ=1
+5 IF +Y<1
SET BDPQ=1
QUIT
+6 IF $DATA(DIRUT)
QUIT
+7 SET BDPOPROV=+Y
SET BDPOPRVP=$PIECE(Y,U,2)
+8 ;Provider Print Name
SET BDPOPRVP=$PIECE(^VA(200,BDPOPROV,0),U,1)
+9 SET BDPQ=0
+10 QUIT
+11 ;
COUNT ;Count of # Patients for this Old Provider
+1 SET BDPI=""
SET BDPQ=0
SET BDPYI=0
+2 FOR
SET BDPI=$ORDER(^BDPRECN("AC",BDPOPROV,BDPI))
IF BDPI=""
QUIT
SET BDPYI=BDPYI+1
+3 WRITE !!?10,"There are ",BDPYI," patients currently assigned to this Provider."
+4 ;More than one patient exists for Provider
IF BDPYI=0
SET BDPQ=1
+5 KILL BDPI,BDPYI
+6 WRITE !
+7 WRITE !
+8 QUIT
+9 ;
+10 ;
ASK ;Ask to Continue
+1 SET BDPQ=0
+2 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue changing the Designated Provider for each Patient?"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET BDPQ=1
QUIT
+4 IF 'Y
SET BDPQ=1
QUIT
+5 QUIT
+6 ;
+7 ;
TYPE ; GET CATEGORY TYPE FOR DESIGNATED PROVIDER
+1 WRITE !
+2 SET BDPQ=1
+3 SET DIR(0)="90360.1,.01"
SET DIR("B")="DPCP"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET BDPTYPE=+Y
SET BDPREC("PROV TYPE")=Y(0)
+6 IF $PIECE(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT"
IF '$DATA(^BDPMSGA("B",BDPPROV))
Begin DoDot:1
+7 WRITE !!,"The provider you selected is not listed as a Message Agent, he/she must "
+8 WRITE !,"be added to the Message Agent List using the option on the Manager's "
+9 WRITE !,"Menu before they can be assigned as a message agent.",!
End DoDot:1
GOTO TYPE
+10 IF $PIECE(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT"
IF $PIECE($GET(^BDPMSGA(BDPPROV,0)),U,3)
Begin DoDot:1
+11 WRITE !!,"The provider you selected has been inactivated as a message agent, he/she"
+12 WRITE !," must be reactivated using the option on the Manager's Menu before they can "
+13 WRITE !,"be assigned as a message agent.",!
End DoDot:1
GOTO TYPE
+14 ;
+15 SET BDPQ=0
+16 QUIT
MA ; GET MESSAGE
+1 SET BDPPROV=""
SET BDPQ=0
+2 SET DIC("A")="Select Message Agent: "
SET DIC="^BDPMSGA("
SET DIC("S")="I '$P(^(0),U,3)"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
IF $DATA(DUOUT)
SET DIRUT=1
SET BDPQ=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF +Y<1
SET BDPQ=1
QUIT
+5 SET BDPPROV=+Y
SET BDPRPROV=$PIECE(Y,U,2)
+6 ;Provider Print Name
SET BDPRPRVP=$PIECE(^VA(200,BDPPROV,0),U,1)
+7 SET BDPQ=0
+8 QUIT
+9 ;
ASKGO ;Ask to continue
+1 ;
+2 WRITE !!!,?8,"*****************************************************************",!
+3 WRITE !!,?8,"Okay, you have selected Provider : ",BDPOPRVP,!
+4 WRITE ?8,"Patients who have that provider assigned to them will be",!
+5 WRITE ?8,"assigned Message Agent: ",$$VAL^XBDIQ1(200,BDPPROV,.01)
WRITE !!
+6 WRITE !,?8,"*********************************************************************",!
+7 ;
+8 ;
+9 SET DIR(0)="Y"
SET DIR("A")="Do you wish to Continue to add the Message Agent to each patient"
SET DIR("?")="Enter Y for Yes or N for NO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
SET BDPQ=1
QUIT
+11 IF Y=0
SET BDPQ=1
QUIT
+12 ;
+13 ;
UPDATE ;Update Records
+1 ;
+2 SET BDPIEN=""
FOR
SET BDPIEN=$ORDER(^BDPRECN("AC",BDPOPROV,BDPIEN))
IF BDPIEN'=+BDPIEN
QUIT
Begin DoDot:1
+3 IF BDPIEN=""
QUIT
+4 ;S BDPTYPEM=$P($G(^BDPRECN(BDPIEN,0)),U) ;Type to Match On
+5 ;Q:BDPTYPEM=""
+6 ;Q:BDPTYPE=""
+7 ;I BDPTYPE'=BDPTYPEM Q ;Quit if No Match
+8 ;Patient
SET BDPPAT=$PIECE($GET(^BDPRECN(BDPIEN,0)),U,2)
+9 IF BDPPAT=""
QUIT
+10 ;Quit if No New Provider
IF BDPPROV=""
QUIT
+11 SET X=$$CREATE(BDPPAT,BDPTYPE,BDPPROV)
QUIT
End DoDot:1
+12 ;
+13 QUIT
+14 ;
CREATE(BDPDFN,BDPTYPE,BDPRPRVP) ;EP - Entry Point to Create
+1 ;
+2 NEW BDPRR,BDPLINKI,BDPLPROV,BDPRIEN,BDPLINKI
+3 ;
+4 SET BDPQ=1
+5 ;tell xrefs we are in bdp
SET BDPLINKI=1
+6 ;Provider Text Name
SET BDPRPROV=$PIECE($GET(^VA(200,BDPRPRVP,0)),U)
+7 ;Check to see if this Patient already has Type
SET BDPRR=$ORDER(^BDPRECN("AA",BDPDFN,BDPTYPE,""))
+8 ;NONE OF THIS TYPE
IF BDPRR=""
DO ADDNEW
QUIT BDPQ
+9 ;Current Provider
SET BDPLPROV=$PIECE($GET(^BDPRECN(BDPRR,0)),U,3)
+10 ;Quit if Same Provider Selected as Current
IF BDPLPROV=BDPRPRVP
QUIT 0
+11 SET BDPRIEN=BDPRR
DO MOD
QUIT 0
+12 QUIT 0
+13 ;
ADDNEW ;Add a new Record
+1 KILL DIC
SET DIC="^BDPRECN("
SET DIC(0)="L"
SET DLAYGO=90360.1
SET DIC("DR")=".02////"_BDPDFN
SET X=BDPTYPE
+2 DO FILE^BDPFMC
+3 KILL DIC,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"Error creating DESIGNATED PROVIDER.",!,"Notify programmer.",!
DO EOP^BDP
QUIT
+5 ;
+6 SET BDPRIEN=+Y
+7 ;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
+8 ;IHS/CMI/LAB - PATCH 21 ADDED SETTING OF .04 EFFECTIVE DATE
SET X="`"_BDPRPRVP
SET DIC="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(90360.1,.06,0),U,2)
SET DIC("DR")=".04////"_DT
DO ^DIC
KILL DIC,DA,DR,Y,X,DIADD,DLAYGO
DO ^XBFMK
+9 SET BDPQ=0
+10 KILL BDPLINKI
+11 QUIT
+12 ;
MOD ;Modify an Existing Provider Type for this Patient
+1 SET BDPLINKI=1
+2 ;S X="`"_BDPRPRVP,DIC="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DIC(0)="L",DIC("P")=$P(^DD(90360.1,.06,0),U,2) D ^DIC K DIC,DA,DR,Y,X,DIADD,DLAYGO D ^XBFMK
+3 ;FIND THE LAST MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
+4 SET Z=0
SET X=0
FOR
SET X=$ORDER(^BDPRECN(BDPRIEN,1,X))
IF X'=+X
QUIT
SET Z=X
+5 IF Z
IF $PIECE(^BDPRECN(BDPRIEN,1,Z,0),U,5)=""
SET DIE="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DA=Z
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM,X,Y,Z
+6 ;now add new one
+7 SET DIADD=1
SET X="`"_BDPRPRVP
SET DIC="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(90360.1,.06,0),U,2)
SET DIC("DR")=".04////"_DT
DO ^DIC
KILL DIC,DIADD,DR
+8 IF Y=-1
SET BDPQ=0
QUIT
+9 ;IHS/CIM/LAB - ADDED SETTING OF .04 EFFECTIVE DATE PATCH 21
KILL DIC,DA,DR,Y,X,DIADD,DLAYGO
DO ^XBFMK
+10 ;
+11 SET DIE="^BDPRECN("
SET DA=BDPRIEN
SET DR=".03///`"_BDPRPRVP_";.04////"_DUZ_";.05////"_DT
DO ^DIE
DO ^XBFMK
+12 SET BDPQ=0
+13 KILL BDPLINKI
+14 QUIT
+15 ;
MSGEND ;End of Add Message
+1 WRITE !!!!,"Okay - I have changed all Patient Records - as follows: ",!
Begin DoDot:1
+2 WRITE !,"Patients that had: ",BDPOPRVP," assigned to them.",!
+3 WRITE "Have been assigned Message Agent:"_BDPRPRVP
WRITE !
+4 DO PAUSE^BDP
End DoDot:1
QUIT
+5 SET BDPQ=0
+6 QUIT
+7 ;
+8 ;
EOJ ; END OF JOB
+1 DO ^BDPKILL
+2 QUIT
+3 ;
INFORM ;Data Entry Explanation
+1 ;
+2 WRITE !,?3,"This option is used to assign a Message Agent to any patient who"
+3 WRITE !,"has a particular provider assigned to them. For example, if you want"
+4 WRITE !,"to assign message agent Mary Smith, RN to all of Dr. Miller's patients"
+5 WRITE !,"you can do so with this option."
+6 WRITE !!!,"PLEASE NOTE: If the patient already has a message agent assigned"
+7 WRITE !,"this option will replace that message agent with the new one you are"
+8 WRITE !,"assigning.",!
+9 QUIT
