Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDPAMA

BDPAMA.m

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