BMCRR16 ; 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 clinic referred to.",!
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
;
CLIN ;
S BMCCLIN="" S DIR(0)="S^A:ALL Clinics;O:ONE Clinic",DIR("A")="Report should tally referrals for ",DIR("B")="A" K DA D ^DIR K DIR
G:$D(DIRUT) D
I Y="O" D GETCLIN G:BMCCLIN="" CLIN
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^BMCRR16",XBRC="PROC^BMCRR16",XBRX="XIT^BMCRR16",XBNS="BMC"
D ^XBDBQUE
D XIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^BMCRR16"")"
S XBRC="PROC^BMCRR16",XBRX="XIT^BMCRR16",XBIOP=0,XBNS="BMC" D ^XBDBQUE
Q
XIT ;EP
K BMCPROV,BMCREF,BMCODAT,BMCBD,BMCED,BMCSD,BMCQUIT,BMCPG,BMCCLIN,BMCBT,BMCBTH,BMCET,BMCJOB,BMCRREC,BMCSTOT,D,DFN,DIC,DIRUT,DTOUT,DUOUT,P,X1,X2
K BMCSRTOT,BMCPRTOT
D KILL^AUPNPAT
Q
GETCLIN ;
S DIC="^DIC(40.7,",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y=-1
S BMCCLIN=+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 BMCCLIN,$P(BMCRREC,U,23)'=BMCCLIN 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 ^(P)=$S($D(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",C,P)):^(P)+1,1:1)
S ^(R)=$S($D(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",C,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("BMCRR16",BMCJOB,BMCBTH)) W !!,"No IN-HOUSE REFERRALS",! G DONE
S BMCCLIN="" F S BMCCLIN=$O(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN)) Q:BMCCLIN=""!(BMCQUIT) D PROVIDER
DONE ;
K ^XTMP("BMCRR16",BMCJOB,BMCBTH)
D DONE^BMCRLP2
Q
PROVIDER ;
I $Y>(IOSL-5) D HEAD Q:BMCQUIT
W !!,BMCCLIN S (BMCSTOT,BMCPRTOT,BMCSRTOT)=0
S BMCPROV=0 F S BMCPROV=$O(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,BMCPROV)) Q:BMCPROV=""!(BMCQUIT) D
.I $Y>(IOSL-5) D HEAD Q:BMCQUIT
.W !?20,BMCPROV,?50,$J(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,BMCPROV),5) S BMCSTOT=BMCSTOT+^(BMCPROV)
S BMCSRTOT=$G(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,0,"S")) ;IHS/OIT/FCJ
S BMCPRTOT=$G(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,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 ",BMCCLIN,?50,$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 CLINIC",!
W ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)
W !!,"CLINIC REFERRED TO",?20,"PROVIDER REFERRED FROM",?50,"NUMBER"
W !,$TR($J(" ",80)," ","-")
Q
BMCRR16 ; 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 clinic referred to.",!
+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 ;
CLIN ;
+1 SET BMCCLIN=""
SET DIR(0)="S^A:ALL Clinics;O:ONE Clinic"
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 GETCLIN
IF BMCCLIN=""
GOTO CLIN
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^BMCRR16"
SET XBRC="PROC^BMCRR16"
SET XBRX="XIT^BMCRR16"
SET XBNS="BMC"
+6 DO ^XBDBQUE
+7 DO XIT
+8 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^BMCRR16"")"
+2 SET XBRC="PROC^BMCRR16"
SET XBRX="XIT^BMCRR16"
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,BMCJOB,BMCRREC,BMCSTOT,D,DFN,DIC,DIRUT,DTOUT,DUOUT,P,X1,X2
+2 KILL BMCSRTOT,BMCPRTOT
+3 DO KILL^AUPNPAT
+4 QUIT
GETCLIN ;
+1 SET DIC="^DIC(40.7,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF Y=-1
QUIT
+3 SET BMCCLIN=+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 BMCCLIN
IF $PIECE(BMCRREC,U,23)'=BMCCLIN
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 ^(P)=$SELECT($DATA(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",C,P)):^(P)+1,1:1)
+7 ;IHS/OIT/FCJ
SET ^(R)=$SELECT($DATA(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",C,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("BMCRR16",BMCJOB,BMCBTH))
WRITE !!,"No IN-HOUSE REFERRALS",!
GOTO DONE
+4 SET BMCCLIN=""
FOR
SET BMCCLIN=$ORDER(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN))
IF BMCCLIN=""!(BMCQUIT)
QUIT
DO PROVIDER
DONE ;
+1 KILL ^XTMP("BMCRR16",BMCJOB,BMCBTH)
+2 DO DONE^BMCRLP2
+3 QUIT
PROVIDER ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF BMCQUIT
QUIT
+2 WRITE !!,BMCCLIN
SET (BMCSTOT,BMCPRTOT,BMCSRTOT)=0
+3 SET BMCPROV=0
FOR
SET BMCPROV=$ORDER(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,BMCPROV))
IF BMCPROV=""!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO HEAD
IF BMCQUIT
QUIT
+5 WRITE !?20,BMCPROV,?50,$JUSTIFY(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,BMCPROV),5)
SET BMCSTOT=BMCSTOT+^(BMCPROV)
End DoDot:1
+6 ;IHS/OIT/FCJ
SET BMCSRTOT=$GET(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,0,"S"))
+7 ;IHS/OIT/FCJ
SET BMCPRTOT=$GET(^XTMP("BMCRR16",BMCJOB,BMCBTH,"CLIN",BMCCLIN,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 ",BMCCLIN,?50,$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 CLINIC",!
+4 WRITE ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)
+5 WRITE !!,"CLINIC REFERRED TO",?20,"PROVIDER REFERRED FROM",?50,"NUMBER"
+6 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+7 QUIT
