BMCRR7P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
START ;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR7",BMCJOB,BMCBT)) W !,"No referrals to report",! G DONE
S BMCSORT="" K BMCQUIT
F S BMCSORT=$O(^XTMP("BMCRR7",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("BMCRR7",BMCJOB,BMCBT)
D DONE^BMCRLP2
Q
PRINT ;print one referral
I $G(BMCSPAGE),BMCPG'=1 D HEAD Q:$D(BMCQUIT)
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR7",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 !,$$FMTE^XLFDT($P(BMCRREC,U),"5D")
W ?12,$E($P(^DPT(DFN,0),U),1,18)
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 ?32,BMCHRN
W ?43,$S($P(BMCRREC,U,6):$$VAL^XBDIQ1(200,$P(BMCRREC,U,6),1),1:"--")
S BMCFAC=$$FACREF^BMCRLU(BMCREF)
I BMCFAC="" S BMCFAC="????"
W ?49,$E(BMCFAC,1,16)
W ?67,$S($P($G(^BMCREF(BMCREF,11)),U,6)]"":$$FMTE^XLFDT($P($G(^BMCREF(BMCREF,11)),U,6),"2D")_" (A)",$P($G(^BMCREF(BMCREF,11)),U,5):$$FMTE^XLFDT($P($G(^BMCREF(BMCREF,11)),U,5),"2D")_" (E)",1:"")
W !?5,"# Visits:",?16,$P($G(^BMCREF(BMCREF,11)),U,11)
W ?20,"Type: ",$$VAL^XBDIQ1(90001,BMCREF,.04)
W ?50,"Case Manager: ",$E($$CASEMAN^BMCRLU(BMCREF),1,15)
W !,?5,"IHS Referring Physician: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
I $P($G(^BMCREF(BMCREF,12)),U)="" W ! Q
S BMCP=$$GET1^DIQ(90001,BMCREF,1201,"","BMCP")
S DIWL=1,DIWF="C66" S X=BMCP D ^DIWP
S (C,Z)=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(BMCQUIT)) S C=C+1 D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W !?6,^UTILITY($J,"W",DIWL,Z,0)
W !
K DIWL,DIWR,DIWF,Z,^UTILITY($J,"W")
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,!
W ?29,"OUTPATIENT REFERRAL LOG",!
W !,"REF DATE",?11,"PATIENT NAME",?32," HRN",?43,"PROV",?49,"FACILITY REF TO",?67," D.O.S."
W !,BMC80D
Q
BMCRR7P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
START ;
+1 SET BMC80E="==============================================================================="
+2 SET BMC80D="-------------------------------------------------------------------------------"
+3 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRR7",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
GOTO DONE
+4 SET BMCSORT=""
KILL BMCQUIT
+5 FOR
SET BMCSORT=$ORDER(^XTMP("BMCRR7",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("BMCRR7",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 QUIT
PRINT ;print one referral
+1 IF $GET(BMCSPAGE)
IF BMCPG'=1
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR7",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
+3 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 WRITE !,$$FMTE^XLFDT($PIECE(BMCRREC,U),"5D")
+3 WRITE ?12,$EXTRACT($PIECE(^DPT(DFN,0),U),1,18)
+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 ?32,BMCHRN
+6 WRITE ?43,$SELECT($PIECE(BMCRREC,U,6):$$VAL^XBDIQ1(200,$PIECE(BMCRREC,U,6),1),1:"--")
+7 SET BMCFAC=$$FACREF^BMCRLU(BMCREF)
+8 IF BMCFAC=""
SET BMCFAC="????"
+9 WRITE ?49,$EXTRACT(BMCFAC,1,16)
+10 WRITE ?67,$SELECT($PIECE($GET(^BMCREF(BMCREF,11)),U,6)]"":$$FMTE^XLFDT($PIECE($GET(^BMCREF(BMCREF,11)),U,6),"2D")_" (A)",$PIECE($GET(^BMCREF(BMCREF,11)),U,5):$$FMTE^XLFDT($PIECE($GET(^BMCREF(BMCREF,11)),U,5),"2D")_" (E)",1:"")
+11 WRITE !?5,"# Visits:",?16,$PIECE($GET(^BMCREF(BMCREF,11)),U,11)
+12 WRITE ?20,"Type: ",$$VAL^XBDIQ1(90001,BMCREF,.04)
+13 WRITE ?50,"Case Manager: ",$EXTRACT($$CASEMAN^BMCRLU(BMCREF),1,15)
+14 WRITE !,?5,"IHS Referring Physician: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
+15 IF $PIECE($GET(^BMCREF(BMCREF,12)),U)=""
WRITE !
QUIT
+16 SET BMCP=$$GET1^DIQ(90001,BMCREF,1201,"","BMCP")
+17 SET DIWL=1
SET DIWF="C66"
SET X=BMCP
DO ^DIWP
+18 SET (C,Z)=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(BMCQUIT))
QUIT
SET C=C+1
IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
WRITE !?6,^UTILITY($JOB,"W",DIWL,Z,0)
+19 WRITE !
+20 KILL DIWL,DIWR,DIWF,Z,^UTILITY($JOB,"W")
+21 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 WRITE ?29,"OUTPATIENT REFERRAL LOG",!
+5 WRITE !,"REF DATE",?11,"PATIENT NAME",?32," HRN",?43,"PROV",?49,"FACILITY REF TO",?67," D.O.S."
+6 WRITE !,BMC80D
+7 QUIT
