BMCRR5.m

BMCRR5 ; IHS/PHXAO/TMJ - patients without medical and/or cost data;    

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

 ;IHS/ITSC/FCJ ADDED VAR ;ADDED REQUEST TO SORT BY ALPHA

 ;

START ;

 W:$D(IOF) @IOF

 W !,"This report will list patients who are currently under treatment at outside ",!,"referral facilities.  The definition of those under treatment at outside"

 W !,"facilities is the following:"

 W !?5,"- the referral is an Inpatient referral"

 W !?5,"- the beginning date of service is today or earlier and the expected",!?7,"end date of service is on or after today's date of " W $$FMTE^XLFDT(DT)

 W !?5,"- the status of the referral is active",!,?5,"- Inhouse Referrals are excluded",!

 W !,"This transfer log will contain a 1-2 page detailed summary record display",!,"for each referral.",!

 ;

 ;

SORT ;sort by?

 S BMCSTYPE=""

 S DIR(0)="S^F:Facility Referred to;C:Case Manager;P:Patient Name",DIR("A")="Sort output by which of the above",DIR("B")="F" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 S BMCSTYPE=Y

 S BMCSTYPA=""

 I BMCSTYPE'="P" D  G:$D(DIRUT) SORT

 .S DIR(0)="Y",DIR("A")="Would you like entries listed alphabetically by patient name",DIR("B")="Y" K DA D ^DIR K DIR

 .Q:$D(DIRUT)

 .S BMCSTYPA=Y

 ;

PAGE ;separate page for each

 S BMCSPAGE=""

 S DIR(0)="Y",DIR("A")="Do you want each "_$S(BMCSTYPE="C":"Case Manager",BMCSTYPE="P":"Patient",BMCSTYPE="F":"Facility")_" on a separate page",DIR("B")="N" K DA D ^DIR K DIR

 I $D(DIRUT) G SORT

 S BMCSPAGE=Y

SECREF ;PRINT SEC REF AS A SEPARATE ENTRY

 S BMCTYPR=""

 S DIR(0)="Y",DIR("A")="Would you like to print the Secondary Referrals as Separate entries",DIR("B")="N" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S BMCTYPR=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="" Q

 S BMCOPT=Y

 G:$G(BMCQUIT) XIT

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

 S XBRP="^BMCRR5P",XBRC="^BMCRR51",XBRX="XIT^BMCRR5",XBNS="BMC"

 D ^XBDBQUE

 D XIT

 Q

BROWSE ;

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

 S XBRC="^BMCRR51",XBRX="XIT^BMCRR5",XBIOP=0 D ^XBDBQUE

 Q

XIT ;EP - CALLED FROM BMCRR5

 D KILL^AUPNPAT

 K BMC1,BMC2,BMC80D,BMC80E,BMCAR,BMCBT,BMCBTH,BMCCOL,BMCCTR,BMCET,BMCFILE,BMCG,BMCH,BMCI,BMCJOB,BMCNODE,BMCOPT,BMCPG,BMCPN,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSTR,BMCV,BMCVDFN,BMCVDG,BMCVFILE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY

 K %,C,D0,DA,DFN,DI,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,F,I,X,Y,Z

 K BMCD,BMCHRN,BMCSORT,BMCP,BMCSPAGE,BMCSTYPE,BMCTST,BMC15S,BMCRNUMB,BMCTYPR

 Q

BMCRR5    ; IHS/PHXAO/TMJ - patients without medical and/or cost data;    

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

 +2       ;IHS/ITSC/FCJ ADDED VAR ;ADDED REQUEST TO SORT BY ALPHA

 +3       ;

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,"This report will list patients who are currently under treatment at outside ",!,"referral facilities.  The definition of those under treatment at outside"

 +3        WRITE !,"facilities is the following:"

 +4        WRITE !?5,"- the referral is an Inpatient referral"

 +5        WRITE !?5,"- the beginning date of service is today or earlier and the expected",!?7,"end date of service is on or after today's date of "

           WRITE $$FMTE^XLFDT(DT)

 +6        WRITE !?5,"- the status of the referral is active",!,?5,"- Inhouse Referrals are excluded",!

 +7        WRITE !,"This transfer log will contain a 1-2 page detailed summary record display",!,"for each referral.",!

 +8       ;

 +9       ;

SORT      ;sort by?

 +1        SET BMCSTYPE=""

 +2        SET DIR(0)="S^F:Facility Referred to;C:Case Manager;P:Patient Name"

           SET DIR("A")="Sort output by which of the above"

           SET DIR("B")="F"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET BMCSTYPE=Y

 +5        SET BMCSTYPA=""

 +6        IF BMCSTYPE'="P"

               Begin DoDot:1

 +7                SET DIR(0)="Y"

                   SET DIR("A")="Would you like entries listed alphabetically by patient name"

                   SET DIR("B")="Y"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +8                IF $DATA(DIRUT)

                       QUIT 

 +9                SET BMCSTYPA=Y

               End DoDot:1

               IF $DATA(DIRUT)

                   GOTO SORT

 +10      ;

PAGE      ;separate page for each

 +1        SET BMCSPAGE=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Do you want each "_$SELECT(BMCSTYPE="C":"Case Manager",BMCSTYPE="P":"Patient",BMCSTYPE="F":"Facility")_" on a separate page"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO SORT

 +4        SET BMCSPAGE=Y

SECREF    ;PRINT SEC REF AS A SEPARATE ENTRY

 +1        SET BMCTYPR=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Would you like to print the Secondary Referrals as Separate entries"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET BMCTYPR=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=""

               QUIT 

 +4        SET BMCOPT=Y

 +5        IF $GET(BMCQUIT)

               GOTO XIT

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

               DO BROWSE

               DO XIT

               QUIT 

 +7        SET XBRP="^BMCRR5P"

           SET XBRC="^BMCRR51"

           SET XBRX="XIT^BMCRR5"

           SET XBNS="BMC"

 +8        DO ^XBDBQUE

 +9        DO XIT

 +10       QUIT 

BROWSE    ;

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

 +2        SET XBRC="^BMCRR51"

           SET XBRX="XIT^BMCRR5"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

XIT       ;EP - CALLED FROM BMCRR5

 +1        DO KILL^AUPNPAT

 +2        KILL BMC1,BMC2,BMC80D,BMC80E,BMCAR,BMCBT,BMCBTH,BMCCOL,BMCCTR,BMCET,BMCFILE,BMCG,BMCH,BMCI,BMCJOB,BMCNODE,BMCOPT,BMCPG,BMCPN,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSTR,BMCV,BMCVDFN,BMCVDG,BMCVFILE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY

 +3        KILL %,C,D0,DA,DFN,DI,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,F,I,X,Y,Z

 +4        KILL BMCD,BMCHRN,BMCSORT,BMCP,BMCSPAGE,BMCSTYPE,BMCTST,BMC15S,BMCRNUMB,BMCTYPR

 +5        QUIT