BMCRR13P ; IHS/PHXAO/TMJ - PRNT REFERRALS ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
START ;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
I '$D(^XTMP("BMCRR13",BMCJOB,BMCBT)) S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) W !,"No referrals to report",! G DONE
S BMCPG=0 I 'BMCSPAGE D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCPRV="" K BMCQUIT
F S BMCPRV=$O(^XTMP("BMCRR13",BMCJOB,BMCBT,"DATA HITS",BMCPRV)) Q:BMCPRV=""!($D(BMCQUIT)) D PRINT
G:$D(BMCQUIT) DONE
I $Y>(IOSL-6) D HEAD G:$D(BMCQUIT) DONE
DONE ;
K ^XTMP("BMCRR13",BMCJOB,BMCBT)
D DONE^BMCRLP2
Q
PRINT ;print one referral
I BMCSPAGE=1 D HEAD Q:$D(BMCQUIT)
I BMCSPAGE'=1 W !
W !,"REQUESTING PROVIDER: ",BMCPRV
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR13",BMCJOB,BMCBT,"DATA HITS",BMCPRV,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT)) S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PRINT1
Q
PRINT1 ;
S BMCFAC=$$FACREF^BMCRLU(BMCREF) S:BMCFAC="" BMCFAC="--"
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
W !,$$AVDOS^BMCRLU(BMCREF,"C")
W ?11,$P(BMCRREC,U,2)
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)
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 X="ACTIVE REFERRALS BY REQUESTING PROVIDER"
W ?(80-$L(X))/2,X,!
S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
W !,?49,"REF"
W !,"BEGIN DOS",?11,"REFERRAL #",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"
W !,BMC80D
Q
BMCRR13P ; IHS/PHXAO/TMJ - PRNT REFERRALS ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
START ;
+1 SET BMC80E="==============================================================================="
+2 SET BMC80D="-------------------------------------------------------------------------------"
+3 IF '$DATA(^XTMP("BMCRR13",BMCJOB,BMCBT))
SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
WRITE !,"No referrals to report",!
GOTO DONE
+4 SET BMCPG=0
IF 'BMCSPAGE
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+5 SET BMCPRV=""
KILL BMCQUIT
+6 FOR
SET BMCPRV=$ORDER(^XTMP("BMCRR13",BMCJOB,BMCBT,"DATA HITS",BMCPRV))
IF BMCPRV=""!($DATA(BMCQUIT))
QUIT
DO PRINT
+7 IF $DATA(BMCQUIT)
GOTO DONE
+8 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(BMCQUIT)
GOTO DONE
DONE ;
+1 KILL ^XTMP("BMCRR13",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 QUIT
PRINT ;print one referral
+1 IF BMCSPAGE=1
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 IF BMCSPAGE'=1
WRITE !
+3 WRITE !,"REQUESTING PROVIDER: ",BMCPRV
+4 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR13",BMCJOB,BMCBT,"DATA HITS",BMCPRV,BMCREF))
IF BMCREF'=+BMCREF!($DATA(BMCQUIT))
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
DO PRINT1
+5 QUIT
PRINT1 ;
+1 SET BMCFAC=$$FACREF^BMCRLU(BMCREF)
IF BMCFAC=""
SET BMCFAC="--"
+2 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+3 WRITE !,$$AVDOS^BMCRLU(BMCREF,"C")
+4 WRITE ?11,$PIECE(BMCRREC,U,2)
+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 WRITE ?59,$EXTRACT(BMCFAC,1,20)
+10 IF $$VAL^XBDIQ1(90001,BMCREF,.09)]""
WRITE !?59,$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,20)
+11 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 X="ACTIVE REFERRALS BY REQUESTING PROVIDER"
+5 WRITE ?(80-$LENGTH(X))/2,X,!
+6 SET Y=BMCBD
DO DD^%DT
WRITE ?17,"BEG DATE: "_Y
+7 SET Y=BMCED
DO DD^%DT
WRITE ?40,"END DATE: "_Y,!
+8 WRITE !,?49,"REF"
+9 WRITE !,"BEGIN DOS",?11,"REFERRAL #",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"
+10 WRITE !,BMC80D
+11 QUIT
