Routine: BDPCHNGD

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

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

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

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

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

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

EOJ ; END OF JOB

 D ^BDPKILL

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.",!

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

BDPCHNGD.m