BMCRR13.m

BMCRR13 ; IHS/PHXAO/TMJ - list active referral by Requesting Provider ; 

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;IHS/ITSC/FCJ ADDED BEG AND END DATE SELECTION TO REPORT

 ;

START ;

 W !!,"This report prints out a list of all referrals that are still",!,"active (not closed), sorted by the provider within your facility who requested",!,"it.  You can select to print just one provider's list or all providers' lists"

 W !,"in which case you can optionally print each provider's list on a separate",!,"page.",!

 W !,"In-House Referrals are excluded in this report.",!

BD ;GET BEG AND ENDING DATES

 D BD^BMCRUTL

 G:$D(DIRUT) XIT

PROV ;

 S BMCPROV=""

 S DIR(0)="S^A:ALL PROVIDERS;O:ONE PROVIDER",DIR("A")="Display referrals for ",DIR("B")="A" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 I Y="A" G PAGE

PROV1 ;

 S DIR(0)="90001,.06",DIR("A")="Enter Referring Provider" K DA D ^DIR K DIR

 G:$D(DIRUT) PROV

 G:Y="" PROV

 S BMCPROV=+Y,BMCSPAGE=0 G ZIS

PAGE ;separate page for each

 S BMCSPAGE=""

 S DIR(0)="Y",DIR("A")="Do you want each Provider on a separate page",DIR("B")="N" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 S BMCSPAGE=Y

ZIS ;call to XBDBQUE

 K BMCOPT

 W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) S BMCQUIT="" G XIT

 S BMCOPT=Y

 G:$G(BMCQUIT) PAGE

 I $G(BMCOPT)="B" D BROWSE,XIT Q

 S XBRP="^BMCRR13P",XBRC="^BMCRR131",XBRX="XIT^BMCRR13",XBNS="BMC"

 D ^XBDBQUE

 D XIT

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""^BMCRR13P"")"

 S XBRC="^BMCRR131",XBRX="XIT^BMCRR13",XBIOP=0 D ^XBDBQUE

 Q

XIT ;EP - CALLED FROM BMCRR13

 D KILL^AUPNPAT

 K BMC80D,BMC80E,BMCBT,BMCBTH,BMCET,BMCPRV,BMCJOB,BMCOPT,BMCPG,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSPAGE,BMCPROV

 K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD

 K DA,DFN,DIR,DIRUT,DTOUT,X,Y

 Q

BMCRR13   ; IHS/PHXAO/TMJ - list active referral by Requesting Provider ; 

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;IHS/ITSC/FCJ ADDED BEG AND END DATE SELECTION TO REPORT

 +3       ;

START     ;

 +1        WRITE !!,"This report prints out a list of all referrals that are still",!,"active (not closed), sorted by the provider within your facility who requested",!,"it.  You can select to print just one provider's list or all providers' lists"

 +2        WRITE !,"in which case you can optionally print each provider's list on a separate",!,"page.",!

 +3        WRITE !,"In-House Referrals are excluded in this report.",!

BD        ;GET BEG AND ENDING DATES

 +1        DO BD^BMCRUTL

 +2        IF $DATA(DIRUT)

               GOTO XIT

PROV      ;

 +1        SET BMCPROV=""

 +2        SET DIR(0)="S^A:ALL PROVIDERS;O:ONE PROVIDER"

           SET DIR("A")="Display referrals for "

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        IF Y="A"

               GOTO PAGE

PROV1     ;

 +1        SET DIR(0)="90001,.06"

           SET DIR("A")="Enter Referring Provider"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               GOTO PROV

 +3        IF Y=""

               GOTO PROV

 +4        SET BMCPROV=+Y

           SET BMCSPAGE=0

           GOTO ZIS

PAGE      ;separate page for each

 +1        SET BMCSPAGE=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Do you want each Provider on a separate page"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET BMCSPAGE=Y

ZIS       ;call to XBDBQUE

 +1        KILL BMCOPT

 +2        WRITE !

           SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               SET BMCQUIT=""

               GOTO XIT

 +4        SET BMCOPT=Y

 +5        IF $GET(BMCQUIT)

               GOTO PAGE

 +6        IF $GET(BMCOPT)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +7        SET XBRP="^BMCRR13P"

           SET XBRC="^BMCRR131"

           SET XBRX="XIT^BMCRR13"

           SET XBNS="BMC"

 +8        DO ^XBDBQUE

 +9        DO XIT

 +10       QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""^BMCRR13P"")"

 +2        SET XBRC="^BMCRR131"

           SET XBRX="XIT^BMCRR13"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

XIT       ;EP - CALLED FROM BMCRR13

 +1        DO KILL^AUPNPAT

 +2        KILL BMC80D,BMC80E,BMCBT,BMCBTH,BMCET,BMCPRV,BMCJOB,BMCOPT,BMCPG,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSPAGE,BMCPROV

 +3        KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD

 +4        KILL DA,DFN,DIR,DIRUT,DTOUT,X,Y

 +5        QUIT