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