BDPAPI ; IHS/CMI/TMJ - ADD A NEW DESIGNATED PROVIDER ;
;;2.0;IHS PCC SUITE;**2,10,21**;MAY 14, 2009;Build 34
;
AEDWH(BDPPAT,BDPIEN,BDPRET) ;PEP - called to add, edit or delete a WOMEN's HEALTH CASE MANAGER
;
;BDPPAT - DFN of patient
;BDPIEN - ien of provider in file 200 to add as WHCM if one doesn't exist
; or edit the existing provider if there is one
; OR "@" to delete the existing WHCM and not replace it
;BDPRET - return value 1 if successful, 0^ERROR MESSAGE if not successful
;
;e.g to make provider with IEN 1234 as the WHCM for patient 3456
; S X=$$AEDWH^BDPAPI(3456,1234)
;e.g to remove the current WHCM and not replace it (for example, if patient moves or dies)
; S X=$$AEDWH^BDPAPI(3456,"@")
;
I '$G(BDPPAT) S BDPRET="0^valid patient DFN passed" Q
I '$D(^AUPNPAT(BDPPAT)) S BDPRET="0^patient not in patient file" Q
NEW BDPCIEN,BDPRIEN,X
S BDPCIEN=$O(^BDPTCAT("B","WOMEN'S HEALTH CASE MANAGER",0))
I 'BDPCIEN S BDPRET="0^WOMEN'S HEALTH CASE MANAGER category not found" Q
I '$G(BDPIEN),BDPIEN'="@" S BDPRET="0^PROVIDER IEN OR @ NOT PASSED" Q
I BDPIEN,'$D(^VA(200,BDPIEN,0)) S BDPRET="0^INVALID PROVIDER IEN PASSED" Q
;
I BDPIEN="@" S BDPRET=$$DEL1(BDPPAT,BDPCIEN) Q
S BDPRIEN=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0)) ;get ien of this patient/category
I 'BDPRIEN S BDPRIEN=$$ADD1(BDPPAT,BDPCIEN) I 'BDPRIEN S BDPRET=BDPRIEN Q
I $P(^BDPRECN(BDPRIEN,0),U,3)=BDPIEN S BDPRET=1 Q ;that already is the provider so don't bother
;
S BDPRET=$$EDIT(BDPRIEN,BDPCIEN,BDPIEN)
Q
;
AEDAP(BDPPAT,BDPIEN,BDPTYPE,BDPRET) ;PEP - called to add, edit or delete any designated provider by category
;this will add a new provider with the category BDPTYPE as the provider category
;
;BDPPAT - DFN of patient
;BDPIEN - ien of provider in file 200 to add a new provider or edit the existing provider to this one
; OR "@" to delete the existing provider and not replace it
;BDPTYPE - name of category to add this provider for e.g. "DPCP" or "RENAL DISEASE"
;BDPRET - return value 1 if successful, 0^ERROR MESSAGE if not successful
;e.g to make provider with IEN 1234 as the WHCM for patient 3456
; S X=$$AEDAP^BDPAPI(3456,1234,"RENAL DISEASE",.RETURN)
;e.g to remove the current WHCM and not replace it (for example, if patient moves or dies)
; S X=$$AEDAP^BDPAPI(3456,"@","WOMEN'S HEALTH CASE MANAGER",.RETURN)
;
I '$G(BDPPAT) S BDPRET="0^valid patient DFN passed" Q
I '$D(^AUPNPAT(BDPPAT)) S BDPRET="0^patient not in patient file" Q
NEW BDPCIEN,BDPRIEN,X
S BDPCIEN=$O(^BDPTCAT("B",BDPTYPE,0))
I 'BDPCIEN S BDPRET="0^Provider category not found" Q
I '$G(BDPIEN),BDPIEN'="@" S BDPRET="0^PROVIDER IEN OR @ NOT PASSED" Q
I BDPIEN,'$D(^VA(200,BDPIEN,0)) S BDPRET="0^INVALID PROVIDER IEN PASSED" Q
;
I BDPIEN="@" S BDPRET=$$DEL1(BDPPAT,BDPCIEN) Q
S BDPRIEN=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0)) ;get ien of this patient/category
I 'BDPRIEN S BDPRIEN=$$ADD1(BDPPAT,BDPCIEN) I 'BDPRIEN S BDPRET=BDPRIEN Q
I $P(^BDPRECN(BDPRIEN,0),U,3)=BDPIEN S BDPRET=1 Q ;that already is the provider so don't bother
;
S BDPRET=$$EDIT(BDPRIEN,BDPCIEN,BDPIEN)
Q
;
ADD1(BDPDFN,BDPTYPE) ;EP - add to top level of file for this category
NEW X S X=$O(^BDPRECN("AA",BDPDFN,BDPTYPE,0)) I X Q X
K DIC
S DIC="^BDPRECN(",DIC(0)="L",DLAYGO=90360.1,DIC("DR")=".02////"_BDPDFN,X=BDPTYPE
D FILE^BDPFMC
I Y<0 Q "0^UNABLE TO ADD - FILEMAN FAILED"
Q +Y
;
EDIT(BDPRIEN,BDPTYPE,BDPPROV) ;EP - edit/add to multiple
I '$G(BDPRIEN) Q "0^RECORD IEN INVALID"
I '$G(BDPTYPE) Q "0^PROVIDER TYPE INVALID"
I '$D(BDPPROV) Q "0^PROVIDER IEN INVALID"
NEW X,BDPLIEN,C,BDPLNUM,BDPNIEN
S:'$D(^BDPRECN(BDPRIEN,1,0)) $P(^(0),U,2)="90360.11P"
S (X,BDPLIEN,BDPLNUM)=0
F S X=$O(^BDPRECN(BDPRIEN,1,X)) Q:X'=+X S BDPLIEN=X,BDPLNUM=BDPLNUM+1 ;get last ien in multiple
S BDPNIEN=BDPLIEN+1
S BDPLNUM=BDPLNUM+1
S $P(^BDPRECN(BDPRIEN,1,0),U,3)=BDPNIEN
S $P(^BDPRECN(BDPRIEN,1,0),U,4)=BDPLNUM
;INACTIVE PREVIOUS ONE
S BDPLINKI=1 ;tell fileman you are coming from BDP
K DIE,DA,DR
I BDPNIEN'=1,$P(^BDPRECN(BDPRIEN,1,BDPLIEN,0),U,5)="" S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=BDPLIEN,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
;S DR=".01///"_"`"_BDPPROV
S ^BDPRECN(BDPRIEN,1,BDPNIEN,0)=BDPPROV_U_DUZ_U_DT_U_DT
;L +^BDPRECN(BDPRIEN):10 I '$T Q "0^UNABLE TO LOCK GLOBAL"
;S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=BDPLIEN D ^DIE K DIE,DR,DA,DINUM
;L -^BDPRECN(BDPRIEN)
;REINDEX MULTIPLE ENTRY
NEW DIK
S DA(1)=BDPRIEN,DA=BDPNIEN,DIK="^BDPRECN("_BDPRIEN_",1," D IX^DIK K DIC,DA
;I $D(Y) Q "0^ADDING PROVIDER TO LOG FAILED"
Q 1
;
DEL1(BDPPAT,BDPTYPE) ;
NEW BDPX
S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPTYPE,0))
I 'BDPX Q 1 ;doesn't have one so can't delete it
NEW DA,DIE,DR,X,Y,DINUM
S DA=BDPX,DIE="^BDPRECN(",DR=".03///@;.04////"_DUZ_";.05////"_DT D ^DIE ;IHS/CMI/LAB = added .04/.05 updating patch 22
;NOW WE HAVE TO UPDATE THE INACTIVE DATE IN THE MULTIPLE FOR THIS ONE BEING DELETED
;FIND THE MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
S X=0 F S X=$O(^BDPRECN(BDPX,1,X)) Q:X'=+X S Y=X
I Y,$P(^BDPRECN(BDPX,1,Y,0),U,5)="" S DIE="^BDPRECN("_BDPX_",1,",DA(1)=BDPX,DA=Y,DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT D ^DIE K DIE,DR,DA,DINUM
Q 1
;
WHPCP(BDPPAT,BDPRET) ;PEP - return WH case managers and DPCP
; input: BDPPAT - DFN of patient
; BDPRET - return array
; return array BDPRET:
; BDPRET(category name)=name of provider^ien of provider^provider class of provider^date updated
; BDPRET("WOMEN'S HEALTH CASE MANAGER")=name of provider^ien of provider^provider class of provider^date updated
; BDPRET("DESIGNATED PRIMARY PROVIDER")=name of provider^ien of provider^provider class of provider^date updated
; BDPRET("WOMEN'S HEALTH ALTERNATE")=name of provider^ien of provider^provider class of provider^date updated
;
; If the patient does not have a provider in any of the above categories the array will not
; contain that category so if there is no dpcp then '$D(BDPRET("DESIGNATED PRIMARY CARE PROVIDER")
; will be true
;
K BDPRET
I $G(BDPPAT)="" Q
NEW BDPX,BDPY,BDPZ,BDPCIEN
S BDPCIEN=$O(^BDPTCAT("B","DESIGNATED PRIMARY PROVIDER",0))
S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
I BDPX,$P($G(^BDPRECN(BDPX,0)),U,3)]"" S BDPY="DESIGNATED PRIMARY PROVIDER" D SETV
S BDPCIEN=0 F S BDPCIEN=$O(^BDPTCAT(BDPCIEN)) Q:BDPCIEN'=+BDPCIEN I $P(^BDPTCAT(BDPCIEN,0),U,6) D
.S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
.Q:'BDPX
.Q:$P(^BDPRECN(BDPX,0),U,3)=""
.S BDPY=$P(^BDPTCAT(BDPCIEN,0),U,1) D SETV
.Q
Q
SETV ;
NEW BDPI
S BDPI=$$VALI^XBDIQ1(90360.1,BDPX,.03)
S BDPRET(BDPY)=$$VAL^XBDIQ1(90360.1,BDPX,.03)_"^"_BDPI_"^"_$$VAL^XBDIQ1(200,BDPI,53.5)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.05)
Q
ALLDP(BDPPAT,BDPTYPE,BDPRET) ;PEP - return array of designated providers in all categories or 1 category
; input: BDPPAT - DFN of patient
; BDPTYPE - null if want all designated providers, or NAME of category, (e.g. RENAL DISEASE)
; if just want 1 provider category
; BDPRET - return array
; return array BDPRET:
; BDPRET(category name)=name of provider^ien of provider^provider class of provider^date updated
; example:
; BDPRET("WOMEN'S HEALTH CASE MANAGER")=name of provider^ien of provider^provider class of provider^date updated
; BDPRET("DESIGNATED PRIMARY PROVIDER")=name of provider^ien of provider^provider class of provider^date updated
;
K BDPRET
I $G(BDPPAT)="" Q
S BDPTYPE=$G(BDPTYPE)
NEW BDPX,BDPY,BDPZ,BDPCIEN
S BDPCIEN=0 F S BDPCIEN=$O(^BDPRECN("AA",BDPPAT,BDPCIEN)) Q:BDPCIEN'=+BDPCIEN D
.I BDPTYPE]"",$P(^BDPTCAT(BDPCIEN,0),U)'=BDPTYPE Q ;don't want this one
.S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
.Q:'BDPX
.Q:$P(^BDPRECN(BDPX,0),U,3)=""
.S BDPY=$P(^BDPTCAT(BDPCIEN,0),U,1) D SETV
.Q
Q
PROVPANL(BDPPIEN) ;PEP - entry point to view/update one provider's panel
I '$G(BDPPIEN) Q
D EN^BDPDPEE
Q
ALLDPVG(BDPPAT,BDPTYPE,BDPRET) ;PEP - return array of designated providers in all categories or 1 category
; input: BDPPAT - DFN of patient
; BDPTYPE - null if want all designated providers, or NAME of category, (e.g. RENAL DISEASE)
; if just want 1 provider category
; BDPRET - return array
; return array BDPRET:
; BDPRET(category IEN)=name of category^name of provider^ien of provider^provider class of provider^date updated^user last update
; example:
; BDPRET(12)=name of category^name of provider^ien of provider^provider class of provider^date updated
;
K BDPRET
I $G(BDPPAT)="" Q
S BDPTYPE=$G(BDPTYPE)
NEW BDPX,BDPY,BDPZ,BDPCIEN
S BDPCIEN=0 F S BDPCIEN=$O(^BDPRECN("AA",BDPPAT,BDPCIEN)) Q:BDPCIEN'=+BDPCIEN D
.I BDPTYPE]"",$P(^BDPTCAT(BDPCIEN,0),U)'=BDPTYPE Q ;don't want this one
.S BDPX=$O(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
.Q:'BDPX
.Q:$P(^BDPRECN(BDPX,0),U,3)=""
.S BDPY=BDPCIEN D SETV1
.Q
Q
SETV1 ;
NEW BDPI
S BDPI=$$VALI^XBDIQ1(90360.1,BDPX,.03)
S BDPRET(BDPY)=$P(^BDPTCAT(BDPCIEN,0),U,1)_"^"_$$VAL^XBDIQ1(90360.1,BDPX,.03)_"^"_BDPI_"^"_$$VAL^XBDIQ1(200,BDPI,53.5)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.05)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.04)
Q
MA(P) ;PEP - called to get message agent for a patient
;input - DFN
;output - message agent IEN from file 200^message agent name^message agent email address from message agent file
;if no message agent assigned to the patient null is returned
I '$G(P) Q ""
I '$D(^DPT(P,0)) Q ""
NEW I,N,R,E
D ALLDP^BDPAPI(P,"MESSAGE AGENT",.R)
I '$D(R("MESSAGE AGENT")) Q "" ;patient does not have a message agent
S N=$P(R("MESSAGE AGENT"),U,1) ;name
S I=$P(R("MESSAGE AGENT"),U,2) ;ien in file 200
S E=$$GET1^DIQ(90360.5,I,.02) ;dir email
Q I_"^"_N_"^"_E
BDPAPI ; IHS/CMI/TMJ - ADD A NEW DESIGNATED PROVIDER ;
+1 ;;2.0;IHS PCC SUITE;**2,10,21**;MAY 14, 2009;Build 34
+2 ;
AEDWH(BDPPAT,BDPIEN,BDPRET) ;PEP - called to add, edit or delete a WOMEN's HEALTH CASE MANAGER
+1 ;
+2 ;BDPPAT - DFN of patient
+3 ;BDPIEN - ien of provider in file 200 to add as WHCM if one doesn't exist
+4 ; or edit the existing provider if there is one
+5 ; OR "@" to delete the existing WHCM and not replace it
+6 ;BDPRET - return value 1 if successful, 0^ERROR MESSAGE if not successful
+7 ;
+8 ;e.g to make provider with IEN 1234 as the WHCM for patient 3456
+9 ; S X=$$AEDWH^BDPAPI(3456,1234)
+10 ;e.g to remove the current WHCM and not replace it (for example, if patient moves or dies)
+11 ; S X=$$AEDWH^BDPAPI(3456,"@")
+12 ;
+13 IF '$GET(BDPPAT)
SET BDPRET="0^valid patient DFN passed"
QUIT
+14 IF '$DATA(^AUPNPAT(BDPPAT))
SET BDPRET="0^patient not in patient file"
QUIT
+15 NEW BDPCIEN,BDPRIEN,X
+16 SET BDPCIEN=$ORDER(^BDPTCAT("B","WOMEN'S HEALTH CASE MANAGER",0))
+17 IF 'BDPCIEN
SET BDPRET="0^WOMEN'S HEALTH CASE MANAGER category not found"
QUIT
+18 IF '$GET(BDPIEN)
IF BDPIEN'="@"
SET BDPRET="0^PROVIDER IEN OR @ NOT PASSED"
QUIT
+19 IF BDPIEN
IF '$DATA(^VA(200,BDPIEN,0))
SET BDPRET="0^INVALID PROVIDER IEN PASSED"
QUIT
+20 ;
+21 IF BDPIEN="@"
SET BDPRET=$$DEL1(BDPPAT,BDPCIEN)
QUIT
+22 ;get ien of this patient/category
SET BDPRIEN=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+23 IF 'BDPRIEN
SET BDPRIEN=$$ADD1(BDPPAT,BDPCIEN)
IF 'BDPRIEN
SET BDPRET=BDPRIEN
QUIT
+24 ;that already is the provider so don't bother
IF $PIECE(^BDPRECN(BDPRIEN,0),U,3)=BDPIEN
SET BDPRET=1
QUIT
+25 ;
+26 SET BDPRET=$$EDIT(BDPRIEN,BDPCIEN,BDPIEN)
+27 QUIT
+28 ;
AEDAP(BDPPAT,BDPIEN,BDPTYPE,BDPRET) ;PEP - called to add, edit or delete any designated provider by category
+1 ;this will add a new provider with the category BDPTYPE as the provider category
+2 ;
+3 ;BDPPAT - DFN of patient
+4 ;BDPIEN - ien of provider in file 200 to add a new provider or edit the existing provider to this one
+5 ; OR "@" to delete the existing provider and not replace it
+6 ;BDPTYPE - name of category to add this provider for e.g. "DPCP" or "RENAL DISEASE"
+7 ;BDPRET - return value 1 if successful, 0^ERROR MESSAGE if not successful
+8 ;e.g to make provider with IEN 1234 as the WHCM for patient 3456
+9 ; S X=$$AEDAP^BDPAPI(3456,1234,"RENAL DISEASE",.RETURN)
+10 ;e.g to remove the current WHCM and not replace it (for example, if patient moves or dies)
+11 ; S X=$$AEDAP^BDPAPI(3456,"@","WOMEN'S HEALTH CASE MANAGER",.RETURN)
+12 ;
+13 IF '$GET(BDPPAT)
SET BDPRET="0^valid patient DFN passed"
QUIT
+14 IF '$DATA(^AUPNPAT(BDPPAT))
SET BDPRET="0^patient not in patient file"
QUIT
+15 NEW BDPCIEN,BDPRIEN,X
+16 SET BDPCIEN=$ORDER(^BDPTCAT("B",BDPTYPE,0))
+17 IF 'BDPCIEN
SET BDPRET="0^Provider category not found"
QUIT
+18 IF '$GET(BDPIEN)
IF BDPIEN'="@"
SET BDPRET="0^PROVIDER IEN OR @ NOT PASSED"
QUIT
+19 IF BDPIEN
IF '$DATA(^VA(200,BDPIEN,0))
SET BDPRET="0^INVALID PROVIDER IEN PASSED"
QUIT
+20 ;
+21 IF BDPIEN="@"
SET BDPRET=$$DEL1(BDPPAT,BDPCIEN)
QUIT
+22 ;get ien of this patient/category
SET BDPRIEN=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+23 IF 'BDPRIEN
SET BDPRIEN=$$ADD1(BDPPAT,BDPCIEN)
IF 'BDPRIEN
SET BDPRET=BDPRIEN
QUIT
+24 ;that already is the provider so don't bother
IF $PIECE(^BDPRECN(BDPRIEN,0),U,3)=BDPIEN
SET BDPRET=1
QUIT
+25 ;
+26 SET BDPRET=$$EDIT(BDPRIEN,BDPCIEN,BDPIEN)
+27 QUIT
+28 ;
ADD1(BDPDFN,BDPTYPE) ;EP - add to top level of file for this category
+1 NEW X
SET X=$ORDER(^BDPRECN("AA",BDPDFN,BDPTYPE,0))
IF X
QUIT X
+2 KILL DIC
+3 SET DIC="^BDPRECN("
SET DIC(0)="L"
SET DLAYGO=90360.1
SET DIC("DR")=".02////"_BDPDFN
SET X=BDPTYPE
+4 DO FILE^BDPFMC
+5 IF Y<0
QUIT "0^UNABLE TO ADD - FILEMAN FAILED"
+6 QUIT +Y
+7 ;
EDIT(BDPRIEN,BDPTYPE,BDPPROV) ;EP - edit/add to multiple
+1 IF '$GET(BDPRIEN)
QUIT "0^RECORD IEN INVALID"
+2 IF '$GET(BDPTYPE)
QUIT "0^PROVIDER TYPE INVALID"
+3 IF '$DATA(BDPPROV)
QUIT "0^PROVIDER IEN INVALID"
+4 NEW X,BDPLIEN,C,BDPLNUM,BDPNIEN
+5 IF '$DATA(^BDPRECN(BDPRIEN,1,0))
SET $PIECE(^(0),U,2)="90360.11P"
+6 SET (X,BDPLIEN,BDPLNUM)=0
+7 ;get last ien in multiple
FOR
SET X=$ORDER(^BDPRECN(BDPRIEN,1,X))
IF X'=+X
QUIT
SET BDPLIEN=X
SET BDPLNUM=BDPLNUM+1
+8 SET BDPNIEN=BDPLIEN+1
+9 SET BDPLNUM=BDPLNUM+1
+10 SET $PIECE(^BDPRECN(BDPRIEN,1,0),U,3)=BDPNIEN
+11 SET $PIECE(^BDPRECN(BDPRIEN,1,0),U,4)=BDPLNUM
+12 ;INACTIVE PREVIOUS ONE
+13 ;tell fileman you are coming from BDP
SET BDPLINKI=1
+14 KILL DIE,DA,DR
+15 IF BDPNIEN'=1
IF $PIECE(^BDPRECN(BDPRIEN,1,BDPLIEN,0),U,5)=""
SET DIE="^BDPRECN("_BDPRIEN_",1,"
SET DA(1)=BDPRIEN
SET DA=BDPLIEN
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM
+16 ;S DR=".01///"_"`"_BDPPROV
+17 SET ^BDPRECN(BDPRIEN,1,BDPNIEN,0)=BDPPROV_U_DUZ_U_DT_U_DT
+18 ;L +^BDPRECN(BDPRIEN):10 I '$T Q "0^UNABLE TO LOCK GLOBAL"
+19 ;S DIE="^BDPRECN("_BDPRIEN_",1,",DA(1)=BDPRIEN,DA=BDPLIEN D ^DIE K DIE,DR,DA,DINUM
+20 ;L -^BDPRECN(BDPRIEN)
+21 ;REINDEX MULTIPLE ENTRY
+22 NEW DIK
+23 SET DA(1)=BDPRIEN
SET DA=BDPNIEN
SET DIK="^BDPRECN("_BDPRIEN_",1,"
DO IX^DIK
KILL DIC,DA
+24 ;I $D(Y) Q "0^ADDING PROVIDER TO LOG FAILED"
+25 QUIT 1
+26 ;
DEL1(BDPPAT,BDPTYPE) ;
+1 NEW BDPX
+2 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPTYPE,0))
+3 ;doesn't have one so can't delete it
IF 'BDPX
QUIT 1
+4 NEW DA,DIE,DR,X,Y,DINUM
+5 ;IHS/CMI/LAB = added .04/.05 updating patch 22
SET DA=BDPX
SET DIE="^BDPRECN("
SET DR=".03///@;.04////"_DUZ_";.05////"_DT
DO ^DIE
+6 ;NOW WE HAVE TO UPDATE THE INACTIVE DATE IN THE MULTIPLE FOR THIS ONE BEING DELETED
+7 ;FIND THE MULTIPLE AND SET .05 EQUAL TO DT, .02 AND .03
+8 SET X=0
FOR
SET X=$ORDER(^BDPRECN(BDPX,1,X))
IF X'=+X
QUIT
SET Y=X
+9 IF Y
IF $PIECE(^BDPRECN(BDPX,1,Y,0),U,5)=""
SET DIE="^BDPRECN("_BDPX_",1,"
SET DA(1)=BDPX
SET DA=Y
SET DR=".02////"_DUZ_";.03////"_DT_";.05////"_DT
DO ^DIE
KILL DIE,DR,DA,DINUM
+10 QUIT 1
+11 ;
WHPCP(BDPPAT,BDPRET) ;PEP - return WH case managers and DPCP
+1 ; input: BDPPAT - DFN of patient
+2 ; BDPRET - return array
+3 ; return array BDPRET:
+4 ; BDPRET(category name)=name of provider^ien of provider^provider class of provider^date updated
+5 ; BDPRET("WOMEN'S HEALTH CASE MANAGER")=name of provider^ien of provider^provider class of provider^date updated
+6 ; BDPRET("DESIGNATED PRIMARY PROVIDER")=name of provider^ien of provider^provider class of provider^date updated
+7 ; BDPRET("WOMEN'S HEALTH ALTERNATE")=name of provider^ien of provider^provider class of provider^date updated
+8 ;
+9 ; If the patient does not have a provider in any of the above categories the array will not
+10 ; contain that category so if there is no dpcp then '$D(BDPRET("DESIGNATED PRIMARY CARE PROVIDER")
+11 ; will be true
+12 ;
+13 KILL BDPRET
+14 IF $GET(BDPPAT)=""
QUIT
+15 NEW BDPX,BDPY,BDPZ,BDPCIEN
+16 SET BDPCIEN=$ORDER(^BDPTCAT("B","DESIGNATED PRIMARY PROVIDER",0))
+17 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+18 IF BDPX
IF $PIECE($GET(^BDPRECN(BDPX,0)),U,3)]""
SET BDPY="DESIGNATED PRIMARY PROVIDER"
DO SETV
+19 SET BDPCIEN=0
FOR
SET BDPCIEN=$ORDER(^BDPTCAT(BDPCIEN))
IF BDPCIEN'=+BDPCIEN
QUIT
IF $PIECE(^BDPTCAT(BDPCIEN,0),U,6)
Begin DoDot:1
+20 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+21 IF 'BDPX
QUIT
+22 IF $PIECE(^BDPRECN(BDPX,0),U,3)=""
QUIT
+23 SET BDPY=$PIECE(^BDPTCAT(BDPCIEN,0),U,1)
DO SETV
+24 QUIT
End DoDot:1
+25 QUIT
SETV ;
+1 NEW BDPI
+2 SET BDPI=$$VALI^XBDIQ1(90360.1,BDPX,.03)
+3 SET BDPRET(BDPY)=$$VAL^XBDIQ1(90360.1,BDPX,.03)_"^"_BDPI_"^"_$$VAL^XBDIQ1(200,BDPI,53.5)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.05)
+4 QUIT
ALLDP(BDPPAT,BDPTYPE,BDPRET) ;PEP - return array of designated providers in all categories or 1 category
+1 ; input: BDPPAT - DFN of patient
+2 ; BDPTYPE - null if want all designated providers, or NAME of category, (e.g. RENAL DISEASE)
+3 ; if just want 1 provider category
+4 ; BDPRET - return array
+5 ; return array BDPRET:
+6 ; BDPRET(category name)=name of provider^ien of provider^provider class of provider^date updated
+7 ; example:
+8 ; BDPRET("WOMEN'S HEALTH CASE MANAGER")=name of provider^ien of provider^provider class of provider^date updated
+9 ; BDPRET("DESIGNATED PRIMARY PROVIDER")=name of provider^ien of provider^provider class of provider^date updated
+10 ;
+11 KILL BDPRET
+12 IF $GET(BDPPAT)=""
QUIT
+13 SET BDPTYPE=$GET(BDPTYPE)
+14 NEW BDPX,BDPY,BDPZ,BDPCIEN
+15 SET BDPCIEN=0
FOR
SET BDPCIEN=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN))
IF BDPCIEN'=+BDPCIEN
QUIT
Begin DoDot:1
+16 ;don't want this one
IF BDPTYPE]""
IF $PIECE(^BDPTCAT(BDPCIEN,0),U)'=BDPTYPE
QUIT
+17 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+18 IF 'BDPX
QUIT
+19 IF $PIECE(^BDPRECN(BDPX,0),U,3)=""
QUIT
+20 SET BDPY=$PIECE(^BDPTCAT(BDPCIEN,0),U,1)
DO SETV
+21 QUIT
End DoDot:1
+22 QUIT
PROVPANL(BDPPIEN) ;PEP - entry point to view/update one provider's panel
+1 IF '$GET(BDPPIEN)
QUIT
+2 DO EN^BDPDPEE
+3 QUIT
ALLDPVG(BDPPAT,BDPTYPE,BDPRET) ;PEP - return array of designated providers in all categories or 1 category
+1 ; input: BDPPAT - DFN of patient
+2 ; BDPTYPE - null if want all designated providers, or NAME of category, (e.g. RENAL DISEASE)
+3 ; if just want 1 provider category
+4 ; BDPRET - return array
+5 ; return array BDPRET:
+6 ; BDPRET(category IEN)=name of category^name of provider^ien of provider^provider class of provider^date updated^user last update
+7 ; example:
+8 ; BDPRET(12)=name of category^name of provider^ien of provider^provider class of provider^date updated
+9 ;
+10 KILL BDPRET
+11 IF $GET(BDPPAT)=""
QUIT
+12 SET BDPTYPE=$GET(BDPTYPE)
+13 NEW BDPX,BDPY,BDPZ,BDPCIEN
+14 SET BDPCIEN=0
FOR
SET BDPCIEN=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN))
IF BDPCIEN'=+BDPCIEN
QUIT
Begin DoDot:1
+15 ;don't want this one
IF BDPTYPE]""
IF $PIECE(^BDPTCAT(BDPCIEN,0),U)'=BDPTYPE
QUIT
+16 SET BDPX=$ORDER(^BDPRECN("AA",BDPPAT,BDPCIEN,0))
+17 IF 'BDPX
QUIT
+18 IF $PIECE(^BDPRECN(BDPX,0),U,3)=""
QUIT
+19 SET BDPY=BDPCIEN
DO SETV1
+20 QUIT
End DoDot:1
+21 QUIT
SETV1 ;
+1 NEW BDPI
+2 SET BDPI=$$VALI^XBDIQ1(90360.1,BDPX,.03)
+3 SET BDPRET(BDPY)=$PIECE(^BDPTCAT(BDPCIEN,0),U,1)_"^"_$$VAL^XBDIQ1(90360.1,BDPX,.03)_"^"_BDPI_"^"_$$VAL^XBDIQ1(200,BDPI,53.5)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.05)_"^"_$$VALI^XBDIQ1(90360.1,BDPX,.04)
+4 QUIT
MA(P) ;PEP - called to get message agent for a patient
+1 ;input - DFN
+2 ;output - message agent IEN from file 200^message agent name^message agent email address from message agent file
+3 ;if no message agent assigned to the patient null is returned
+4 IF '$GET(P)
QUIT ""
+5 IF '$DATA(^DPT(P,0))
QUIT ""
+6 NEW I,N,R,E
+7 DO ALLDP^BDPAPI(P,"MESSAGE AGENT",.R)
+8 ;patient does not have a message agent
IF '$DATA(R("MESSAGE AGENT"))
QUIT ""
+9 ;name
SET N=$PIECE(R("MESSAGE AGENT"),U,1)
+10 ;ien in file 200
SET I=$PIECE(R("MESSAGE AGENT"),U,2)
+11 ;dir email
SET E=$$GET1^DIQ(90360.5,I,.02)
+12 QUIT I_"^"_N_"^"_E
