BMCRR6P.m

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