BMCRR15.m

BMCRR15 ; IHS/PHXAO/TMJ - IN HOUSE REFERRALS BY PROVIDER ;   

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

 ;4.0 IHS/OIT/FCJ ADDED BROWSE FUNCTION AND TOTALS

 ;

START ;

 S BMCJOB=$J,BMCBTH=$H

 W !!,"This report will tally all in-house referrals by provider of service.",!

 W "Report will include both Primary and Secondary Referrals.",!!

D ;DATE RANGE

BD ;get beginning date

 W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning Referral Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S BMCBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_BMCBD_"::EP",DIR("A")="Enter ending Referral Date"  D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S BMCED=Y

 S X1=BMCBD,X2=-1 D C^%DTC S BMCSD=X

 ;

PROV ;

 S BMCPROV="" S DIR(0)="S^A:ALL Providers;O:ONE Provider",DIR("A")="Report should tally referrals for ",DIR("B")="A" K DA D ^DIR K DIR

 G:$D(DIRUT) D

 I Y="O" D GETPROV G:BMCPROV="" PROV

ZIS ;call to XBDBQUE

 D ZIS^BMCRUTL

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

 G:$G(BMCQUIT) XIT

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

 S XBRP="PRINT^BMCRR15",XBRC="PROC^BMCRR15",XBRX="XIT^BMCRR15",XBNS="BMC"

 D ^XBDBQUE

 D XIT

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^BMCRR15"")"

 S XBRC="PROC^BMCRR15",XBRX="XIT^BMCRR15",XBIOP=0,XBNS="BMC" D ^XBDBQUE

 Q

XIT ;EP

 K BMCPROV,BMCREF,BMCODAT,BMCBD,BMCED,BMCSD,BMCQUIT,BMCPG,BMCCLIN,BMCBT,BMCBTH,BMCET,BMCRREC,C,D,DFN,DIC,DIRUT,P,X,X1,X2,BMCSTOT

 D KILL^AUPNPAT

 Q

GETPROV ;

 S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D

 Q:Y=-1

 S BMCPROV=+Y

 Q

PROC ;EP called from xbdbque

 S BMCBT=$H

 S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q

 S BMCODAT=BMCSD_".9999" F  S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED)  D R1

END ;

 S BMCET=$H

 Q

R1 ;

 S BMCREF="" F  S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF  I $P(^BMCREF(BMCREF,0),U,4)="N" S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PROCR

 Q

PROCR ;

 I BMCPROV,$P(BMCRREC,U,6)'=BMCPROV Q

 S C=$P(BMCRREC,U,23),P=$P(BMCRREC,U,6)

 S C=$S(C:$P(^DIC(40.7,C,0),U),1:"<UNKNOWN>")

 S P=$S(P:$P(^VA(200,P,0),U),1:"<UNKNOWN>")

 S R=$S($P($G(^BMCREF(BMCREF,1)),U)'="":"S",1:"P") ;IHS/OIT/FCJ

 S ^(C)=$S($D(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",P,C)):^(C)+1,1:1)

 S ^(R)=$S($D(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",P,0,R)):^(R)+1,1:1) ;IHS/OIT/FCJ

 Q

PRINT ;EP called from xbdbque

 S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-")))

 S BMCQUIT=0

 I '$D(^XTMP("BMCRR15",BMCJOB,BMCBTH)) W !!,"No IN-HOUSE REFERRALS",! G DONE

 S BMCPROV="" F  S BMCPROV=$O(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV)) Q:BMCPROV=""!(BMCQUIT)  D CLINIC

DONE ;

 K ^XTMP("BMCRR15",BMCJOB,BMCBTH)

 D DONE^BMCRLP2

 Q

CLINIC ;

 I $Y>(IOSL-5) D HEAD Q:BMCQUIT

 W !!,BMCPROV S BMCSTOT=0

 S BMCCLIN=0 F  S BMCCLIN=$O(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV,BMCCLIN)) Q:BMCCLIN=""!(BMCQUIT)  D

 .I $Y>(IOSL-5) D HEAD Q:BMCQUIT

 .W !?25,BMCCLIN,?55,$J(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV,BMCCLIN),5) S BMCSTOT=BMCSTOT+^(BMCCLIN)

 S BMCSRTOT=$G(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",BMCPROV,0,"S")) ;IHS/OIT/FCJ

 S BMCPRTOT=$G(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",BMCPROV,0,"P")) ;IHS/OIT/FCJ

 I $Y>(IOSL-5) D HEAD Q:BMCQUIT

 W !!,"Total Secondary Referrals = ",$S(BMCSRTOT="":0,1:BMCSRTOT) ;IHS/OIT/FCJ

 W !,"Total Primary Referrals = ",$S(BMCPRTOT="":0,1:BMCPRTOT) ;IHS/OIT/FCJ

 W !,"Total for ",BMCPROV,?55,$J(BMCSTOT,5)

 Q

HEAD ;

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q

HEAD1 ;

 W:$D(IOF) @IOF

HEAD2 ;

 S BMCPG=BMCPG+1

 W !?55,$$FMTE^XLFDT(DT),?72,"Page ",BMCPG,!

 W ?20,"IN-HOUSE REFERRALS BY PROVIDER",!

 W ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)

 W !!,"PROVIDER",?25,"CLINIC REFERRED TO",?55,"NUMBER"

 W !,$TR($J(" ",80)," ","-")

 Q

BMCRR15   ; IHS/PHXAO/TMJ - IN HOUSE REFERRALS BY PROVIDER ;   

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

 +2       ;4.0 IHS/OIT/FCJ ADDED BROWSE FUNCTION AND TOTALS

 +3       ;

START     ;

 +1        SET BMCJOB=$JOB

           SET BMCBTH=$HOROLOG

 +2        WRITE !!,"This report will tally all in-house referrals by provider of service.",!

 +3        WRITE "Report will include both Primary and Secondary Referrals.",!!

D         ;DATE RANGE

BD        ;get beginning date

 +1        WRITE !

           SET DIR(0)="D^::EP"

           SET DIR("A")="Enter beginning Referral Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET BMCBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="D^"_BMCBD_"::EP"

           SET DIR("A")="Enter ending Referral Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET BMCED=Y

 +4        SET X1=BMCBD

           SET X2=-1

           DO C^%DTC

           SET BMCSD=X

 +5       ;

PROV      ;

 +1        SET BMCPROV=""

           SET DIR(0)="S^A:ALL Providers;O:ONE Provider"

           SET DIR("A")="Report should tally referrals for "

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               GOTO D

 +3        IF Y="O"

               DO GETPROV

               IF BMCPROV=""

                   GOTO PROV

ZIS       ;call to XBDBQUE

 +1        DO ZIS^BMCRUTL

 +2        IF $DATA(DIRUT)

               SET BMCQUIT=""

               GOTO XIT

 +3        IF $GET(BMCQUIT)

               GOTO XIT

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

               DO BROWSE

               DO XIT

               QUIT 

 +5        SET XBRP="PRINT^BMCRR15"

           SET XBRC="PROC^BMCRR15"

           SET XBRX="XIT^BMCRR15"

           SET XBNS="BMC"

 +6        DO ^XBDBQUE

 +7        DO XIT

 +8        QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^BMCRR15"")"

 +2        SET XBRC="PROC^BMCRR15"

           SET XBRX="XIT^BMCRR15"

           SET XBIOP=0

           SET XBNS="BMC"

           DO ^XBDBQUE

 +3        QUIT 

XIT       ;EP

 +1        KILL BMCPROV,BMCREF,BMCODAT,BMCBD,BMCED,BMCSD,BMCQUIT,BMCPG,BMCCLIN,BMCBT,BMCBTH,BMCET,BMCRREC,C,D,DFN,DIC,DIRUT,P,X,X1,X2,BMCSTOT

 +2        DO KILL^AUPNPAT

 +3        QUIT 

GETPROV   ;

 +1        SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

           SET D="AK.PROVIDER"

           SET DIC("A")="Enter PROVIDER (Lastname,Firstname): "

           DO MIX^DIC1

           KILL DIC,D

 +2        IF Y=-1

               QUIT 

 +3        SET BMCPROV=+Y

 +4        QUIT 

PROC      ;EP called from xbdbque

 +1        SET BMCBT=$HOROLOG

 +2        SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))

           IF BMCODAT=""

               SET BMCET=$HOROLOG

               QUIT 

 +3        SET BMCODAT=BMCSD_".9999"

           FOR 

               SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))

               IF BMCODAT=""!((BMCODAT\1)>BMCED)

                   QUIT 

               DO R1

END       ;

 +1        SET BMCET=$HOROLOG

 +2        QUIT 

R1        ;

 +1        SET BMCREF=""

           FOR 

               SET BMCREF=$ORDER(^BMCREF("B",BMCODAT,BMCREF))

               IF BMCREF'=+BMCREF

                   QUIT 

               IF $PIECE(^BMCREF(BMCREF,0),U,4)="N"

                   SET BMCRREC=^BMCREF(BMCREF,0)

                   SET DFN=$PIECE(BMCRREC,U,3)

                   DO PROCR

 +2        QUIT 

PROCR     ;

 +1        IF BMCPROV

               IF $PIECE(BMCRREC,U,6)'=BMCPROV

                   QUIT 

 +2        SET C=$PIECE(BMCRREC,U,23)

           SET P=$PIECE(BMCRREC,U,6)

 +3        SET C=$SELECT(C:$PIECE(^DIC(40.7,C,0),U),1:"<UNKNOWN>")

 +4        SET P=$SELECT(P:$PIECE(^VA(200,P,0),U),1:"<UNKNOWN>")

 +5       ;IHS/OIT/FCJ

           SET R=$SELECT($PIECE($GET(^BMCREF(BMCREF,1)),U)'="":"S",1:"P")

 +6        SET ^(C)=$SELECT($DATA(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",P,C)):^(C)+1,1:1)

 +7       ;IHS/OIT/FCJ

           SET ^(R)=$SELECT($DATA(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",P,0,R)):^(R)+1,1:1)

 +8        QUIT 

PRINT     ;EP called from xbdbque

 +1        SET BMCPG=0

           DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))

 +2        SET BMCQUIT=0

 +3        IF '$DATA(^XTMP("BMCRR15",BMCJOB,BMCBTH))

               WRITE !!,"No IN-HOUSE REFERRALS",!

               GOTO DONE

 +4        SET BMCPROV=""

           FOR 

               SET BMCPROV=$ORDER(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV))

               IF BMCPROV=""!(BMCQUIT)

                   QUIT 

               DO CLINIC

DONE      ;

 +1        KILL ^XTMP("BMCRR15",BMCJOB,BMCBTH)

 +2        DO DONE^BMCRLP2

 +3        QUIT 

CLINIC    ;

 +1        IF $Y>(IOSL-5)

               DO HEAD

               IF BMCQUIT

                   QUIT 

 +2        WRITE !!,BMCPROV

           SET BMCSTOT=0

 +3        SET BMCCLIN=0

           FOR 

               SET BMCCLIN=$ORDER(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV,BMCCLIN))

               IF BMCCLIN=""!(BMCQUIT)

                   QUIT 

               Begin DoDot:1

 +4                IF $Y>(IOSL-5)

                       DO HEAD

                       IF BMCQUIT

                           QUIT 

 +5                WRITE !?25,BMCCLIN,?55,$JUSTIFY(^XTMP("BMCRR15",BMCJOB,BMCBTH,"PROV",BMCPROV,BMCCLIN),5)

                   SET BMCSTOT=BMCSTOT+^(BMCCLIN)

               End DoDot:1

 +6       ;IHS/OIT/FCJ

           SET BMCSRTOT=$GET(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",BMCPROV,0,"S"))

 +7       ;IHS/OIT/FCJ

           SET BMCPRTOT=$GET(^XTMP("BMCRR16",BMCJOB,BMCBTH,"PROV",BMCPROV,0,"P"))

 +8        IF $Y>(IOSL-5)

               DO HEAD

               IF BMCQUIT

                   QUIT 

 +9       ;IHS/OIT/FCJ

           WRITE !!,"Total Secondary Referrals = ",$SELECT(BMCSRTOT="":0,1:BMCSRTOT)

 +10      ;IHS/OIT/FCJ

           WRITE !,"Total Primary Referrals = ",$SELECT(BMCPRTOT="":0,1:BMCPRTOT)

 +11       WRITE !,"Total for ",BMCPROV,?55,$JUSTIFY(BMCSTOT,5)

 +12       QUIT 

HEAD      ;

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET BMCQUIT=1

                       QUIT 

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

HEAD2     ;

 +1        SET BMCPG=BMCPG+1

 +2        WRITE !?55,$$FMTE^XLFDT(DT),?72,"Page ",BMCPG,!

 +3        WRITE ?20,"IN-HOUSE REFERRALS BY PROVIDER",!

 +4        WRITE ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)

 +5        WRITE !!,"PROVIDER",?25,"CLINIC REFERRED TO",?55,"NUMBER"

 +6        WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")

 +7        QUIT