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

BDPLMUPD.m

Go to the documentation of this file. 
  1. BDPLMUPD ; 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.  W:$D(IOF) @IOF
  1.  W $$CTR("View/Update Designated Provider List",80)
  1. PAT ;
  1.  D ^XBFMK
  1.  S BDPPAT=""
  1.  W !! S DIC("A")="Enter Patient Name: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." G END
  1.  S BDPPAT=+Y
  1.  I $$DOD^AUPNPAT(BDPPAT)]"" W !!,"*****Note:  Patient is Decesased.  DOD:  ",$$FMTE^XLFDT($$DOD^AUPNPAT(BDPPAT)) W !! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
  1.  D EN
  1. END ;
  1.  D EOJ
  1.  K BDPP,BDPQUIT,BDPW
  1.  Q
  1.  ;
  1. PPEP(BDPPAT,BDPTYPE) ;PEP - entry point to view/update one patient's providers
  1.  ;BDPPAT - patient DFN
  1.  I '$G(BDPPAT) Q
  1.  ;D EN^XBNEW("EN^BDPLMUPD","BDPPAT")
  1.  D EN
  1.  ;D FULL^VALM1
  1.  Q
  1. EN ; -- main entry point for BDP UPDATE 
  1.  D EN^VALM("BDP DESG PROV UPD - 1 PAT")
  1.  D EN^XBVK("BDP")
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(2)="Designated Provider List for: "_$P(^DPT(BDPPAT,0),U)_"   HRN: "_$$HRN^AUPNPAT(BDPPAT,DUZ(2),2)
  1.  S C=3
  1.  I $$DOD^AUPNPAT(BDPPAT)]"" S VALMHDR(C)="Patient is Deceased.  DOD:  "_$$FMTE^XLFDT($$DOD^AUPNPAT(BDPPAT)) S C=C+1
  1.  S VALMHDR(C)=$TR($J(" ",80)," ","-")
  1.  S C=C+1
  1.  S VALMHDR(C)="#    Category",$E(VALMHDR(C),35)="Provider",$E(VALMHDR(C),70)="Updated"
  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 BDPLIST
  1.  S BDPRCNT=0,BDPLINE=0
  1.  S BDPD=0 F  S BDPD=$O(^BDPRECN("AA",BDPPAT,BDPD)) Q:BDPD'=+BDPD  D
  1.  .S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPD,0))
  1.  .Q:$P($G(^BDPRECN(BDPX,0)),U,3)=""
  1.  .S BDPRCNT=BDPRCNT+1,BDPLINE=BDPLINE+1,Y=BDPRCNT
  1.  .S $E(Y,5)=$E($$VAL^XBDIQ1(90360.1,BDPX,.01),1,28)
  1.  .S $E(Y,35)=$E($$VAL^XBDIQ1(90360.1,BDPX,.03),1,30)
  1.  .;S BDPY=$P(^BDPRECN(BDPX,0),U,3)
  1.  .;S $E(Y,57)=$E($$VAL^XBDIQ1(200,BDPY,53.5),1,13)
  1.  .S $E(Y,70)=$$FMTE^XLFDT($P(^BDPRECN(BDPX,0),U,5),5)
  1.  .S BDPLIST(BDPLINE,0)=Y,BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX
  1.  Q
  1.  ;
  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 CLEAR^VALM1,FULL^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.  ;
  1. HS ;EP called from protocol to generate hs
  1.  D FULL^VALM1
  1.  D EN^XBNEW("HS1^BDPLMUPD","BDPPAT")
  1.  D BACK
  1.  Q
  1. HS1 ;EP - called from xbnew
  1.  S X=""
  1.  I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3) I X,$D(^APCHSCTL(X,0)) S X=$P(^APCHSCTL(X,0),U)
  1.  I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
  1.  I Y=-1 D PAUSE,BACK Q
  1.  S APCHSTYP=+Y,APCHSPAT=BDPPAT
  1.  S BDPHDR="PCC Health Summary for "_$P(^DPT(BDPPAT,0),U)
  1.  D VIEWR^XBLM("EN^APCHS",BDPHDR)
  1.  S (DFN,Y)=BDPPAT D ^AUPNPAT
  1.  D BACK
  1.  Q
  1.  ;
  1. BACK ;
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=BDPLINE
  1.  D HDR
  1.  Q
  1. PAUSE ;EP
  1.  NEW DIR
  1.  S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR
  1.  Q
  1.  ;
  1. EXIT ;EP
  1.  Q
  1.  ;
  1. ADD ;EP - add a new dp
  1.  D FULL^VALM1
  1.  NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
  1.  W !!
  1.  S DIC="^BDPTCAT(",DIC(0)="AEMQ",DIC("A")="Enter the PROVIDER Category: " D ^DIC K DIC
  1.  I Y<0 W !,"No updating done...." D PAUSE,BACK Q
  1.  S BDPCIEN=+Y
  1.  I $D(^BDPRECN("AA",BDPPAT,BDPCIEN)) S X=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0)) I $P($G(^BDPRECN(X,0)),U,3)'="" D  D PAUSE,BACK Q
  1.  .W !!,"This patient already has a provider assigned for category ",!?5,$P(^BDPTCAT(BDPCIEN,0),U)
  1.  .W !,"Please use the CH (Change Provider) action item to change this provider."
  1.  ;get provider name for this category
  1.  W !
  1.  S DIC=200,DIC(0)="AEMQ",DIC("A")="Enter Provider Name: " ;,DIC("B")=$P(^VA(200,DUZ,0),U)
  1.  I $$GET1^DIQ(90360.3,BDPCIEN,.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.  I $$GET1^DIQ(90360.3,BDPCIEN,.01)="MESSAGE AGENT" S DIC("S")="I $D(^BDPMSGA(+Y,0)),'$P(^BDPMSGA(+Y,0),U,3)" K DIC("B")
  1.  D ^DIC K DIC
  1.  I Y<0 W !,"No updating done...." D PAUSE,BACK Q
  1.  S BDPPROV=+Y
  1.  ;add new entry for this patient
  1.  S X=$$ADD1^BDPAPI(BDPPAT,BDPCIEN)
  1.  I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
  1.  S BDPRIEN=X
  1.  S X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
  1.  I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
  1.  W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
  1.  D PAUSE
  1.  D BACK
  1.  Q
  1.  ;
  1. CHANGE ;EP - change existing DP
  1.  D FULL^VALM1
  1.  ;
  1.  NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
  1.  D GETITEM
  1.  I '$G(BDPRIEN) D PAUSE,BACK Q
  1.  I 'BDPRIEN W !,"No item selected to change." D PAUSE,BACK Q
  1.  S BDPCIEN=$P(^BDPRECN(BDPRIEN,0),U)
  1.  W ! S DIC("A")="Enter New Designated "_$$VAL^XBDIQ1(90360.1,BDPRIEN,.01)_": ",DIC="^VA(200,",DIC(0)="AEMQ" ;,DIC("B")=$P(^VA(200,DUZ,0),U)
  1.  I $$GET1^DIQ(90360.3,BDPCIEN,.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.  I $$GET1^DIQ(90360.3,BDPCIEN,.01)="MESSAGE AGENT" S DIC("S")="I $D(^BDPMSGA(+Y,0)),'$P(^BDPMSGA(+Y,0),U,3)" K DIC("B")
  1.  D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Provider Selected." D PAUSE,BACK Q
  1.  S BDPPROV=+Y
  1.  I $P(^BDPRECN(BDPRIEN,0),U,3)=BDPPROV W !!,"That is the currently documented provider." D PAUSE,BACK Q
  1.  S X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
  1.  I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
  1.  W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
  1.  D PAUSE
  1.  D BACK
  1.  Q
  1. DELETE ;EP - delete exisiting DP
  1.  D FULL^VALM1
  1.  ;
  1.  NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
  1.  D GETITEM
  1.  I '$G(BDPRIEN) D PAUSE,BACK Q
  1.  I 'BDPRIEN W !,"No item selected to DELETE." D PAUSE,BACK Q
  1.  S BDPCIEN=$P(^BDPRECN(BDPRIEN,0),U)
  1.  W !!,"Are you sure you want to DELETE ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.03),!?3,"as the designated ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.01),"?"
  1.  K DIR S DIR(0)="Y",DIR("A")="Please confirm",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D PAUSE,BACK Q
  1.  I 'Y D PAUSE,BACK Q
  1.  S BDPPROV=$$VALI^XBDIQ1(90360.1,BDPRIEN,.03)
  1.  NEW DA,DIE,DR,BDPLINKI  ;P19
  1.  S BDPLINKI=1
  1.  ;NEW DA,DIE,DR
  1.  S DA=BDPRIEN,DIE="^BDPRECN(",DR=".03///@;.04////"_DUZ_";.05////"_DT D ^DIE K DIE,DA,DR
  1.  ;FIND THE MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
  1.  NEW X,Y
  1.  S X=0 F  S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X  I $P(^BDPRECN(BDPRIEN,1,X,0),U,1)=BDPPROV S Y=X
  1.  I Y,$P(^BDPRECN(BDPRIEN,1,Y,0),U,5)="" S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=Y,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
  1.  W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully DELETED as",!," the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
  1.  D PAUSE
  1.  D BACK
  1.  Q
  1.  ;
  1. GETITEM ;get record
  1.  I 'BDPRCNT W !,"No Items to change" Q
  1.  NEW BDPIT
  1.  S BDPRIEN=0
  1.  S DIR(0)="N^1:"_BDPRCNT_":0",DIR("A")="Select item to change" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  S BDPIT=Y
  1.  S (X,Y)=0 F  S X=$O(BDPLIST("IDX",X)) Q:X'=+X!(BDPRIEN)  I $O(BDPLIST("IDX",X,0))=BDPIT S Y=$O(BDPLIST("IDX",X,0)),BDPRIEN=BDPLIST("IDX",X,Y)
  1.  I '$D(^BDPRECN(BDPRIEN,0)) S BDPRIEN=0 Q
  1.  Q
  1. HELP ;EP -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;