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

BDPADD.m

Go to the documentation of this file. 
  1. BDPADD ; IHS/CMI/TMJ - ADD A NEW DESIGNATED PROVIDER ;
  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.  F  D MAIN Q:BDPQ  D HDR^BDP
  1.  D EOJ
  1.  Q
  1.  ;
  1. MAIN ;
  1.  S BDPQ=0
  1.  ;S BDPMODE="A",BDPLOOK=""
  1.  D PATIENT ;              get patient Name
  1.  Q:BDPQ
  1.  D PROVDISP
  1.  I BDPQ=1 G GETTYPE
  1.  ;
  1.  D ASK
  1.  Q:BDPQ
  1.  ;
  1. GETTYPE ;Do Get Date if no existing Designated Providers
  1.  D TYPE ;                 get Provider Category Type
  1.  Q:BDPQ
  1.  D ADD ;                  add new Designated Provider record
  1.  ;Q:BDPQ
  1.  Q
  1.  ;
  1. PATIENT ; GET PATIENT
  1.  F  D PATIENT2 I BDPQ!($G(BDPDFN)) Q
  1.  Q
  1.  ;
  1. PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS
  1.  S BDPQ=1
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D DIC^BDPFMC
  1.  Q:Y<1
  1.  S BDPDFN=+Y,BDPREC("PAT NAME")=$P(^DPT(+Y,0),U)
  1.  S BDPQ=0
  1.  I $$DOD^AUPNPAT(BDPDFN) D  I 'Y K BDPDFN,BDPREC("PAT NAME") Q
  1.  . W !!,"This patient is deceased."
  1.  . S DIR(0)="YO",DIR("A")="Are you sure you want this patient",DIR("B")="NO" K DA D ^DIR K DIR
  1.  . W !
  1.  . Q
  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 with adding a new Designated Provider",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. PROVDISP ;Display if Patient has existing Designated Providers
  1.  W !!,?25,"********************",!
  1.  W ?10,"**CURRENT DESIGNATED PROVIDERS - BY PROVIDER CATEGORY TYPE**",!
  1.  W !,?15,"Assigned to Patient: "
  1.  W ?35,$P($G(^DPT(BDPDFN,0)),U)
  1.  W !,?25,"********************"
  1.  W !,?10,"**CATEGORY TYPE**",?46,"**CURRENT PROVIDER ASSIGNED**",!
  1.  I '$D(^BDPRECN("AA",BDPDFN)) W !,?20,"**--NO EXISTING DESIGNATED PROVIDERS--**",! S BDPQ=1 Q
  1.  S BDPQ=0
  1.  S BDPTYPE=""
  1.  S BDPCOUNT=0
  1.  F I=1:1:100 S BDPTYPE=$O(^BDPRECN("AA",BDPDFN,BDPTYPE)) Q:BDPTYPE=""  S BDPCOUNT=BDPCOUNT+1 D NEXT
  1.  Q
  1. NEXT ;2ND $O
  1.  S BDPRIEN=""
  1.  F  S BDPRIEN=$O(^BDPRECN("AA",BDPDFN,BDPTYPE,BDPRIEN)) Q:BDPRIEN'=+BDPRIEN  D
  1.  . Q:BDPTYPE=""
  1.  . Q:BDPRIEN=""
  1.  . S BDPPTNAM=$P(^DPT(BDPDFN,0),U,1) ;Patient Print Name
  1.  . S BDPTYPNM=$P(^BDPTCAT(BDPTYPE,0),U,1) ;Type Print
  1.  . S BDPCPRV=$P($G(^BDPRECN(BDPRIEN,0)),U,3) ;Current Provider IEN
  1.  . I BDPCPRV="" S BDPCPRVP="<None Currently Assigned>" ;If no current Provider
  1.  . E  S BDPCPRVP=$P(^VA(200,BDPCPRV,0),U,1) ;Provider Print Name
  1.  . W !,?5,BDPCOUNT,?10,$E(BDPTYPNM,1,30),?50,$E(BDPCPRVP,1,35)
  1.  . S I=I+1 ; increment outer loop counter to limit display to 10 Designated Providers
  1.  . Q
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1. TYPE ; GET CATEGORY TYPE FOR DESIGNATED PROVIDER
  1.  W !
  1.  S BDPQ=1
  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.  S BDPQ=0
  1.  Q
  1. PROV ; GET DESIGNATED PROVIDER
  1.  S BDPPROV="",BDPQ=1
  1.  S DIC("A")="Select New Designated Provider: ",DIC="^VA(200,",DIC(0)="AEMQ"
  1.  I $$GET1^DIQ(90360.3,BDPTYPE,.01)="MESSAGE AGENT" S DIC("S")="I $D(^BDPMSGA(+Y,0)),'$P(^BDPMSGA(+Y,0),U,3)" K DIC("B")
  1.  I $$GET1^DIQ(90360.3,BDPTYPE,.01)'="MESSAGE AGENT" S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  D ^DIC K DIC,DA S:$D(DUOUT) DIRUT=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. ADD ; ADD NEW DESIGNATED PROVIDER RECORD
  1.  S BDPQ=1
  1.  S BDPRR=$O(^BDPRECN("AA",BDPDFN,BDPTYPE,"")) ;Check to see if this Patient already has Type
  1.  I BDPRR'="" S BDPLPROV=$P($G(^BDPRECN(BDPRR,0)),U,3) ;Current Provider
  1.  I BDPRR>0 W !!,?10,"This patient already has a Designated Provider Type",!,"   the Category you selected. See the Designated Provider Listing above."
  1.  I BDPRR>0 W !!,"-Use the MOD menu item to change to a new CURRENT Provider for this Category Type-",!! D PAUSE^BDP Q
  1.  ;
  1.  D PROV
  1.  Q:BDPQ
  1. ASKGO ;Ask to continue
  1.  ;
  1.  W !!,"Okay, you have selected DESIGNATED PROVIDER : ",BDPRPRVP,!
  1.  W "To be assigned to Patient Name: "_$P($G(^DPT(BDPDFN,0)),U,1) W !
  1.  W "For Designated Provider Category/Type: "_$P($G(^BDPTCAT(BDPTYPE,0)),U,1) W !!
  1.  ;
  1.  ;
  1.  S DIR(0)="Y",DIR("A")="Do you wish to Continue with the Adding of the new Designated Provider",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.  W !!,"Okay I will add this provider to this patient record! ",! D  Q
  1.  .S DIC="^BDPRECN(",DIC(0)="L",DLAYGO=90360.1,DIC("DR")=".02////"_BDPDFN,X=BDPTYPE
  1.  .D FILE^BDPFMC
  1.  .I Y<0 W !,"Error creating DESIGNATED PROVIDER.",!,"Notify programmer.",! D EOP^BDP Q
  1.  .W !!,"DESIGNATED PROVIDER : ",BDPRPRVP,!
  1.  . W "Has been assigned to Patient Name: "_$P($G(^DPT(BDPDFN,0)),U,1) W !
  1.  . W "For Designated Provider Category/Type: "_$P($G(^BDPTCAT(BDPTYPE,0)),U,1) W !!
  1.  .S BDPRIEN=+Y
  1.  .;SEEMS TO ME THE MULTIPLE IEN WILL ALWAYS BE 1 SO NO NEED TO GET THE LAST AND INACTIVATE IT OR PUT IN A STOP DATE
  1.  .I $D(BDPRIEN) D
  1.  .. Q:'BDPRIEN
  1.  .. S:'$D(^BDPRECN(BDPRIEN,1,0)) $P(^(0),U,2)="90360.11P"
  1.  .. S BDPLIEN=$P($G(^BDPRECN(BDPRIEN,1,0)),U,3) ;Last IEN in Multiple
  1.  .. I BDPLIEN="" S BDPLIEN=0
  1.  .. S BDPLNUM=$P($G(^BDPRECN(BDPRIEN,1,0)),U,4) ;Las Number in Multiple
  1.  .. I BDPLNUM="" S BDPLNUM=0
  1.  .. S BDPLIEN=BDPLIEN+1
  1.  .. S BDPLNUM=BDPLNUM+1
  1.  .. S $P(^BDPRECN(BDPRIEN,1,0),U,3)=BDPLIEN
  1.  .. S $P(^BDPRECN(BDPRIEN,1,0),U,4)=BDPLNUM
  1.  .. S BDPLINKI=1  ;tell fileman you are coming from bdp
  1.  .. S DR=".01///"_"`"_BDPPROV_";.04////"_DT  ;ihs/cmi/lab - added effective date
  1.  .. S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=BDPLIEN D ^DIE K DIE,DR,DA,DINUM
  1.  . D PAUSE^BDP
  1.  .S BDPQ=0
  1.  .Q
  1. EOJ ; END OF JOB
  1.  D ^BDPKILL
  1.  Q
  1.  ;
  1.  ;
  1. INFORM ;Data Entry Explanation
  1.  ;
  1.  W !,?20,"******************************"
  1.  W !,?3,"Utilize this Option to Add a NEW Designated Specialty Provider Record.",!
  1.  W ?3,"If the Patient has already been assigned an Existing Provider for the",!,?3,"Category selected - you must use the MODIFY Data Entry Menu Option",!,?3,"to CHANGE the Existing Provider for this Patient's Category Type.",!
  1.  W ?20,"******************************",!
  1.  Q