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

BDPDPEE.m

Go to the documentation of this file. 
  1. BDPDPEE ; IHS/CMI/TMJ - UPDATE USING LISTMAN ; 
  1.  ;;2.0;IHS PCC SUITE;**2,10,20,21**;MAY 14, 2009;Build 34
  1.  ;
  1.  ;
  1. START ;
  1.  NEW BDPX,BDPY,BDPR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BDPV,BDPBD,BDPED
  1.  NEW D,R
  1.  K BDPV
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("View/Update Designated Provider List",80)
  1. PROV ;
  1.  D ^XBFMK
  1.  S BDPDP=""
  1.  W !! S DIC("A")="Enter Designated Provider Name: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Provider Selected." Q
  1.  S BDPPIEN=+Y
  1.  S X=$$CHKPROV(BDPPIEN) I X Q
  1.  D EN
  1. END ;
  1.  D EOJ
  1.  K BDPP,BDPQUIT,BDPW
  1.  Q
  1.  ;
  1. CHKPROV(PROV) ;
  1.  NEW X,Y,BDPQ,BDPG
  1.  S BDPQ=0,BDPG=0
  1.  S X=$$VAL^XBDIQ1(200,PROV,53.4) I X]"" D
  1.  .W !!,"Please Note:  This provider was inactivated on ",X,!
  1.  .S BDPG=1
  1.  I '$D(^VA(200,"AK.PROVIDER",$P($G(^VA(200,PROV,0)),U),PROV)) D
  1.  .W !!,"Please Note:  This person does not have the PROVIDER key and therefore",!,"should not be used as the designated primary care provider.",!
  1.  .S BDPG=1
  1.  I 'BDPG Q 0
  1.  NEW DIR
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue with the update",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  W !
  1.  I 'Y Q 1
  1.  Q 0
  1. PPEP(BDPPIEN) ;PEP - entry point to view/update one provider's panel
  1.  I '$G(BDPPIEN) Q
  1.  D EN
  1.  Q
  1. EN ;EP -- main entry point for BDP UPDATE PATIENT DATA
  1.  D EN^VALM("BDP DESG PROVIDER UPDATE")
  1.  K BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(2)="Patients with Designated Provider: "_$P(^VA(200,BDPPIEN,0),U)
  1.  S VALMHDR(3)="*I or *D denotes patient is Inactive or Deceased"
  1.  S VALMHDR(4)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(5)="#      HRN    PATIENT NAME            DOB      SEX LAST VISIT   PROV TYPE"
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. INIT ; -- init variables and list array
  1.  S VALMSG="?? for more actions  + next screen  - prev screen"
  1.  D GATHER ;gather up all records for display
  1.  S VALMCNT=BDPLINE
  1.  Q
  1.  ;
  1. GATHER ;
  1.  K ^TMP("BDPDPEE",$J),^TMP($J,"BDPDPEE")
  1.  S BDPD=0 F  S BDPD=$O(^BDPRECN("AC",BDPPIEN,BDPD)) Q:BDPD'=+BDPD  S ^TMP($J,"BDPDPEE",$P(^DPT($P(^BDPRECN(BDPD,0),U,2),0),U),BDPD)=""
  1.  S BDPRCNT=0,BDPLINE=0
  1.  S BDPNAME=0 F  S BDPNAME=$O(^TMP($J,"BDPDPEE",BDPNAME)) Q:BDPNAME=""  D
  1.  .S BDPX=0 F  S BDPX=$O(^TMP($J,"BDPDPEE",BDPNAME,BDPX)) Q:BDPX'=+BDPX  D
  1.  ..S BDPRCNT=BDPRCNT+1,BDPLINE=BDPLINE+1,Y=BDPRCNT
  1.  ..S BDPD=$P(^BDPRECN(BDPX,0),U,2)
  1.  ..I $$DOD^AUPNPAT(BDPD)]"" S Y=Y_" *D"
  1.  ..E  I $P($G(^AUPNPAT(BDPD,41,DUZ(2),0)),U,3)]"" S Y=Y_" *I"
  1.  ..S $E(Y,8)=$$HRN^AUPNPAT(BDPD,DUZ(2)),$E(Y,15)=$E($P(^DPT(BDPD,0),U),1,20),$E(Y,39)=$$DATE^BDPLMDSP($$DOB^AUPNPAT(BDPD)),$E(Y,48)=$P(^DPT(BDPD,0),U,2),$E(Y,52)=$$DATE^BDPLMDSP($$LASTVD^APCLV1(BDPD))
  1.  ..S $E(Y,62)=$$VAL^XBDIQ1(90360.1,BDPX,.01)
  1.  ..S ^TMP("BDPDPEE",$J,BDPLINE,0)=Y,^TMP("BDPDPEE",$J,"IDX",BDPLINE,BDPRCNT)=BDPX
  1.  Q  ;new 
  1.  ;
  1. CHG ;EP - Called from Protocol to change from One Provider to Another
  1.  ;
  1.  D FULL^VALM1
  1.  S DIR(0)="LO^:",DIR("A")="Change which selected item" K DA D ^DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No items selected." G EXIT
  1.  I $D(DIRUT) W !,"No Item selected." G EXIT
  1.  S BDPANS=Y ;Selected Items
  1.  W ! S DIC("A")="Enter New Designated Provider Name: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("B")=$P(^VA(200,DUZ,0),U)
  1.  D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Provider Selected." D PAUSE G EXIT
  1.  S BDPPROV=+Y
  1.  S X=$$CHKPROV(BDPPROV) I X G EXIT
  1.  S BDPC="" F BDPI=1:1 S BDPC=$P(BDPANS,",",BDPI) Q:BDPC=""  S BDPR=^TMP("BDPDPEE",$J,"IDX",BDPC,BDPC) D
  1.  . I '$D(^BDPRECN(BDPR,0)) Q
  1.  . S BDPPAT=$P(^BDPRECN(BDPR,0),U,2)
  1.  . S BDPTYPE=$P(^BDPRECN(BDPR,0),U) ; TYPE
  1.  . I $$GET1^DIQ(90360.3,BDPTYPE,.01)="MESSAGE AGENT",'$D(^BDPMSGA("B",BDPPROV)) W !!,"Cannot assign as Message Agent (not in message agent file)-RECORD ",BDPC D PAUSE^BDP Q
  1.  . I $$GET1^DIQ(90360.3,BDPTYPE,.01)="MESSAGE AGENT",$P($G(^BDPMSGA(BDPPROV,0)),U,3) W !!,"Cannot assign as Message Agent (inactive message agent)-RECORD ",BDPC D PAUSE^BDP Q
  1.  . S X=$$CREATE^BDPAMA(BDPPAT,BDPTYPE,BDPPROV)
  1.  W !,"Changed the selected Providers",!
  1.  D EXIT
  1.  Q
  1. RMDP ;EP - called from protocol to remove multiple DP entries
  1.  S DIR(0)="LO^:",DIR("A")="Remove which selected item" K DA D ^DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No items selected." G EXIT
  1.  I $D(DIRUT) W !,"No Item selected." G EXIT
  1.  S BDPANS=Y,BDPC="" F BDPI=1:1 S BDPC=$P(BDPANS,",",BDPI) Q:BDPC=""  S BDPR=^TMP("BDPDPEE",$J,"IDX",BDPC,BDPC) D
  1.  . I '$D(^BDPRECN(BDPR,0)) Q
  1.  . S BDPPAT=$P(^BDPRECN(BDPR,0),U,2)
  1.  . S BDPTYPE=$P(^BDPRECN(BDPR,0),U) ; TYPE
  1.  . D DELETE^BDPPASS
  1.  ;D FULL^VALM1
  1.  ;W !,"Removing ",$P(^VA(200,BDPPIEN,0),U)," as the ",$$VAL^XBDIQ1(90360.1,BDPR,.01)," provider for ",!,$P(^DPT(BDPPAT,0),U)," ..."
  1.  ;D DELETE^BDPPASS
  1.  W !,"Removed the selected Providers",!
  1.  D EXIT
  1.  Q
  1. GETTYPE ;
  1.  S APCHSTYP=""
  1.  S X="",DIC(0)="AEMQL",DIC="^APCHSCTL(" D ^DIC K DIC,DA
  1.  I Y=-1 W !!,"NO TYPE SELECTED.",!! Q
  1.  S APCHSTYP=+Y
  1.  Q
  1. HS ;EP called from protocol to generate hs
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." Q
  1.  S DFN=+Y
  1.  S Y=DFN D ^AUPNPAT
  1.  D GETTYPE
  1.  I '$G(APCHSTYP) D EN^XBVK("APCH"),PAUSE,EXIT Q
  1.  S APCHSPAT=DFN
  1.  S %="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
  1.  D VIEWR^XBLM("EN^APCHS",%)
  1.  D EN^XBVK("APCH") K AMCHDAYS,AMCHDOB,%
  1.  D EXIT
  1.  Q
  1. ADDDP ;EP called from protocol to open a new case
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  S BDPPAT=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." Q
  1.  S BDPPAT=+Y
  1. ADDDP1 S BDPTYPE=""
  1.  K DIR S DIR(0)="90360.1,.01",DIR("A")="Enter the Type of Designated Provider" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"TYPE not entered." D PAUSE,EXIT Q
  1.  S BDPTYPE=+Y
  1.  I $D(^BDPRECN("AA",BDPPAT,BDPTYPE)) S X=$O(^BDPRECN("AA",BDPPAT,BDPTYPE,0)) I $P($G(^BDPRECN(X,0)),U,3)'="" D  I BDPQ D PAUSE,EXIT Q
  1.  .W !!,"This patient already has provider ",$P(^VA(200,$P($G(^BDPRECN(X,0)),U,3),0),U)," assigned for category ",!?5,$P(^BDPTCAT(BDPTYPE,0),U)
  1.  .K DIR
  1.  .S BDPQ=""
  1.  .S DIR(0)="Y",DIR("A")="Do you want to change the provider to "_$P(^VA(200,BDPPIEN,0),U,1),DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  .I 'Y S BDPQ=1 Q
  1.  I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",'$D(^BDPMSGA("B",BDPPIEN)) D  G ADDDP1
  1.  .W !!,"This person is not listed as a Message Agent, they must be added to the Message"
  1.  .W !,"Agent List using the option on the Manager's Menu before they can be "
  1.  .W !,"assigned as a message agent.",!
  1.  I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",$P($G(^BDPMSGA(BDPPIEN,0)),U,3) D  G ADDDP1
  1.  .W !!,"This person been inactivated as a message agent, they must be reactivated"
  1.  .W !,"using the option on the Manager's Menu before they can be assigned"
  1.  .W !,"as a message agent.",!
  1.  S X=$$CREATE^BDPAMA(BDPPAT,BDPTYPE,BDPPIEN)
  1.  D EXIT
  1.  Q
  1.  ;
  1. GATHER1 ;EP Called from Protocol to Resort List Display
  1.  ;
  1.  S BDPSANS=""
  1.  ;
  1. BDPASK ;Ask User Type of Sort
  1.  ;
  1.  S DIR(0)="S^1:PATIENT;2:CATEGORY",DIR("A")="Enter Type of Lister Display Sort: ",DIR("B")="PATIENT",DIR("?")="You must select a Sort Type from the List" KILL DA D ^DIR KILL DIR
  1.  I Y<0 W !,"NO SORT SELECTED.",!! Q
  1.  S BDPSANS=Y
  1.  D EXIT
  1.  Q
  1.  ;
  1. GATHER2 ;Resort by Provider
  1.  ;
  1.  K ^TMP("BDPDPEE",$J),^TMP($J,"BDPDPEE")
  1.  S BDPD=0 F  S BDPD=$O(^BDPRECN("AC",BDPPIEN,BDPD)) Q:BDPD'=+BDPD  S ^TMP($J,"BDPDPEE",$P(^BDPRECN(BDPD,0),U),BDPD)=""
  1.  S BDPRCNT=0,BDPLINE=0
  1.  S BDPNAME=0 F  S BDPNAME=$O(^TMP($J,"BDPDPEE",BDPNAME)) Q:BDPNAME=""  D
  1.  .S BDPX=0 F  S BDPX=$O(^TMP($J,"BDPDPEE",BDPNAME,BDPX)) Q:BDPX'=+BDPX  D
  1.  ..S BDPRCNT=BDPRCNT+1,BDPLINE=BDPLINE+1,Y=BDPRCNT
  1.  ..S BDPD=$P(^BDPRECN(BDPX,0),U,2)
  1.  ..S $E(Y,8)=$$HRN^AUPNPAT(BDPD,DUZ(2)),$E(Y,15)=$E($P(^DPT(BDPD,0),U),1,20),$E(Y,39)=$$DATE^BDPLMDSP($$DOB^AUPNPAT(BDPD)),$E(Y,48)=$P(^DPT(BDPD,0),U,2),$E(Y,52)=$$DATE^BDPLMDSP($$LASTVD^APCLV1(BDPD))
  1.  ..S $E(Y,62)=$$VAL^XBDIQ1(90360.1,BDPX,.01)
  1.  ..S ^TMP("BDPDPEE",$J,BDPLINE,0)=Y,^TMP("BDPDPEE",$J,"IDX",BDPLINE,BDPRCNT)=BDPX
  1.  Q  ;new 
  1. HELP ;EP -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K BDPX,BDPCASE,BDPPC,BDPR1,BDPPAT,DFN
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  I '$D(BDPSANS) D GATHER S VALMCNT=BDPLINE D HDR K X,Y,Z,I Q
  1.  I BDPSANS=1 D GATHER S VALMCNT=BDPLINE D HDR K X,Y,Z,I Q
  1.  I BDPSANS=2 D GATHER2 S VALMCNT=BDPLINE D HDR K X,Y,Z,I Q
  1.  I BDPSANS="" D GATHER S VALMCNT=BDPLINE D HDR K X,Y,Z,I Q
  1. PAUSE ;EP
  1.  S DIR(0)="EO",DIR("A")="Press ENTER to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("BDP")
  1.  K DFN
  1.  K DDSFILE,DIPGM,Y
  1.  K X,Y,%,DR,DDS,DA,DIC
  1.  K BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE
  1.  D:$D(VALMWD) CLEAR^VALM1
  1.  K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,VALMON,VALMEVL,VALMIOXY
  1.  D KILL^AUPNPAT
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;