- BMCRR6P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
- ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- START ;
- S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR6",BMCJOB,BMCBT)) W !,"No referrals to report",! G DONE
- S BMCF=0 K BMCQUIT
- F S BMCF=$O(^XTMP("BMCRR6",BMCJOB,BMCBT,"REFERRALS",BMCF)) Q:BMCF=""!($D(BMCQUIT)) D PRINT
- G:$D(BMCQUIT) DONE
- I $Y>(IOSL-6) D HEAD G:$D(BMCQUIT) DONE
- DONE ;
- K ^XTMP("BMCRR6",BMCJOB,BMCBT)
- D DONE^BMCRLP2
- Q
- PRINT ;print one referral
- I $Y>(IOSL-9) D HEAD Q:$D(BMCQUIT)
- W !,$E(BMCF,1,23) S T=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U) W ?25,$J(T,5) S %=$P(^(BMCF),U,2) W ?32,$J(%,5) F X=3:1:6 D
- .S J=38+(11*(X-3)),K=J+6
- .S Z=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,X)
- .S Y=(Z/T)*100
- .W ?J,$J(Z,5),?K,$J(Y,3,0)
- .Q
- Q
- HEAD ;ENTRY POINT
- W !!,"* any referral with an ending service date of less than 31 days ago is excluded.",!
- 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 !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
- W ?20,"TIMELINESS OF RECEIPT OF DISCHARGE LETTERS",!?30,"BY REFERRAL FACILITY"
- W !?10,"REFERRAL INITIATED DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED),!
- W !,"* any referral with an ending service date of less than 31 days ago is excluded.",!
- W !,?26,"TOTAL",?33,"NOT YET",?48,"RECEIVED WITH (#MONTHS)"
- W !,"REFERRAL FACILITY",?26,"REFS",?32,"RECD*",?43,"<1",?53,"1-3",?64,"4-6",?75,">6"
- W !?28,"N",?35,"N",?41,"N %",?52,"N %",?63,"N %",?74,"N %"
- W !,$TR($J(" ",80)," ","-")
- Q
- BMCRR6P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- START ;
- +1 SET BMCPG=0
- DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
- IF '$DATA(^XTMP("BMCRR6",BMCJOB,BMCBT))
- WRITE !,"No referrals to report",!
- GOTO DONE
- +2 SET BMCF=0
- KILL BMCQUIT
- +3 FOR
- SET BMCF=$ORDER(^XTMP("BMCRR6",BMCJOB,BMCBT,"REFERRALS",BMCF))
- IF BMCF=""!($DATA(BMCQUIT))
- QUIT
- DO PRINT
- +4 IF $DATA(BMCQUIT)
- GOTO DONE
- +5 IF $Y>(IOSL-6)
- DO HEAD
- IF $DATA(BMCQUIT)
- GOTO DONE
- DONE ;
- +1 KILL ^XTMP("BMCRR6",BMCJOB,BMCBT)
- +2 DO DONE^BMCRLP2
- +3 QUIT
- PRINT ;print one referral
- +1 IF $Y>(IOSL-9)
- DO HEAD
- IF $DATA(BMCQUIT)
- QUIT
- +2 WRITE !,$EXTRACT(BMCF,1,23)
- SET T=$PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U)
- WRITE ?25,$JUSTIFY(T,5)
- SET %=$PIECE(^(BMCF),U,2)
- WRITE ?32,$JUSTIFY(%,5)
- FOR X=3:1:6
- Begin DoDot:1
- +3 SET J=38+(11*(X-3))
- SET K=J+6
- +4 SET Z=$PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,X)
- +5 SET Y=(Z/T)*100
- +6 WRITE ?J,$JUSTIFY(Z,5),?K,$JUSTIFY(Y,3,0)
- +7 QUIT
- End DoDot:1
- +8 QUIT
- HEAD ;ENTRY POINT
- +1 WRITE !!,"* any referral with an ending service date of less than 31 days ago is excluded.",!
- +2 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 !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
- +3 WRITE ?20,"TIMELINESS OF RECEIPT OF DISCHARGE LETTERS",!?30,"BY REFERRAL FACILITY"
- +4 WRITE !?10,"REFERRAL INITIATED DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED),!
- +5 WRITE !,"* any referral with an ending service date of less than 31 days ago is excluded.",!
- +6 WRITE !,?26,"TOTAL",?33,"NOT YET",?48,"RECEIVED WITH (#MONTHS)"
- +7 WRITE !,"REFERRAL FACILITY",?26,"REFS",?32,"RECD*",?43,"<1",?53,"1-3",?64,"4-6",?75,">6"
- +8 WRITE !?28,"N",?35,"N",?41,"N %",?52,"N %",?63,"N %",?74,"N %"
- +9 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
- +10 QUIT
