BDPLMUPD ; IHS/CMI/TMJ - UPDATE USING LISTMAN ;
;;2.0;IHS PCC SUITE;**2,10,20,21**;MAY 14, 2009;Build 34
;
;
START ;
W:$D(IOF) @IOF
W $$CTR("View/Update Designated Provider List",80)
PAT ;
D ^XBFMK
S BDPPAT=""
W !! S DIC("A")="Enter Patient Name: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." G END
S BDPPAT=+Y
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
D EN
END ;
D EOJ
K BDPP,BDPQUIT,BDPW
Q
;
PPEP(BDPPAT,BDPTYPE) ;PEP - entry point to view/update one patient's providers
;BDPPAT - patient DFN
I '$G(BDPPAT) Q
;D EN^XBNEW("EN^BDPLMUPD","BDPPAT")
D EN
;D FULL^VALM1
Q
EN ; -- main entry point for BDP UPDATE
D EN^VALM("BDP DESG PROV UPD - 1 PAT")
D EN^XBVK("BDP")
Q
;
HDR ; -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Designated Provider List for: "_$P(^DPT(BDPPAT,0),U)_" HRN: "_$$HRN^AUPNPAT(BDPPAT,DUZ(2),2)
S C=3
I $$DOD^AUPNPAT(BDPPAT)]"" S VALMHDR(C)="Patient is Deceased. DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(BDPPAT)) S C=C+1
S VALMHDR(C)=$TR($J(" ",80)," ","-")
S C=C+1
S VALMHDR(C)="# Category",$E(VALMHDR(C),35)="Provider",$E(VALMHDR(C),70)="Updated"
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
INIT ; -- init variables and list array
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER ;gather up all records for display
S VALMCNT=BDPLINE
Q
;
GATHER ;
K BDPLIST
S BDPRCNT=0,BDPLINE=0
S BDPD=0 F S BDPD=$O(^BDPRECN("AA",BDPPAT,BDPD)) Q:BDPD'=+BDPD D
.S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPD,0))
.Q:$P($G(^BDPRECN(BDPX,0)),U,3)=""
.S BDPRCNT=BDPRCNT+1,BDPLINE=BDPLINE+1,Y=BDPRCNT
.S $E(Y,5)=$E($$VAL^XBDIQ1(90360.1,BDPX,.01),1,28)
.S $E(Y,35)=$E($$VAL^XBDIQ1(90360.1,BDPX,.03),1,30)
.;S BDPY=$P(^BDPRECN(BDPX,0),U,3)
.;S $E(Y,57)=$E($$VAL^XBDIQ1(200,BDPY,53.5),1,13)
.S $E(Y,70)=$$FMTE^XLFDT($P(^BDPRECN(BDPX,0),U,5),5)
.S BDPLIST(BDPLINE,0)=Y,BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX
Q
;
EOJ ;
D EN^XBVK("BDP")
K DFN
K DDSFILE,DIPGM,Y
K X,Y,%,DR,DDS,DA,DIC
K BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE
D CLEAR^VALM1,FULL^VALM1
K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,VALMON,VALMEVL,VALMIOXY
D KILL^AUPNPAT
Q
;
EXPND ; -- expand code
Q
;
HS ;EP called from protocol to generate hs
D FULL^VALM1
D EN^XBNEW("HS1^BDPLMUPD","BDPPAT")
D BACK
Q
HS1 ;EP - called from xbnew
S X=""
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)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
I Y=-1 D PAUSE,BACK Q
S APCHSTYP=+Y,APCHSPAT=BDPPAT
S BDPHDR="PCC Health Summary for "_$P(^DPT(BDPPAT,0),U)
D VIEWR^XBLM("EN^APCHS",BDPHDR)
S (DFN,Y)=BDPPAT D ^AUPNPAT
D BACK
Q
;
BACK ;
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=BDPLINE
D HDR
Q
PAUSE ;EP
NEW DIR
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR
Q
;
EXIT ;EP
Q
;
ADD ;EP - add a new dp
D FULL^VALM1
NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
W !!
S DIC="^BDPTCAT(",DIC(0)="AEMQ",DIC("A")="Enter the PROVIDER Category: " D ^DIC K DIC
I Y<0 W !,"No updating done...." D PAUSE,BACK Q
S BDPCIEN=+Y
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
.W !!,"This patient already has a provider assigned for category ",!?5,$P(^BDPTCAT(BDPCIEN,0),U)
.W !,"Please use the CH (Change Provider) action item to change this provider."
;get provider name for this category
W !
S DIC=200,DIC(0)="AEMQ",DIC("A")="Enter Provider Name: " ;,DIC("B")=$P(^VA(200,DUZ,0),U)
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)="""""
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")
D ^DIC K DIC
I Y<0 W !,"No updating done...." D PAUSE,BACK Q
S BDPPROV=+Y
;add new entry for this patient
S X=$$ADD1^BDPAPI(BDPPAT,BDPCIEN)
I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
S BDPRIEN=X
S X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
D PAUSE
D BACK
Q
;
CHANGE ;EP - change existing DP
D FULL^VALM1
;
NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
D GETITEM
I '$G(BDPRIEN) D PAUSE,BACK Q
I 'BDPRIEN W !,"No item selected to change." D PAUSE,BACK Q
S BDPCIEN=$P(^BDPRECN(BDPRIEN,0),U)
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)
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)="""""
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")
D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Provider Selected." D PAUSE,BACK Q
S BDPPROV=+Y
I $P(^BDPRECN(BDPRIEN,0),U,3)=BDPPROV W !!,"That is the currently documented provider." D PAUSE,BACK Q
S X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
I 'X W !!,"error updating designated provider" D PAUSE,BACK Q
W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
D PAUSE
D BACK
Q
DELETE ;EP - delete exisiting DP
D FULL^VALM1
;
NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
D GETITEM
I '$G(BDPRIEN) D PAUSE,BACK Q
I 'BDPRIEN W !,"No item selected to DELETE." D PAUSE,BACK Q
S BDPCIEN=$P(^BDPRECN(BDPRIEN,0),U)
W !!,"Are you sure you want to DELETE ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.03),!?3,"as the designated ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.01),"?"
K DIR S DIR(0)="Y",DIR("A")="Please confirm",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE,BACK Q
I 'Y D PAUSE,BACK Q
S BDPPROV=$$VALI^XBDIQ1(90360.1,BDPRIEN,.03)
NEW DA,DIE,DR,BDPLINKI ;P19
S BDPLINKI=1
;NEW DA,DIE,DR
S DA=BDPRIEN,DIE="^BDPRECN(",DR=".03///@;.04////"_DUZ_";.05////"_DT D ^DIE K DIE,DA,DR
;FIND THE MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
NEW X,Y
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
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
W !!,"Provider ",$P(^VA(200,BDPPROV,0),U)," successfully DELETED as",!," the designated ",$P(^BDPTCAT(BDPCIEN,0),U)," provider.",!
D PAUSE
D BACK
Q
;
GETITEM ;get record
I 'BDPRCNT W !,"No Items to change" Q
NEW BDPIT
S BDPRIEN=0
S DIR(0)="N^1:"_BDPRCNT_":0",DIR("A")="Select item to change" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BDPIT=Y
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)
I '$D(^BDPRECN(BDPRIEN,0)) S BDPRIEN=0 Q
Q
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
BDPLMUPD ; IHS/CMI/TMJ - UPDATE USING LISTMAN ;
+1 ;;2.0;IHS PCC SUITE;**2,10,20,21**;MAY 14, 2009;Build 34
+2 ;
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE $$CTR("View/Update Designated Provider List",80)
PAT ;
+1 DO ^XBFMK
+2 SET BDPPAT=""
+3 WRITE !!
SET DIC("A")="Enter Patient Name: "
SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Patient Selected."
GOTO END
+5 SET BDPPAT=+Y
+6 IF $$DOD^AUPNPAT(BDPPAT)]""
WRITE !!,"*****Note: Patient is Decesased. DOD: ",$$FMTE^XLFDT($$DOD^AUPNPAT(BDPPAT))
WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+7 DO EN
END ;
+1 DO EOJ
+2 KILL BDPP,BDPQUIT,BDPW
+3 QUIT
+4 ;
PPEP(BDPPAT,BDPTYPE) ;PEP - entry point to view/update one patient's providers
+1 ;BDPPAT - patient DFN
+2 IF '$GET(BDPPAT)
QUIT
+3 ;D EN^XBNEW("EN^BDPLMUPD","BDPPAT")
+4 DO EN
+5 ;D FULL^VALM1
+6 QUIT
EN ; -- main entry point for BDP UPDATE
+1 DO EN^VALM("BDP DESG PROV UPD - 1 PAT")
+2 DO EN^XBVK("BDP")
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+2 SET VALMHDR(2)="Designated Provider List for: "_$PIECE(^DPT(BDPPAT,0),U)_" HRN: "_$$HRN^AUPNPAT(BDPPAT,DUZ(2),2)
+3 SET C=3
+4 IF $$DOD^AUPNPAT(BDPPAT)]""
SET VALMHDR(C)="Patient is Deceased. DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(BDPPAT))
SET C=C+1
+5 SET VALMHDR(C)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+6 SET C=C+1
+7 SET VALMHDR(C)="# Category"
SET $EXTRACT(VALMHDR(C),35)="Provider"
SET $EXTRACT(VALMHDR(C),70)="Updated"
+8 QUIT
+9 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
INIT ; -- init variables and list array
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 ;gather up all records for display
DO GATHER
+3 SET VALMCNT=BDPLINE
+4 QUIT
+5 ;
GATHER ;
+1 KILL BDPLIST
+2 SET BDPRCNT=0
SET BDPLINE=0
+3 SET BDPD=0
FOR
SET BDPD=$ORDER(^BDPRECN("AA",BDPPAT,BDPD))
IF BDPD'=+BDPD
QUIT
Begin DoDot:1
+4 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPD,0))
+5 IF $PIECE($GET(^BDPRECN(BDPX,0)),U,3)=""
QUIT
+6 SET BDPRCNT=BDPRCNT+1
SET BDPLINE=BDPLINE+1
SET Y=BDPRCNT
+7 SET $EXTRACT(Y,5)=$EXTRACT($$VAL^XBDIQ1(90360.1,BDPX,.01),1,28)
+8 SET $EXTRACT(Y,35)=$EXTRACT($$VAL^XBDIQ1(90360.1,BDPX,.03),1,30)
+9 ;S BDPY=$P(^BDPRECN(BDPX,0),U,3)
+10 ;S $E(Y,57)=$E($$VAL^XBDIQ1(200,BDPY,53.5),1,13)
+11 SET $EXTRACT(Y,70)=$$FMTE^XLFDT($PIECE(^BDPRECN(BDPX,0),U,5),5)
+12 SET BDPLIST(BDPLINE,0)=Y
SET BDPLIST("IDX",BDPLINE,BDPRCNT)=BDPX
End DoDot:1
+13 QUIT
+14 ;
EOJ ;
+1 DO EN^XBVK("BDP")
+2 KILL DFN
+3 KILL DDSFILE,DIPGM,Y
+4 KILL X,Y,%,DR,DDS,DA,DIC
+5 KILL BDPCASE,BDPX,BDPD,BDPRCNT,BDPLINE,BDPCDATE
+6 DO CLEAR^VALM1
DO FULL^VALM1
+7 KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,VALMON,VALMEVL,VALMIOXY
+8 DO KILL^AUPNPAT
+9 QUIT
+10 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
HS ;EP called from protocol to generate hs
+1 DO FULL^VALM1
+2 DO EN^XBNEW("HS1^BDPLMUPD","BDPPAT")
+3 DO BACK
+4 QUIT
HS1 ;EP - called from xbnew
+1 SET X=""
+2 IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
IF X
IF $DATA(^APCHSCTL(X,0))
SET X=$PIECE(^APCHSCTL(X,0),U)
+3 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+4 IF X=""
SET X="ADULT REGULAR"
+5 KILL DIC,DR,DD
SET DIC("B")=X
SET DIC="^APCHSCTL("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DD,D0,D1,DQ
+6 IF Y=-1
DO PAUSE
DO BACK
QUIT
+7 SET APCHSTYP=+Y
SET APCHSPAT=BDPPAT
+8 SET BDPHDR="PCC Health Summary for "_$PIECE(^DPT(BDPPAT,0),U)
+9 DO VIEWR^XBLM("EN^APCHS",BDPHDR)
+10 SET (DFN,Y)=BDPPAT
DO ^AUPNPAT
+11 DO BACK
+12 QUIT
+13 ;
BACK ;
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER
+4 SET VALMCNT=BDPLINE
+5 DO HDR
+6 QUIT
PAUSE ;EP
+1 NEW DIR
+2 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
+3 QUIT
+4 ;
EXIT ;EP
+1 QUIT
+2 ;
ADD ;EP - add a new dp
+1 DO FULL^VALM1
+2 NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
+3 WRITE !!
+4 SET DIC="^BDPTCAT("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the PROVIDER Category: "
DO ^DIC
KILL DIC
+5 IF Y<0
WRITE !,"No updating done...."
DO PAUSE
DO BACK
QUIT
+6 SET BDPCIEN=+Y
+7 IF $DATA(^BDPRECN("AA",BDPPAT,BDPCIEN))
SET X=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
IF $PIECE($GET(^BDPRECN(X,0)),U,3)'=""
Begin DoDot:1
+8 WRITE !!,"This patient already has a provider assigned for category ",!?5,$PIECE(^BDPTCAT(BDPCIEN,0),U)
+9 WRITE !,"Please use the CH (Change Provider) action item to change this provider."
End DoDot:1
DO PAUSE
DO BACK
QUIT
+10 ;get provider name for this category
+11 WRITE !
+12 ;,DIC("B")=$P(^VA(200,DUZ,0),U)
SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Enter Provider Name: "
+13 IF $$GET1^DIQ(90360.3,BDPCIEN,.01)'="MESSAGE AGENT"
SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
+14 IF $$GET1^DIQ(90360.3,BDPCIEN,.01)="MESSAGE AGENT"
SET DIC("S")="I $D(^BDPMSGA(+Y,0)),'$P(^BDPMSGA(+Y,0),U,3)"
KILL DIC("B")
+15 DO ^DIC
KILL DIC
+16 IF Y<0
WRITE !,"No updating done...."
DO PAUSE
DO BACK
QUIT
+17 SET BDPPROV=+Y
+18 ;add new entry for this patient
+19 SET X=$$ADD1^BDPAPI(BDPPAT,BDPCIEN)
+20 IF 'X
WRITE !!,"error updating designated provider"
DO PAUSE
DO BACK
QUIT
+21 SET BDPRIEN=X
+22 SET X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
+23 IF 'X
WRITE !!,"error updating designated provider"
DO PAUSE
DO BACK
QUIT
+24 WRITE !!,"Provider ",$PIECE(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$PIECE(^BDPTCAT(BDPCIEN,0),U)," provider.",!
+25 DO PAUSE
+26 DO BACK
+27 QUIT
+28 ;
CHANGE ;EP - change existing DP
+1 DO FULL^VALM1
+2 ;
+3 NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
+4 DO GETITEM
+5 IF '$GET(BDPRIEN)
DO PAUSE
DO BACK
QUIT
+6 IF 'BDPRIEN
WRITE !,"No item selected to change."
DO PAUSE
DO BACK
QUIT
+7 SET BDPCIEN=$PIECE(^BDPRECN(BDPRIEN,0),U)
+8 ;,DIC("B")=$P(^VA(200,DUZ,0),U)
WRITE !
SET DIC("A")="Enter New Designated "_$$VAL^XBDIQ1(90360.1,BDPRIEN,.01)_": "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
+9 IF $$GET1^DIQ(90360.3,BDPCIEN,.01)'="MESSAGE AGENT"
SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
+10 IF $$GET1^DIQ(90360.3,BDPCIEN,.01)="MESSAGE AGENT"
SET DIC("S")="I $D(^BDPMSGA(+Y,0)),'$P(^BDPMSGA(+Y,0),U,3)"
KILL DIC("B")
+11 DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+12 IF Y<0
WRITE !,"No Provider Selected."
DO PAUSE
DO BACK
QUIT
+13 SET BDPPROV=+Y
+14 IF $PIECE(^BDPRECN(BDPRIEN,0),U,3)=BDPPROV
WRITE !!,"That is the currently documented provider."
DO PAUSE
DO BACK
QUIT
+15 SET X=$$EDIT^BDPAPI(BDPRIEN,BDPCIEN,BDPPROV)
+16 IF 'X
WRITE !!,"error updating designated provider"
DO PAUSE
DO BACK
QUIT
+17 WRITE !!,"Provider ",$PIECE(^VA(200,BDPPROV,0),U)," successfully added as",!,"the designated ",$PIECE(^BDPTCAT(BDPCIEN,0),U)," provider.",!
+18 DO PAUSE
+19 DO BACK
+20 QUIT
DELETE ;EP - delete exisiting DP
+1 DO FULL^VALM1
+2 ;
+3 NEW DIC,Y,X,BDPCIEN,BDPPROV,BDPRIEN
+4 DO GETITEM
+5 IF '$GET(BDPRIEN)
DO PAUSE
DO BACK
QUIT
+6 IF 'BDPRIEN
WRITE !,"No item selected to DELETE."
DO PAUSE
DO BACK
QUIT
+7 SET BDPCIEN=$PIECE(^BDPRECN(BDPRIEN,0),U)
+8 WRITE !!,"Are you sure you want to DELETE ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.03),!?3,"as the designated ",$$VAL^XBDIQ1(90360.1,BDPRIEN,.01),"?"
+9 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Please confirm"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
DO PAUSE
DO BACK
QUIT
+11 IF 'Y
DO PAUSE
DO BACK
QUIT
+12 SET BDPPROV=$$VALI^XBDIQ1(90360.1,BDPRIEN,.03)
+13 ;P19
NEW DA,DIE,DR,BDPLINKI
+14 SET BDPLINKI=1
+15 ;NEW DA,DIE,DR
+16 SET DA=BDPRIEN
SET DIE="^BDPRECN("
SET DR=".03///@;.04////"_DUZ_";.05////"_DT
DO ^DIE
KILL DIE,DA,DR
+17 ;FIND THE MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
+18 NEW X,Y
+19 SET X=0
FOR
SET X=$ORDER(^BDPRECN(BDPRIEN,1,X))
IF X'=+X
QUIT
IF $PIECE(^BDPRECN(BDPRIEN,1,X,0),U,1)=BDPPROV
SET Y=X
+20 IF Y
IF $PIECE(^BDPRECN(BDPRIEN,1,Y,0),U,5)=""
SET DIE="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DA=Y
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM
+21 WRITE !!,"Provider ",$PIECE(^VA(200,BDPPROV,0),U)," successfully DELETED as",!," the designated ",$PIECE(^BDPTCAT(BDPCIEN,0),U)," provider.",!
+22 DO PAUSE
+23 DO BACK
+24 QUIT
+25 ;
GETITEM ;get record
+1 IF 'BDPRCNT
WRITE !,"No Items to change"
QUIT
+2 NEW BDPIT
+3 SET BDPRIEN=0
+4 SET DIR(0)="N^1:"_BDPRCNT_":0"
SET DIR("A")="Select item to change"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET BDPIT=Y
+7 SET (X,Y)=0
FOR
SET X=$ORDER(BDPLIST("IDX",X))
IF X'=+X!(BDPRIEN)
QUIT
IF $ORDER(BDPLIST("IDX",X,0))=BDPIT
SET Y=$ORDER(BDPLIST("IDX",X,0))
SET BDPRIEN=BDPLIST("IDX",X,Y)
+8 IF '$DATA(^BDPRECN(BDPRIEN,0))
SET BDPRIEN=0
QUIT
+9 QUIT
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
