BMCRR18P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 09/27/2006 2:05 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
;;IHS/ITSC/FCJ PRT DISCHARGE COMMENTS FR RCIS COMMENTS FILE AND SEC SUF
;4.0*1 3.8.06 IHS/OIT/FCJ ADDED BEG AND END DT TO REPORT HEADER
;
;Go to SUMPRINT Line Tag if User Selects Summary Print
;I BMCOUTP="S" D SUMPRINT Q
;
;
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR18",BMCJOB,BMCBT)) W !,"No referrals to report",! G XIT
S BMCPN=0,BMCQUIT=0
S BMCDATE="" F S BMCDATE=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE)) Q:BMCDATE=""!(BMCQUIT) D P
XIT ;
K ^XTMP("BMCRR18",BMCJOB,BMCBT)
D DONE^BMCRLP2
D KILL^AUPNPAT
K BMCDATE,BMCI
Q
P ;
S BMCPN="" F S BMCPN=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN)) Q:BMCPN=""!(BMCQUIT) D PRINT
Q
PRINT ;print one referral
I $Y>(IOSL-10) D HEAD Q:BMCQUIT
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCREF)) Q:BMCREF'=+BMCREF!(BMCQUIT) S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D
.D:BMCOUTP="D" PRINT1,HEAD
.D:BMCOUTP="S" SUMPRINT
Q
PRINT1 ;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
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 !!,$E($P(^DPT(DFN,0),U),1,20),?22,BMCHRN,?28,$$AGE^AUPNPAT(DFN,DT,"R")
S BMCRNUMB=$P($G(^BMCREF(BMCREF,0)),U,2)
W ?35,BMCRNUMB,$P($G(^BMCREF(BMCREF,1)),U)
W ?53,$E($$COMMRES^AUPNPAT(DFN,"E"),1,10)
W ?65,$E($$FACREF^BMCRLU(BMCREF),1,15)
W !,$E($P($G(^BMCREF(BMCREF,12)),U,1),1,19)
W ?27,"Admit Dt: ",$$AVDOS^BMCRLU(BMCREF,"C"),"-","Disch Dt: ",$$AVEOS^BMCRLU(BMCREF,"S")," LOS: ",$$AVLOS^BMCRLU(BMCREF,"C")
;
CASECOM ;
W !
Q:'$D(^BMCCOM("AD",BMCREF))
S BMCI=0 F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!(BMCQUIT) D
.Q:$P(^BMCCOM(BMCI,0),U,5)'="C"
.W !,"Case Review Comments: "_$$FMTE^XLFDT($P(^BMCCOM(BMCI,0),U),"5D")
.W ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
.D COMMENTS
DISCOM ;
I '$D(^BMCCOM("AD",BMCREF)) Q
S BMCI=0
F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!(BMCQUIT) D
.Q:$P(^BMCCOM(BMCI,0),U,5)'="D"
.W !,"Discharge Comments: "_$$FMTE^XLFDT($P(^BMCCOM(BMCI,0),U),"5D")
.W ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
.D COMMENTS
Q
S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCI D WP^BMCFDR K BMCIOM
S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W ?10,BMCWP(Y),!
Q
HEAD ;ENTRY POINT
NEW X,Y,Z,C
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 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 ?21,"**AREA HOSPITAL DISCHARGES BY DATE**"
;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 !,?28,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W !,?28,"END DATE: "_Y,!
;
I BMCOUTP="D" W !!,"Pt Name/Purpose",?22,"Rec #",?29,"Age",?36,"Referral #",?52,"Community",?65,"Fac. Ref To"
;
I BMCOUTP="S" W !!,"Pt Name/Purpose",?22,"Rec #",?32,"Age",?39,"Referral #",?52,"Community",?65,"Fac. Ref To",?82,"Purpose of Referral",?104,"Beginning ",?116,"Ending ",?126,"Los"
I BMCOUTP="D" W !,$TR($J(" ",80)," ","-")
I BMCOUTP="S" W !,$TR($J(" ",132)," ","-")
Q
;
SUMPRINT ;Entry Point Down to Print Report Summary Selection
;
;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
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 !,$E($P(^DPT(DFN,0),U),1,20),?22,BMCHRN,?31,$$AGE^AUPNPAT(DFN,DT,"R")
W ?38,$P($G(^BMCREF(BMCREF,0)),U,2)
W ?53,$E($$COMMRES^AUPNPAT(DFN,"E"),1,10)
W ?65,$E($$FACREF^BMCRLU(BMCREF),1,15)
W ?82,$E($P($G(^BMCREF(BMCREF,12)),U,1),1,20)
W ?104,$$AVDOS^BMCRLU(BMCREF,"C"),?117,$$AVEOS^BMCRLU(BMCREF,"S"),?126,$$AVLOS^BMCRLU(BMCREF,"C")
Q
;
BMCRR18P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 09/27/2006 2:05 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
+2 ;;IHS/ITSC/FCJ PRT DISCHARGE COMMENTS FR RCIS COMMENTS FILE AND SEC SUF
+3 ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED BEG AND END DT TO REPORT HEADER
+4 ;
+5 ;Go to SUMPRINT Line Tag if User Selects Summary Print
+6 ;I BMCOUTP="S" D SUMPRINT Q
+7 ;
+8 ;
+9 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRR18",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
GOTO XIT
+10 SET BMCPN=0
SET BMCQUIT=0
+11 SET BMCDATE=""
FOR
SET BMCDATE=$ORDER(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE))
IF BMCDATE=""!(BMCQUIT)
QUIT
DO P
XIT ;
+1 KILL ^XTMP("BMCRR18",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 DO KILL^AUPNPAT
+4 KILL BMCDATE,BMCI
+5 QUIT
P ;
+1 SET BMCPN=""
FOR
SET BMCPN=$ORDER(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN))
IF BMCPN=""!(BMCQUIT)
QUIT
DO PRINT
+2 QUIT
PRINT ;print one referral
+1 IF $Y>(IOSL-10)
DO HEAD
IF BMCQUIT
QUIT
+2 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCREF))
IF BMCREF'=+BMCREF!(BMCQUIT)
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
Begin DoDot:1
+3 IF BMCOUTP="D"
DO PRINT1
DO HEAD
+4 IF BMCOUTP="S"
DO SUMPRINT
End DoDot:1
+5 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 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)
+3 WRITE !!,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,BMCHRN,?28,$$AGE^AUPNPAT(DFN,DT,"R")
+4 SET BMCRNUMB=$PIECE($GET(^BMCREF(BMCREF,0)),U,2)
+5 WRITE ?35,BMCRNUMB,$PIECE($GET(^BMCREF(BMCREF,1)),U)
+6 WRITE ?53,$EXTRACT($$COMMRES^AUPNPAT(DFN,"E"),1,10)
+7 WRITE ?65,$EXTRACT($$FACREF^BMCRLU(BMCREF),1,15)
+8 WRITE !,$EXTRACT($PIECE($GET(^BMCREF(BMCREF,12)),U,1),1,19)
+9 WRITE ?27,"Admit Dt: ",$$AVDOS^BMCRLU(BMCREF,"C"),"-","Disch Dt: ",$$AVEOS^BMCRLU(BMCREF,"S")," LOS: ",$$AVLOS^BMCRLU(BMCREF,"C")
+10 ;
CASECOM ;
+1 WRITE !
+2 IF '$DATA(^BMCCOM("AD",BMCREF))
QUIT
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'=+BMCI!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $PIECE(^BMCCOM(BMCI,0),U,5)'="C"
QUIT
+5 WRITE !,"Case Review Comments: "_$$FMTE^XLFDT($PIECE(^BMCCOM(BMCI,0),U),"5D")
+6 WRITE ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
+7 DO COMMENTS
End DoDot:1
DISCOM ;
+1 IF '$DATA(^BMCCOM("AD",BMCREF))
QUIT
+2 SET BMCI=0
+3 FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'=+BMCI!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $PIECE(^BMCCOM(BMCI,0),U,5)'="D"
QUIT
+5 WRITE !,"Discharge Comments: "_$$FMTE^XLFDT($PIECE(^BMCCOM(BMCI,0),U),"5D")
+6 WRITE ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
+7 DO COMMENTS
End DoDot:1
+8 QUIT
+1 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCI
DO WP^BMCFDR
KILL BMCIOM
+2 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+4 WRITE ?10,BMCWP(Y),!
End DoDot:1
+5 QUIT
HEAD ;ENTRY POINT
+1 NEW X,Y,Z,C
+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=1
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 ?21,"**AREA HOSPITAL DISCHARGES BY DATE**"
+5 ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT
+6 SET Y=BMCBD
DO DD^%DT
WRITE !,?28,"BEG DATE: "_Y
+7 SET Y=BMCED
DO DD^%DT
WRITE !,?28,"END DATE: "_Y,!
+8 ;
+9 IF BMCOUTP="D"
WRITE !!,"Pt Name/Purpose",?22,"Rec #",?29,"Age",?36,"Referral #",?52,"Community",?65,"Fac. Ref To"
+10 ;
+11 IF BMCOUTP="S"
WRITE !!,"Pt Name/Purpose",?22,"Rec #",?32,"Age",?39,"Referral #",?52,"Community",?65,"Fac. Ref To",?82,"Purpose of Referral",?104,"Beginning ",?116,"Ending ",?126,"Los"
+12 IF BMCOUTP="D"
WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+13 IF BMCOUTP="S"
WRITE !,$TRANSLATE($JUSTIFY(" ",132)," ","-")
+14 QUIT
+15 ;
SUMPRINT ;Entry Point Down to Print Report Summary Selection
+1 ;
+2 ;
+3 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+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 !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,BMCHRN,?31,$$AGE^AUPNPAT(DFN,DT,"R")
+6 WRITE ?38,$PIECE($GET(^BMCREF(BMCREF,0)),U,2)
+7 WRITE ?53,$EXTRACT($$COMMRES^AUPNPAT(DFN,"E"),1,10)
+8 WRITE ?65,$EXTRACT($$FACREF^BMCRLU(BMCREF),1,15)
+9 WRITE ?82,$EXTRACT($PIECE($GET(^BMCREF(BMCREF,12)),U,1),1,20)
+10 WRITE ?104,$$AVDOS^BMCRLU(BMCREF,"C"),?117,$$AVEOS^BMCRLU(BMCREF,"S"),?126,$$AVLOS^BMCRLU(BMCREF,"C")
+11 QUIT
+12 ;
