BSDPCP ; IHS/ANMC/LJF,WAR - UPDATE PCP FOR GROUP OF PTS ;
;;5.3;PIMS;**1003,1004,1007**;DEC 01, 2006
;IHS/ITSC/LJF 06/17/2005 PATCH 1003 screened out deceased patients
;IHS/OIT/LJF 09/28/2005 PATCH 1004 allow inactive providers in listing
;cmi/anch/maw 11/22/2006 PATCH 1007 added line in ASKPN and code in GATHER for item 1007.11
;
PROV ; -- ask user to select a provider
NEW BSDPRV,SCREEN,BSDFL,BSDAAPN
S BSDFL=$S($P(^DD(9000001,.14,0),U,2)["200":200,1:6),SCREEN=""
;I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))" ;IHS/OIT/LJF 09/28/2005 PATCH 1004
S BSDPRV=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Select a PRIMARY CARE PROVIDER","","",SCREEN) Q:BSDPRV<1
D ASKPN ;cmi/anch/maw 11/9/2006 added item 1007.11 patch 1007
;
EN ; -- main entry point for SD IHS PCP LIST
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSD PCP LIST")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
S VALMHDR(2)=$$SP(18)_"Patient List for "_$$GET1^DIQ(BSDFL,BSDPRV,.01)
S VALMSG="- Previous Screen Q Quit ?? for More Actions"
Q
;
INIT ; -- init variables and list array
NEW BSDLN
D GATHER
S VALMCNT=BSDLN
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K VALMCNT,VALMQUIT,BSDPRV
K ^TMP("BSDPCP",$J),^TMP("BSDPCP2",$J)
Q
;
EXPND ; -- expand code
Q
;
RESET ; -- code executed upon return
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
D INIT,HDR Q
;
RESET2 ; -- code executed upon return
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
Q
;
GATHER ; -- build display array
NEW DFN,NAME,COMM,LINE,COUNT
D MSG^BDGF("Building Patient List. . .Please wait.",1,0)
K ^TMP("BSDPCP",$J),^TMP("BSDPCP1",$J),^TMP("BSDPCP2",$J)
S BSDLN=0
S DFN=0 F S DFN=$O(^AUPNPAT("AK",+BSDPRV,DFN)) Q:'DFN D
. ;
. ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 screen out deceased patients
. Q:$$DOD^AUPNPAT(DFN) ;skip if patient has date of death recorded
. ;
. S NAME=$$GET1^DIQ(2,DFN,.01)
. S COMM=$$GET1^DIQ(9000001,DFN,1118) S:COMM="" COMM="??"
. ;S ^TMP("BSDPCP1",$J,COMM,NAME,DFN)="" cmi/anch/maw 11/9/2006 orig line item 1007.11 patch 1007
. I $G(BSDAPN)="C" S ^TMP("BSDPCP1",$J,COMM,NAME,DFN)="" ;cmi/anch/maw 11/9/2006 new line item 1007.11 patch 1007
. I $G(BSDAPN)="P" S ^TMP("BSDPCP1",$J,NAME,COMM,DFN)="" ;cmi/anch/maw 11/9/2006 new line added item 1007.11 patch 1007
;
;cmi/anch/maw added below line for item 1007.11 patch 1007
I $G(BSDAPN)="C" D ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
. S COMM=0 F S COMM=$O(^TMP("BSDPCP1",$J,COMM)) Q:COMM="" D
.. S NAME=0 F S NAME=$O(^TMP("BSDPCP1",$J,COMM,NAME)) Q:NAME="" D
... S DFN=0 F S DFN=$O(^TMP("BSDPCP1",$J,COMM,NAME,DFN)) Q:'DFN D
.... S COUNT=$G(COUNT)+1,LINE=$$PAD($J(COUNT,4)_" "_NAME,25)
.... S LINE=LINE_$J($$HRN^AUPNPAT(DFN,DUZ(2)),8)_" "_COMM
.... S LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
.... D SET(LINE,+$G(COUNT),DFN)
.... S ^TMP("BSDPCP2",$J,COMM,DFN)=""
;
;cmi/anch/maw added below lines for item 1007.11 patch 1007
I $G(BSDAPN)="P" D ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
. S NAME=0 F S NAME=$O(^TMP("BSDPCP1",$J,NAME)) Q:NAME="" D
.. S COMM=0 F S COMM=$O(^TMP("BSDPCP1",$J,NAME,COMM)) Q:COMM="" D
... S DFN=0 F S DFN=$O(^TMP("BSDPCP1",$J,NAME,COMM,DFN)) Q:'DFN D
.... S COUNT=$G(COUNT)+1,LINE=$$PAD($J(COUNT,4)_" "_NAME,25)
.... S LINE=LINE_$J($$HRN^AUPNPAT(DFN,DUZ(2)),8)_" "_COMM
.... S LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
.... D SET(LINE,+$G(COUNT),DFN)
.... S ^TMP("BSDPCP2",$J,NAME,DFN)=""
;
I '$G(COUNT) D SET($$SP(10)_"NONE FOUND",0,0)
K ^TMP("BSDPCP1",$J)
Q
;
SET(L,C,N) ; -- set display line into array
S BSDLN=BSDLN+1 S:N=0 N=1
S ^TMP("BSDPCP",$J,BSDLN,0)=L
S ^TMP("BSDPCP",$J,"IDX",BSDLN,C)=N
Q
;
LASTVST(DFN) ; -- returns date, serv cat, and clinic/srv of last visit
NEW X,V,CAT,VDT,CLIN,LINE
S X=0 F S X=$O(^AUPNVSIT("AA",DFN,X)) Q:('X)!($D(LINE)) D
. S V=0 F S V=$O(^AUPNVSIT("AA",DFN,X,V)) Q:'V D
.. S CAT=$$SC^APCLV(V,"I") Q:"OHATS"'[CAT
.. S VDT=$$VD^APCLV(V,"S"),CLIN=$$CLINIC^APCLV(V,"E")
.. I CAT="H" S CLIN=$$DSCHSERV^APCLV(V,"E")
.. S CAT=$$SC^APCLV(V,"E")
.. S LINE=$$PAD($J(VDT,8),10)_$E(CAT,1,3)_" "_CLIN
Q $G(LINE)
;
;
GETITEM ; -- select item from list
K BSDRR
D EN^VALM2(XQORNOD(0),"O")
I '$D(VALMY) Q
NEW X,Y,Z,F
S X=0 F S X=$O(VALMY(X)) Q:X="" D
. S Y=0 F S Y=$O(^TMP("BSDPCP",$J,"IDX",Y)) Q:Y="" D
.. S Z=$O(^TMP("BSDPCP",$J,"IDX",Y,0))
.. Q:^TMP("BSDPCP",$J,"IDX",Y,Z)="" Q:(Z'=X)
.. S BSDRR(X)=^TMP("BSDPCP",$J,"IDX",Y,Z)
.. S Y=99999999
D CLEAR^VALM1,FULL^VALM1
Q
;
PATLOOP ;EP; -- called to edit by patient from PCP List
NEW BSDRR,BSDCNT,DFN
D GETITEM I '$D(BSDRR) D RESET2 Q
D FULL^VALM1
S BSDCNT=0 F S BSDCNT=$O(BSDRR(BSDCNT)) Q:'BSDCNT D
. S DFN=BSDRR(BSDCNT) Q:'DFN
. D MSG^BDGF($J(BSDCNT,4)_" "_$$GET1^DIQ(2,DFN,.01)_":",2,0)
. D ONEPAT(DFN)
D RESET
Q
;
COMLOOP ;EP; -- called to edit by community from PCP List
NEW BSDCOMN,Y,SCREEN,BSDNEW,BSDREAS,DIE,DA,DR
D FULL^VALM1
S Y=$$READ^BDGF("PO^9999999.05:EQMZ") I 'Y D RESET2 Q
S BSDCOMN=$P(Y,U,2)
;
S SCREEN=""
I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",BSDPRV)),$P($G(^VA(200,BSDPRV,""PS"")),U,4)="""""
S Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
I Y<1 D RESET2 Q
S BSDNEW=+Y
;
S BSDREAS=+$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
I BSDREAS<1 D RESET2 Q
;
D MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
D MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01)_" in "_BSDCOMN,1,0)
D MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
I '$$READ^BDGF("YO","Ready to continue","NO") D RESET2 Q
;
S DIE="^AUPNPAT(",DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
S DFN=0 F S DFN=$O(^TMP("BSDPCP2",$J,BSDCOMN,DFN)) Q:'DFN D
. S DA=DFN D ^DIE W "."
D RESET
Q
;
UPD ;EP; -- called by update all patients from PCP List
D CLEAR^VALM1,MSG^BDGF($$SP(20)_"CONVERT PRIMARY CARE PROVIDER",2,2)
NEW Y,BSDNEW,SCREEN,BSDREAS
S SCREEN=""
I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
S Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
Q:Y<1 S BSDNEW=+Y
;
S BSDREAS=""
F Q:+BSDREAS>0!(BSDREAS="^") D
.S BSDREAS=$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
.I BSDREAS=-1 D
..W !!,$C(7),"You must enter a REASON or '^' to Quit"
..D PAUSE^BDGF
I BSDREAS<1 D RESET2 Q
S BSDREAS=+BSDREAS
;
D MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
D MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01),1,0)
D MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
I '$$READ^BDGF("YO","Ready to continue","NO") D RESET2 Q
;
S DIE="^AUPNPAT(",DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
S DFN=0 F S DFN=$O(^AUPNPAT("AK",BSDPRV,DFN)) Q:'DFN D
. S DA=DFN D ^DIE W "."
;
S BSDPRV=BSDNEW D RESET
Q
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
;
GETPAT ;EP;-- edit PCP for 1 patient when patient not known
NEW DIC,Y,DFN
S Y=1 F D Q:Y<1
. S DIC=9000001,DIC(0)="AEMQ" D ^DIC Q:Y<1
. S DFN=+Y
. NEW Y,I W ! D PCPDISP^BSDU1(DFN,.Y) F I=1:1 Q:'$D(Y(I)) W !,Y(I)
. Q:'$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
. D ONEPAT(DFN) S Y=DFN
Q
;
ONEPAT(DFN) ; once patient is selected, edit PCP fields
NEW BEFORE,DIE,DA,DR,DITC
S BEFORE=$$GET1^DIQ(9000001,DFN,.14,"I") ;current PCP
S DIE="^AUPNPAT(",DA=DFN,DR=".14" D ^DIE ;edit PCP
;
; if PCP changed, ask reason (date and user updated via triggers)
I BEFORE]"",BEFORE'=$$GET1^DIQ(9000001,DFN,.14,"I") D Q:$D(Y)
. S DITC="",DIE="^AUPNPAT(",DA=DFN,DR=".37///@" D ^DIE
. S DIE="^AUPNPAT(",DA=DFN,DR=".37" D ^DIE
;
I $$GET1^DIQ(2,DFN,.02)="FEMALE",$D(^BWP(DFN)) D WHREF(DFN)
Q
;
WHREF(PAT) ; edit WH Referral Provider
NEW DIE,BEFORE,DA,DR
S BEFORE=$$GET1^DIQ(9002086,PAT,.25,"I")
S DIE="^BWP(",DA=DFN,DR=".25" D ^DIE
I BEFORE]"",BEFORE'=$$GET1^DIQ(9002086,DFN,.25,"I") D
. S DIE="^BWP(",DA=DFN,DR=".28///@" D ^DIE
. S DIE="^BWP(",DA=DFN,DR=".28" D ^DIE
Q
;
AMPCP ;EP; update PCP from Appt Mgt
D FULL^VALM1
I $G(DFN) D S VALMBCK="R" Q
. NEW Y,I W ! D PCPDISP^BSDU1(DFN,.Y) F I=1:1 Q:'$D(Y(I)) W !,Y(I)
. Q:'$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
. D ONEPAT(DFN)
;
D GETPAT S VALMBCK="R"
Q
;cmi/anch/maw added ASKPN 11/9/2006 item 1007.11 patch 1007
ASKPN ;EP - ask if they want to sort by patient name
S BSDAPN=$$READ^BDGF("S^C:Community of Residence;P:Patient Name","Sort By","Community of Residence")
Q
;
BSDPCP ; IHS/ANMC/LJF,WAR - UPDATE PCP FOR GROUP OF PTS ;
+1 ;;5.3;PIMS;**1003,1004,1007**;DEC 01, 2006
+2 ;IHS/ITSC/LJF 06/17/2005 PATCH 1003 screened out deceased patients
+3 ;IHS/OIT/LJF 09/28/2005 PATCH 1004 allow inactive providers in listing
+4 ;cmi/anch/maw 11/22/2006 PATCH 1007 added line in ASKPN and code in GATHER for item 1007.11
+5 ;
PROV ; -- ask user to select a provider
+1 NEW BSDPRV,SCREEN,BSDFL,BSDAAPN
+2 SET BSDFL=$SELECT($PIECE(^DD(9000001,.14,0),U,2)["200":200,1:6)
SET SCREEN=""
+3 ;I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
+4 ;IHS/OIT/LJF 09/28/2005 PATCH 1004
IF BSDFL=200
SET SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))"
+5 SET BSDPRV=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Select a PRIMARY CARE PROVIDER","","",SCREEN)
IF BSDPRV<1
QUIT
+6 ;cmi/anch/maw 11/9/2006 added item 1007.11 patch 1007
DO ASKPN
+7 ;
EN ; -- main entry point for SD IHS PCP LIST
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BSD PCP LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+2 SET VALMHDR(2)=$$SP(18)_"Patient List for "_$$GET1^DIQ(BSDFL,BSDPRV,.01)
+3 SET VALMSG="- Previous Screen Q Quit ?? for More Actions"
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW BSDLN
+2 DO GATHER
+3 SET VALMCNT=BSDLN
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL VALMCNT,VALMQUIT,BSDPRV
+2 KILL ^TMP("BSDPCP",$JOB),^TMP("BSDPCP2",$JOB)
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
RESET ; -- code executed upon return
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 DO INIT
DO HDR
QUIT
+4 ;
RESET2 ; -- code executed upon return
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 QUIT
+4 ;
GATHER ; -- build display array
+1 NEW DFN,NAME,COMM,LINE,COUNT
+2 DO MSG^BDGF("Building Patient List. . .Please wait.",1,0)
+3 KILL ^TMP("BSDPCP",$JOB),^TMP("BSDPCP1",$JOB),^TMP("BSDPCP2",$JOB)
+4 SET BSDLN=0
+5 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT("AK",+BSDPRV,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+6 ;
+7 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 screen out deceased patients
+8 ;skip if patient has date of death recorded
IF $$DOD^AUPNPAT(DFN)
QUIT
+9 ;
+10 SET NAME=$$GET1^DIQ(2,DFN,.01)
+11 SET COMM=$$GET1^DIQ(9000001,DFN,1118)
IF COMM=""
SET COMM="??"
+12 ;S ^TMP("BSDPCP1",$J,COMM,NAME,DFN)="" cmi/anch/maw 11/9/2006 orig line item 1007.11 patch 1007
+13 ;cmi/anch/maw 11/9/2006 new line item 1007.11 patch 1007
IF $GET(BSDAPN)="C"
SET ^TMP("BSDPCP1",$JOB,COMM,NAME,DFN)=""
+14 ;cmi/anch/maw 11/9/2006 new line added item 1007.11 patch 1007
IF $GET(BSDAPN)="P"
SET ^TMP("BSDPCP1",$JOB,NAME,COMM,DFN)=""
End DoDot:1
+15 ;
+16 ;cmi/anch/maw added below line for item 1007.11 patch 1007
+17 ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
IF $GET(BSDAPN)="C"
Begin DoDot:1
+18 SET COMM=0
FOR
SET COMM=$ORDER(^TMP("BSDPCP1",$JOB,COMM))
IF COMM=""
QUIT
Begin DoDot:2
+19 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BSDPCP1",$JOB,COMM,NAME))
IF NAME=""
QUIT
Begin DoDot:3
+20 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BSDPCP1",$JOB,COMM,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+21 SET COUNT=$GET(COUNT)+1
SET LINE=$$PAD($JUSTIFY(COUNT,4)_" "_NAME,25)
+22 SET LINE=LINE_$JUSTIFY($$HRN^AUPNPAT(DFN,DUZ(2)),8)_" "_COMM
+23 SET LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
+24 DO SET(LINE,+$GET(COUNT),DFN)
+25 SET ^TMP("BSDPCP2",$JOB,COMM,DFN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 ;cmi/anch/maw added below lines for item 1007.11 patch 1007
+28 ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
IF $GET(BSDAPN)="P"
Begin DoDot:1
+29 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BSDPCP1",$JOB,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+30 SET COMM=0
FOR
SET COMM=$ORDER(^TMP("BSDPCP1",$JOB,NAME,COMM))
IF COMM=""
QUIT
Begin DoDot:3
+31 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BSDPCP1",$JOB,NAME,COMM,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+32 SET COUNT=$GET(COUNT)+1
SET LINE=$$PAD($JUSTIFY(COUNT,4)_" "_NAME,25)
+33 SET LINE=LINE_$JUSTIFY($$HRN^AUPNPAT(DFN,DUZ(2)),8)_" "_COMM
+34 SET LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
+35 DO SET(LINE,+$GET(COUNT),DFN)
+36 SET ^TMP("BSDPCP2",$JOB,NAME,DFN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 IF '$GET(COUNT)
DO SET($$SP(10)_"NONE FOUND",0,0)
+39 KILL ^TMP("BSDPCP1",$JOB)
+40 QUIT
+41 ;
SET(L,C,N) ; -- set display line into array
+1 SET BSDLN=BSDLN+1
IF N=0
SET N=1
+2 SET ^TMP("BSDPCP",$JOB,BSDLN,0)=L
+3 SET ^TMP("BSDPCP",$JOB,"IDX",BSDLN,C)=N
+4 QUIT
+5 ;
LASTVST(DFN) ; -- returns date, serv cat, and clinic/srv of last visit
+1 NEW X,V,CAT,VDT,CLIN,LINE
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVSIT("AA",DFN,X))
IF ('X)!($DATA(LINE))
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",DFN,X,V))
IF 'V
QUIT
Begin DoDot:2
+4 SET CAT=$$SC^APCLV(V,"I")
IF "OHATS"'[CAT
QUIT
+5 SET VDT=$$VD^APCLV(V,"S")
SET CLIN=$$CLINIC^APCLV(V,"E")
+6 IF CAT="H"
SET CLIN=$$DSCHSERV^APCLV(V,"E")
+7 SET CAT=$$SC^APCLV(V,"E")
+8 SET LINE=$$PAD($JUSTIFY(VDT,8),10)_$EXTRACT(CAT,1,3)_" "_CLIN
End DoDot:2
End DoDot:1
+9 QUIT $GET(LINE)
+10 ;
+11 ;
GETITEM ; -- select item from list
+1 KILL BSDRR
+2 DO EN^VALM2(XQORNOD(0),"O")
+3 IF '$DATA(VALMY)
QUIT
+4 NEW X,Y,Z,F
+5 SET X=0
FOR
SET X=$ORDER(VALMY(X))
IF X=""
QUIT
Begin DoDot:1
+6 SET Y=0
FOR
SET Y=$ORDER(^TMP("BSDPCP",$JOB,"IDX",Y))
IF Y=""
QUIT
Begin DoDot:2
+7 SET Z=$ORDER(^TMP("BSDPCP",$JOB,"IDX",Y,0))
+8 IF ^TMP("BSDPCP",$JOB,"IDX",Y,Z)=""
QUIT
IF (Z'=X)
QUIT
+9 SET BSDRR(X)=^TMP("BSDPCP",$JOB,"IDX",Y,Z)
+10 SET Y=99999999
End DoDot:2
End DoDot:1
+11 DO CLEAR^VALM1
DO FULL^VALM1
+12 QUIT
+13 ;
PATLOOP ;EP; -- called to edit by patient from PCP List
+1 NEW BSDRR,BSDCNT,DFN
+2 DO GETITEM
IF '$DATA(BSDRR)
DO RESET2
QUIT
+3 DO FULL^VALM1
+4 SET BSDCNT=0
FOR
SET BSDCNT=$ORDER(BSDRR(BSDCNT))
IF 'BSDCNT
QUIT
Begin DoDot:1
+5 SET DFN=BSDRR(BSDCNT)
IF 'DFN
QUIT
+6 DO MSG^BDGF($JUSTIFY(BSDCNT,4)_" "_$$GET1^DIQ(2,DFN,.01)_":",2,0)
+7 DO ONEPAT(DFN)
End DoDot:1
+8 DO RESET
+9 QUIT
+10 ;
COMLOOP ;EP; -- called to edit by community from PCP List
+1 NEW BSDCOMN,Y,SCREEN,BSDNEW,BSDREAS,DIE,DA,DR
+2 DO FULL^VALM1
+3 SET Y=$$READ^BDGF("PO^9999999.05:EQMZ")
IF 'Y
DO RESET2
QUIT
+4 SET BSDCOMN=$PIECE(Y,U,2)
+5 ;
+6 SET SCREEN=""
+7 IF BSDFL=200
SET SCREEN="I $D(^XUSEC(""PROVIDER"",BSDPRV)),$P($G(^VA(200,BSDPRV,""PS"")),U,4)="""""
+8 SET Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
+9 IF Y<1
DO RESET2
QUIT
+10 SET BSDNEW=+Y
+11 ;
+12 SET BSDREAS=+$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
+13 IF BSDREAS<1
DO RESET2
QUIT
+14 ;
+15 DO MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
+16 DO MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01)_" in "_BSDCOMN,1,0)
+17 DO MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
+18 IF '$$READ^BDGF("YO","Ready to continue","NO")
DO RESET2
QUIT
+19 ;
+20 SET DIE="^AUPNPAT("
SET DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
+21 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BSDPCP2",$JOB,BSDCOMN,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+22 SET DA=DFN
DO ^DIE
WRITE "."
End DoDot:1
+23 DO RESET
+24 QUIT
+25 ;
UPD ;EP; -- called by update all patients from PCP List
+1 DO CLEAR^VALM1
DO MSG^BDGF($$SP(20)_"CONVERT PRIMARY CARE PROVIDER",2,2)
+2 NEW Y,BSDNEW,SCREEN,BSDREAS
+3 SET SCREEN=""
+4 IF BSDFL=200
SET SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
+5 SET Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
+6 IF Y<1
QUIT
SET BSDNEW=+Y
+7 ;
+8 SET BSDREAS=""
+9 FOR
IF +BSDREAS>0!(BSDREAS="^")
QUIT
Begin DoDot:1
+10 SET BSDREAS=$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
+11 IF BSDREAS=-1
Begin DoDot:2
+12 WRITE !!,$CHAR(7),"You must enter a REASON or '^' to Quit"
+13 DO PAUSE^BDGF
End DoDot:2
End DoDot:1
+14 IF BSDREAS<1
DO RESET2
QUIT
+15 SET BSDREAS=+BSDREAS
+16 ;
+17 DO MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
+18 DO MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01),1,0)
+19 DO MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
+20 IF '$$READ^BDGF("YO","Ready to continue","NO")
DO RESET2
QUIT
+21 ;
+22 SET DIE="^AUPNPAT("
SET DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
+23 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT("AK",BSDPRV,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+24 SET DA=DFN
DO ^DIE
WRITE "."
End DoDot:1
+25 ;
+26 SET BSDPRV=BSDNEW
DO RESET
+27 QUIT
+28 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
+3 ;
GETPAT ;EP;-- edit PCP for 1 patient when patient not known
+1 NEW DIC,Y,DFN
+2 SET Y=1
FOR
Begin DoDot:1
+3 SET DIC=9000001
SET DIC(0)="AEMQ"
DO ^DIC
IF Y<1
QUIT
+4 SET DFN=+Y
+5 NEW Y,I
WRITE !
DO PCPDISP^BSDU1(DFN,.Y)
FOR I=1:1
IF '$DATA(Y(I))
QUIT
WRITE !,Y(I)
+6 IF '$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
QUIT
+7 DO ONEPAT(DFN)
SET Y=DFN
End DoDot:1
IF Y<1
QUIT
+8 QUIT
+9 ;
ONEPAT(DFN) ; once patient is selected, edit PCP fields
+1 NEW BEFORE,DIE,DA,DR,DITC
+2 ;current PCP
SET BEFORE=$$GET1^DIQ(9000001,DFN,.14,"I")
+3 ;edit PCP
SET DIE="^AUPNPAT("
SET DA=DFN
SET DR=".14"
DO ^DIE
+4 ;
+5 ; if PCP changed, ask reason (date and user updated via triggers)
+6 IF BEFORE]""
IF BEFORE'=$$GET1^DIQ(9000001,DFN,.14,"I")
Begin DoDot:1
+7 SET DITC=""
SET DIE="^AUPNPAT("
SET DA=DFN
SET DR=".37///@"
DO ^DIE
+8 SET DIE="^AUPNPAT("
SET DA=DFN
SET DR=".37"
DO ^DIE
End DoDot:1
IF $DATA(Y)
QUIT
+9 ;
+10 IF $$GET1^DIQ(2,DFN,.02)="FEMALE"
IF $DATA(^BWP(DFN))
DO WHREF(DFN)
+11 QUIT
+12 ;
WHREF(PAT) ; edit WH Referral Provider
+1 NEW DIE,BEFORE,DA,DR
+2 SET BEFORE=$$GET1^DIQ(9002086,PAT,.25,"I")
+3 SET DIE="^BWP("
SET DA=DFN
SET DR=".25"
DO ^DIE
+4 IF BEFORE]""
IF BEFORE'=$$GET1^DIQ(9002086,DFN,.25,"I")
Begin DoDot:1
+5 SET DIE="^BWP("
SET DA=DFN
SET DR=".28///@"
DO ^DIE
+6 SET DIE="^BWP("
SET DA=DFN
SET DR=".28"
DO ^DIE
End DoDot:1
+7 QUIT
+8 ;
AMPCP ;EP; update PCP from Appt Mgt
+1 DO FULL^VALM1
+2 IF $GET(DFN)
Begin DoDot:1
+3 NEW Y,I
WRITE !
DO PCPDISP^BSDU1(DFN,.Y)
FOR I=1:1
IF '$DATA(Y(I))
QUIT
WRITE !,Y(I)
+4 IF '$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
QUIT
+5 DO ONEPAT(DFN)
End DoDot:1
SET VALMBCK="R"
QUIT
+6 ;
+7 DO GETPAT
SET VALMBCK="R"
+8 QUIT
+9 ;cmi/anch/maw added ASKPN 11/9/2006 item 1007.11 patch 1007
ASKPN ;EP - ask if they want to sort by patient name
+1 SET BSDAPN=$$READ^BDGF("S^C:Community of Residence;P:Patient Name","Sort By","Community of Residence")
+2 QUIT
+3 ;
