BMCRR9P.m

BMCRR9P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;4.0;IHS/ITSC/FCJ ADDED SEC REF TO REPORT

START ;

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

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

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

 S BMCSORT="" K BMCQUIT

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

 G:$D(BMCQUIT) DONE

 I $Y>(IOSL-6) D HEAD G:$D(BMCQUIT) DONE

DONE ;

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

 D DONE^BMCRLP2

 Q

PRINT ;print one referral

 S BMCREF=0 F  S BMCREF=$O(^XTMP("BMCRR9",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT))  S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PRINT1

 Q

PRINT1 ;

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

 W !,$S(BMCSTYPE="B":$$AVDOS^BMCRLU(BMCREF,"C"),1:$$FMTE^XLFDT($P(BMCRREC,U),"5D"))

 W ?11,$P(BMCRREC,U,2)

 ;4.0;IHS/ITSC/FCJ ADDED SEC REF SUF TO REPORT

 W $P($G(^BMCREF(BMCREF,1)),U)

 W ?28,$E($P(^DPT(DFN,0),U),1,20)

 W ?49,$S($P(BMCRREC,U,6):$$VAL^XBDIQ1(200,$P(BMCRREC,U,6),1),1:"--")

 W ?54,$E($$VAL^XBDIQ1(90001,BMCREF,.04),1,3)

 S BMCFAC=$$FACREF^BMCRLU(BMCREF)

 I BMCFAC="" S BMCFAC="????"

 W ?59,$E(BMCFAC,1,20)

 I $$VAL^XBDIQ1(90001,BMCREF,.09)]"" W !?59,$E($$VAL^XBDIQ1(90001,BMCREF,.09),1,20)

 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,!

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

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

 S X="ACTIVE REFERRALS SORTED BY "_$S(BMCSTYPE="B":"BEGIN DATE OF SERVICE",1:"DATE INITIATED")

 W ?(80-$L(X))/2,X,!

 W !,?49,"REF"

 W !,$S(BMCSTYPE="B":"BEGIN DOS",1:"INITIATED"),?11,"REFERRAL #",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"

 W !,BMC80D

 Q

BMCRR9P   ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;   

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

 +2       ;4.0;IHS/ITSC/FCJ ADDED SEC REF TO REPORT

START     ;

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

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

 +3        SET BMCPG=0

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

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

               WRITE !,"No referrals to report",!

               GOTO DONE

 +4        SET BMCSORT=""

           KILL BMCQUIT

 +5        FOR 

               SET BMCSORT=$ORDER(^XTMP("BMCRR9",BMCJOB,BMCBT,"DATA HITS",BMCSORT))

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

                   QUIT 

               DO PRINT

 +6        IF $DATA(BMCQUIT)

               GOTO DONE

 +7        IF $Y>(IOSL-6)

               DO HEAD

               IF $DATA(BMCQUIT)

                   GOTO DONE

DONE      ;

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

 +2        DO DONE^BMCRLP2

 +3        QUIT 

PRINT     ;print one referral

 +1        SET BMCREF=0

           FOR 

               SET BMCREF=$ORDER(^XTMP("BMCRR9",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCREF))

               IF BMCREF'=+BMCREF!($DATA(BMCQUIT))

                   QUIT 

               SET BMCRREC=^BMCREF(BMCREF,0)

               SET DFN=$PIECE(BMCRREC,U,3)

               DO PRINT1

 +2        QUIT 

PRINT1    ;

 +1        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT 

 +2        WRITE !,$SELECT(BMCSTYPE="B":$$AVDOS^BMCRLU(BMCREF,"C"),1:$$FMTE^XLFDT($PIECE(BMCRREC,U),"5D"))

 +3        WRITE ?11,$PIECE(BMCRREC,U,2)

 +4       ;4.0;IHS/ITSC/FCJ ADDED SEC REF SUF TO REPORT

 +5        WRITE $PIECE($GET(^BMCREF(BMCREF,1)),U)

 +6        WRITE ?28,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20)

 +7        WRITE ?49,$SELECT($PIECE(BMCRREC,U,6):$$VAL^XBDIQ1(200,$PIECE(BMCRREC,U,6),1),1:"--")

 +8        WRITE ?54,$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.04),1,3)

 +9        SET BMCFAC=$$FACREF^BMCRLU(BMCREF)

 +10       IF BMCFAC=""

               SET BMCFAC="????"

 +11       WRITE ?59,$EXTRACT(BMCFAC,1,20)

 +12       IF $$VAL^XBDIQ1(90001,BMCREF,.09)]""

               WRITE !?59,$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,20)

 +13       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        SET Y=BMCBD

           DO DD^%DT

           WRITE ?31,"REFERRAL INITIATED",!,?17,"BEG DATE: "_Y

 +5        SET Y=BMCED

           DO DD^%DT

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

 +6        SET X="ACTIVE REFERRALS SORTED BY "_$SELECT(BMCSTYPE="B":"BEGIN DATE OF SERVICE",1:"DATE INITIATED")

 +7        WRITE ?(80-$LENGTH(X))/2,X,!

 +8        WRITE !,?49,"REF"

 +9        WRITE !,$SELECT(BMCSTYPE="B":"BEGIN DOS",1:"INITIATED"),?11,"REFERRAL #",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"

 +10       WRITE !,BMC80D

 +11       QUIT