BDPCHNGD ; IHS/CMI/TMJ - CHANGE NON-EXISTING PROVIDER TO NEW PROVIDER ;
;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34
;
; Subscripted BDPREC is EXTERNAL form.
; BDPREC("PAT NAME")=patient name
; BDPREC("PROV TYPE")=Provider Category Type
; BDPDFN=patient ien
; BDPRDATE=date in internal FileMan form
; BDPRIEN=Designated Provider ien
;
;This routine populates records which have deleted the
;current Desg. Provider and can assign unassigned patients
;to a current new Provider.
START ;
;
D INFORM ;Data Entry Explanation
;
D MAIN Q:BDPQ D HDR^BDP
D EOJ
Q
;
MAIN ;
S BDPQ=0,BDPYI=0
D ASK
Q:BDPQ
D PROV
I BDPQ=1 G MAIN
;
;D ASK
;
GETTYPE ;Do Get Date if no existing Designated Providers
D TYPE ; get Provider Category Type
Q:BDPQ
D ASKGO ; add new Designated Provider record
S BDPQ=0
Q
;
;
;
;
ASK ;Ask to Continue
S BDPQ=0
W !! S DIR(0)="Y",DIR("A")="Do you want to continue changing the Designated Provider for each Patient",DIR("B")="Y" K DA D ^DIR K DIR
I $D(DIRUT) S BDPQ=1 Q
I 'Y S BDPQ=1 Q
Q
;
;
TYPE ; GET CATEGORY TYPE FOR DESIGNATED PROVIDER
W !
S BDPQ=1
S DIR(0)="90360.1,.01",DIR("B")="DPCP" K DA D ^DIR K DIR
Q:$D(DIRUT)
S BDPTYPE=+Y,BDPREC("PROV TYPE")=Y(0)
I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",'$D(^BDPMSGA("B",BDPPROV)) D G TYPE
.W !!,"The provider you selected is not listed as a Message Agent, he/she must "
.W !,"be added to the Message Agent List using the option on the Manager's "
.W !,"Menu before they can be assigned as a message agent.",!
I $P(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT",$P($G(^BDPMSGA(BDPPROV,0)),U,3) D G TYPE
.W !!,"The provider you selected has been inactivated as a message agent, he/she"
.W !," must be reactivated using the option on the Manager's Menu before they can "
.W !,"be assigned as a message agent.",!
;
S BDPQ=0
Q
PROV ; GET DESIGNATED PROVIDER
S BDPPROV="",BDPQ=0
S DIC("A")="Select New Designated Provider: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA S:$D(DUOUT) DIRUT=1,BDPQ=1
Q:$D(DIRUT)
I +Y<1 S BDPQ=1 Q
S X=$$CHKPROV^BDPDPEE(+Y) I X S BDPQ=1 Q
S BDPPROV=+Y,BDPRPROV=$P(Y,U,2)
S BDPRPRVP=$P(^VA(200,BDPPROV,0),U,1) ;Provider Print Name
S BDPQ=0
Q
;
ASKGO ;Ask to continue
;
W !!!,?8,"**********************************************",!
W !!,?8,"Okay, all Patients with NO EXISTING Current Provider : ",!
W ?8,"Will be assigned to NEW Provider Named: "_BDPRPRVP W !
W ?8,"For Designated Provider Category/Type: "_$P($G(^BDPTCAT(BDPTYPE,0)),U,1) W !!
W !,?8,"**********************************************",!
;
;
S DIR(0)="Y",DIR("A")="Do you wish to Continue Updating to a new CURRENT Designated Provider",DIR("?")="Enter Y for Yes or N for NO",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S BDPQ=1 Q
I Y=0 S BDPQ=1 Q
;
;
UPDATE ;Update Records
;
S BDPIEN="" F S BDPIEN=$O(^BDPRECN("B",BDPTYPE,BDPIEN)) Q:BDPIEN'=+BDPIEN D
. Q:BDPIEN=""
. S BDPTYPEM=$P($G(^BDPRECN(BDPIEN,0)),U) ;Type to Match On
. Q:BDPTYPEM=""
. Q:BDPTYPE=""
. I BDPTYPE'=BDPTYPEM Q ;Quit if No Match
. S BDPPAT=$P($G(^BDPRECN(BDPIEN,0)),U,2) ;Patient
. Q:BDPPAT=""
. S BDPOPROV=$P($G(^BDPRECN(BDPIEN,0)),U,3) ;Existing Provider
. Q:BDPOPROV'="" ;Quit if they already have a Provider
. ;Otherwise go on and populate these non-existing Current Providers
. ;with the new one the User Selected
. Q:BDPPROV="" ;Quit if No New Provider
. S X=$$CREATE^BDPAMA(BDPPAT,BDPTYPE,BDPPROV) Q
;
;
MSGEND ;End of Add Message
W !!!!,"Okay - I have changed all Patient Records - as follows: ",! D Q
.W !,"OLD Designated Provider: No Current Provider Assigned",!
. W "has been re-assigned to NEW Designated Provider:"_BDPRPRVP W !
. W "For Designated Provider Category/Type: "_$P($G(^BDPTCAT(BDPTYPE,0)),U,1) W !!
. ;W "Note: If this Designated Provider already existed for the patient",!,?7," - No change was made to the patient record-.",!
. D PAUSE^BDP
S BDPQ=0
Q
;
;
EOJ ; END OF JOB
D ^BDPKILL
Q
;
INFORM ;Data Entry Explanation
;
W !,?3,"This Option allows the automatic changing Existing Records......",!,?10,"from an Unassigned (blank) CURRENT Designated Provider -",!,?10,"to a NEW assigned Designated Provider.",!!
W ?3,"The User is prompted for the NEW Provider Name.",!
W ?3,"Once the desired Provider Category Type is selected by the User,",!
W ?3,"the Program will automatically LOOP through all Records and",!,?3,"change to the NEW Provider for this Category Type.",!!
W ?3,"If the patient's existing Provider/Category Type are the same,",!,?3,"no update will occur.",!
Q
BDPCHNGD ; IHS/CMI/TMJ - CHANGE NON-EXISTING PROVIDER TO NEW PROVIDER ;
+1 ;;2.0;IHS PCC SUITE;**10,21**;MAY 14, 2009;Build 34
+2 ;
+3 ; Subscripted BDPREC is EXTERNAL form.
+4 ; BDPREC("PAT NAME")=patient name
+5 ; BDPREC("PROV TYPE")=Provider Category Type
+6 ; BDPDFN=patient ien
+7 ; BDPRDATE=date in internal FileMan form
+8 ; BDPRIEN=Designated Provider ien
+9 ;
+10 ;This routine populates records which have deleted the
+11 ;current Desg. Provider and can assign unassigned patients
+12 ;to a current new Provider.
START ;
+1 ;
+2 ;Data Entry Explanation
DO INFORM
+3 ;
+4 DO MAIN
IF BDPQ
QUIT
DO HDR^BDP
+5 DO EOJ
+6 QUIT
+7 ;
MAIN ;
+1 SET BDPQ=0
SET BDPYI=0
+2 DO ASK
+3 IF BDPQ
QUIT
+4 DO PROV
+5 IF BDPQ=1
GOTO MAIN
+6 ;
+7 ;D ASK
+8 ;
GETTYPE ;Do Get Date if no existing Designated Providers
+1 ; get Provider Category Type
DO TYPE
+2 IF BDPQ
QUIT
+3 ; add new Designated Provider record
DO ASKGO
+4 SET BDPQ=0
+5 QUIT
+6 ;
+7 ;
+8 ;
+9 ;
ASK ;Ask to Continue
+1 SET BDPQ=0
+2 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue changing the Designated Provider for each Patient"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET BDPQ=1
QUIT
+4 IF 'Y
SET BDPQ=1
QUIT
+5 QUIT
+6 ;
+7 ;
TYPE ; GET CATEGORY TYPE FOR DESIGNATED PROVIDER
+1 WRITE !
+2 SET BDPQ=1
+3 SET DIR(0)="90360.1,.01"
SET DIR("B")="DPCP"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET BDPTYPE=+Y
SET BDPREC("PROV TYPE")=Y(0)
+6 IF $PIECE(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT"
IF '$DATA(^BDPMSGA("B",BDPPROV))
Begin DoDot:1
+7 WRITE !!,"The provider you selected is not listed as a Message Agent, he/she must "
+8 WRITE !,"be added to the Message Agent List using the option on the Manager's "
+9 WRITE !,"Menu before they can be assigned as a message agent.",!
End DoDot:1
GOTO TYPE
+10 IF $PIECE(^BDPTCAT(BDPTYPE,0),U,1)="MESSAGE AGENT"
IF $PIECE($GET(^BDPMSGA(BDPPROV,0)),U,3)
Begin DoDot:1
+11 WRITE !!,"The provider you selected has been inactivated as a message agent, he/she"
+12 WRITE !," must be reactivated using the option on the Manager's Menu before they can "
+13 WRITE !,"be assigned as a message agent.",!
End DoDot:1
GOTO TYPE
+14 ;
+15 SET BDPQ=0
+16 QUIT
PROV ; GET DESIGNATED PROVIDER
+1 SET BDPPROV=""
SET BDPQ=0
+2 SET DIC("A")="Select New Designated Provider: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
IF $DATA(DUOUT)
SET DIRUT=1
SET BDPQ=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF +Y<1
SET BDPQ=1
QUIT
+5 SET X=$$CHKPROV^BDPDPEE(+Y)
IF X
SET BDPQ=1
QUIT
+6 SET BDPPROV=+Y
SET BDPRPROV=$PIECE(Y,U,2)
+7 ;Provider Print Name
SET BDPRPRVP=$PIECE(^VA(200,BDPPROV,0),U,1)
+8 SET BDPQ=0
+9 QUIT
+10 ;
ASKGO ;Ask to continue
+1 ;
+2 WRITE !!!,?8,"**********************************************",!
+3 WRITE !!,?8,"Okay, all Patients with NO EXISTING Current Provider : ",!
+4 WRITE ?8,"Will be assigned to NEW Provider Named: "_BDPRPRVP
WRITE !
+5 WRITE ?8,"For Designated Provider Category/Type: "_$PIECE($GET(^BDPTCAT(BDPTYPE,0)),U,1)
WRITE !!
+6 WRITE !,?8,"**********************************************",!
+7 ;
+8 ;
+9 SET DIR(0)="Y"
SET DIR("A")="Do you wish to Continue Updating to a new CURRENT Designated Provider"
SET DIR("?")="Enter Y for Yes or N for NO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
SET BDPQ=1
QUIT
+11 IF Y=0
SET BDPQ=1
QUIT
+12 ;
+13 ;
UPDATE ;Update Records
+1 ;
+2 SET BDPIEN=""
FOR
SET BDPIEN=$ORDER(^BDPRECN("B",BDPTYPE,BDPIEN))
IF BDPIEN'=+BDPIEN
QUIT
Begin DoDot:1
+3 IF BDPIEN=""
QUIT
+4 ;Type to Match On
SET BDPTYPEM=$PIECE($GET(^BDPRECN(BDPIEN,0)),U)
+5 IF BDPTYPEM=""
QUIT
+6 IF BDPTYPE=""
QUIT
+7 ;Quit if No Match
IF BDPTYPE'=BDPTYPEM
QUIT
+8 ;Patient
SET BDPPAT=$PIECE($GET(^BDPRECN(BDPIEN,0)),U,2)
+9 IF BDPPAT=""
QUIT
+10 ;Existing Provider
SET BDPOPROV=$PIECE($GET(^BDPRECN(BDPIEN,0)),U,3)
+11 ;Quit if they already have a Provider
IF BDPOPROV'=""
QUIT
+12 ;Otherwise go on and populate these non-existing Current Providers
+13 ;with the new one the User Selected
+14 ;Quit if No New Provider
IF BDPPROV=""
QUIT
+15 SET X=$$CREATE^BDPAMA(BDPPAT,BDPTYPE,BDPPROV)
QUIT
End DoDot:1
+16 ;
+17 ;
MSGEND ;End of Add Message
+1 WRITE !!!!,"Okay - I have changed all Patient Records - as follows: ",!
Begin DoDot:1
+2 WRITE !,"OLD Designated Provider: No Current Provider Assigned",!
+3 WRITE "has been re-assigned to NEW Designated Provider:"_BDPRPRVP
WRITE !
+4 WRITE "For Designated Provider Category/Type: "_$PIECE($GET(^BDPTCAT(BDPTYPE,0)),U,1)
WRITE !!
+5 ;W "Note: If this Designated Provider already existed for the patient",!,?7," - No change was made to the patient record-.",!
+6 DO PAUSE^BDP
End DoDot:1
QUIT
+7 SET BDPQ=0
+8 QUIT
+9 ;
+10 ;
EOJ ; END OF JOB
+1 DO ^BDPKILL
+2 QUIT
+3 ;
INFORM ;Data Entry Explanation
+1 ;
+2 WRITE !,?3,"This Option allows the automatic changing Existing Records......",!,?10,"from an Unassigned (blank) CURRENT Designated Provider -",!,?10,"to a NEW assigned Designated Provider.",!!
+3 WRITE ?3,"The User is prompted for the NEW Provider Name.",!
+4 WRITE ?3,"Once the desired Provider Category Type is selected by the User,",!
+5 WRITE ?3,"the Program will automatically LOOP through all Records and",!,?3,"change to the NEW Provider for this Category Type.",!!
+6 WRITE ?3,"If the patient's existing Provider/Category Type are the same,",!,?3,"no update will occur.",!
+7 QUIT
