Routine: BMCRR3P

BMCRR3P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;     [ 09/27/2006  2:14 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101

 ;4.0*1 3.8.06 IHS/OIT/FCJ PRINT BEG AND END DT

START ;

 S BMC80E="==============================================================================="

 S BMC80D="-------------------------------------------------------------------------------"

 S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR3",BMCJOB,BMCBT)) W !,"No patientss to report",! G DONE

 S BMCPN=0 K BMCQUIT

 F  S BMCPN=$O(^XTMP("BMCRR3",BMCJOB,BMCBT,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT))  D DFN

DONE ;

 K ^XTMP("BMCRR3",BMCJOB,BMCBT)

 D DONE^BMCRLP2

DFN ;

 S DFN="" F  S DFN=$O(^XTMP("BMCRR3",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN)) Q:DFN=""!($D(BMCQUIT))  D PRINT

PRINT ;print one referral

 Q:$P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U,2)<BMCAMT

 I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)

 W !,$E(BMCPN,1,25)

 S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)

 W ?28,BMCHRN

 W ?40,$$FMTE^XLFDT($P(^DPT(DFN,0),U,3),"5D")

 W ?52,$P(^DPT(DFN,0),U,2)

 W ?56,$J($P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U),5)

 S X=$P(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U,2),X2="2$" D COMMA^%DTC W ?64,X

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 !?21,"******** PRIMARY REFERRALS *******"

 W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!

 W ?22,"HIGH COST USERS - "_$S(BMCCOST="I":"using IHS COST",1:"using TOTAL COST"),!

 ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT

 S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y

 S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!

0 W !,"PATIENT NAME",?28," HRN",?40,"DOB",?51,"SEX",?56,"# REFS",?64,"TOTAL COST"

 W !,BMC80D

BMCRR3P   ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;     [ 09/27/2006  2:14 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101

 +2       ;4.0*1 3.8.06 IHS/OIT/FCJ PRINT BEG AND END DT

START     ;

 +1        SET BMC80E="==============================================================================="

 +2        SET BMC80D="-------------------------------------------------------------------------------"

 +3        SET BMCPG=0

           DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))

           IF '$DATA(^XTMP("BMCRR3",BMCJOB,BMCBT))

               WRITE !,"No patientss to report",!

               GOTO DONE

 +4        SET BMCPN=0

           KILL BMCQUIT

 +5        FOR

               SET BMCPN=$ORDER(^XTMP("BMCRR3",BMCJOB,BMCBT,"DATA HITS",BMCPN))

               IF BMCPN=""!($DATA(BMCQUIT))

                   QUIT

               DO DFN

DONE      ;

 +1        KILL ^XTMP("BMCRR3",BMCJOB,BMCBT)

 +2        DO DONE^BMCRLP2

 +3        QUIT

DFN       ;

 +1        SET DFN=""

FOR

               SET DFN=$ORDER(^XTMP("BMCRR3",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN))

               IF DFN=""!($DATA(BMCQUIT))

                   QUIT

               DO PRINT

 +2        QUIT

PRINT     ;print one referral

 +1        IF $PIECE(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U,2)<BMCAMT

               QUIT

 +2        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT

 +3        WRITE !,$EXTRACT(BMCPN,1,25)

 +4        SET BMCHRN="????"

           IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))

               SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)

 +5        WRITE ?28,BMCHRN

 +6        WRITE ?40,$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3),"5D")

 +7        WRITE ?52,$PIECE(^DPT(DFN,0),U,2)

 +8        WRITE ?56,$JUSTIFY($PIECE(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U),5)

 +9        SET X=$PIECE(^XTMP("BMCRR3",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN),U,2)

           SET X2="2$"

           DO COMMA^%DTC

           WRITE ?64,X

 +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 !?21,"******** PRIMARY REFERRALS *******"

 +4        WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!

 +5        WRITE ?22,"HIGH COST USERS - "_$SELECT(BMCCOST="I":"using IHS COST",1:"using TOTAL COST"),!

 +6       ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT

 +7        SET Y=BMCBD

           DO DD^%DT

           WRITE ?17,"BEG DATE: "_Y

 +8        SET Y=BMCED

           DO DD^%DT

           WRITE ?40,"END DATE: "_Y,!

0          WRITE !,"PATIENT NAME",?28," HRN",?40,"DOB",?51,"SEX",?56,"# REFS",?64,"TOTAL COST"

 +1        WRITE !,BMC80D

 +2        QUIT

BMCRR3P.m