BMCRR4P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 09/27/2006 2:16 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
;4.0*1 3.7.06 IHS/OIT/FCJ MODIFIED TO PRT PROV IN ALPHA ORDER
START ;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-")))
I '$D(^XTMP("BMCRR4",BMCJOB,BMCBT)) W !,"No data to report",! G DONE
S BMCPN=0 K BMCQUIT
;4.0*1 3.7.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRT PROV IN ALPHA ORDR
I BMCTYPE="P" S BMCSORT=0 D
.F S BMCSORT=$O(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCSORT)) Q:BMCSORT=""!($D(BMCQUIT)) S BMCPN=0 D
..F S BMCPN=$O(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCSORT,BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) S BMCX=^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN) D PROC
E F S BMCPN=$O(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) S BMCX=^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN) D PROC
;4.0*1 3.7.06 IHS/OIT/FCJ END OF REWRITE
DONE ;
K ^XTMP("BMCRR4",BMCJOB,BMCBT)
D DONE^BMCRLP2
Q
PROC ;
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
S X=$S(BMCTYPE="P":$P(^VA(200,BMCPN,0),U),1:$P(^DIC(4,BMCPN,0),U))
W !,$E(X,1,20),?25,$J($P(BMCX,U),5)
W ?32,$J($P(BMCX,U,2),5)
W ?37,$J($P(BMCX,U,3),5)
W ?43,$J($P(BMCX,U,4),5)
S X=$S($D(^XTMP("BMCRR4",BMCJOB,BMCBT,"PCC VISITS",BMCPN)):^(BMCPN),1:0)
W ?50,$J(X,6)
I X W ?64,$J(($P(BMCX,U)/X)*100,5,0)
Q
HEAD ;ENTRY POINT
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
S BMCPG=BMCPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!!
W ?19,"REFERRAL PATTERNS BY REQUESTING ",$S(BMCTYPE="P":"PROVIDER",1:"FACILITY"),!
S Y=DT D DD^%DT W ?(80-$L(Y)/2),Y
S Y=BMCBD D DD^%DT W !,?28,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W !,?28,"END DATE: "_Y,!
W !,$S(BMCTYPE="P":"PROVIDER",1:"FACILITY"),?23,"# REFS",?33,"IHS",?38,"OTHER",?44,"CHS",?50,"# PCC",?59,"TOTAL REF RATE"
W !,?23,"INITIATED",?33,"REFS",?38,"REFS",?44,"REFS",?50,"VISITS",?59,"PER 100 PCC VISITS"
W !,BMC80D
Q
BMCRR4P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 09/27/2006 2:16 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
+2 ;4.0*1 3.7.06 IHS/OIT/FCJ MODIFIED TO PRT PROV IN ALPHA ORDER
START ;
+1 SET BMC80E="==============================================================================="
+2 SET BMC80D="-------------------------------------------------------------------------------"
+3 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+4 IF '$DATA(^XTMP("BMCRR4",BMCJOB,BMCBT))
WRITE !,"No data to report",!
GOTO DONE
+5 SET BMCPN=0
KILL BMCQUIT
+6 ;4.0*1 3.7.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRT PROV IN ALPHA ORDR
+7 IF BMCTYPE="P"
SET BMCSORT=0
Begin DoDot:1
+8 FOR
SET BMCSORT=$ORDER(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCSORT))
IF BMCSORT=""!($DATA(BMCQUIT))
QUIT
SET BMCPN=0
Begin DoDot:2
+9 FOR
SET BMCPN=$ORDER(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCSORT,BMCPN))
IF BMCPN=""!($DATA(BMCQUIT))
QUIT
SET BMCX=^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN)
DO PROC
End DoDot:2
End DoDot:1
+10 IF '$TEST
FOR
SET BMCPN=$ORDER(^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN))
IF BMCPN=""!($DATA(BMCQUIT))
QUIT
SET BMCX=^XTMP("BMCRR4",BMCJOB,BMCBT,"REFERRALS",BMCPN)
DO PROC
+11 ;4.0*1 3.7.06 IHS/OIT/FCJ END OF REWRITE
DONE ;
+1 KILL ^XTMP("BMCRR4",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 QUIT
PROC ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 SET X=$SELECT(BMCTYPE="P":$PIECE(^VA(200,BMCPN,0),U),1:$PIECE(^DIC(4,BMCPN,0),U))
+3 WRITE !,$EXTRACT(X,1,20),?25,$JUSTIFY($PIECE(BMCX,U),5)
+4 WRITE ?32,$JUSTIFY($PIECE(BMCX,U,2),5)
+5 WRITE ?37,$JUSTIFY($PIECE(BMCX,U,3),5)
+6 WRITE ?43,$JUSTIFY($PIECE(BMCX,U,4),5)
+7 SET X=$SELECT($DATA(^XTMP("BMCRR4",BMCJOB,BMCBT,"PCC VISITS",BMCPN)):^(BMCPN),1:0)
+8 WRITE ?50,$JUSTIFY(X,6)
+9 IF X
WRITE ?64,$JUSTIFY(($PIECE(BMCX,U)/X)*100,5,0)
+10 QUIT
HEAD ;ENTRY POINT
+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=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 SET BMCPG=BMCPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!!
+4 WRITE ?19,"REFERRAL PATTERNS BY REQUESTING ",$SELECT(BMCTYPE="P":"PROVIDER",1:"FACILITY"),!
+5 SET Y=DT
DO DD^%DT
WRITE ?(80-$LENGTH(Y)/2),Y
+6 SET Y=BMCBD
DO DD^%DT
WRITE !,?28,"BEG DATE: "_Y
+7 SET Y=BMCED
DO DD^%DT
WRITE !,?28,"END DATE: "_Y,!
+8 WRITE !,$SELECT(BMCTYPE="P":"PROVIDER",1:"FACILITY"),?23,"# REFS",?33,"IHS",?38,"OTHER",?44,"CHS",?50,"# PCC",?59,"TOTAL REF RATE"
+9 WRITE !,?23,"INITIATED",?33,"REFS",?38,"REFS",?44,"REFS",?50,"VISITS",?59,"PER 100 PCC VISITS"
+10 WRITE !,BMC80D
+11 QUIT
