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
