BMCRR17P ; IHS/PHXAO/TMJ - PRNT BILL VSTS;OUTLIER REPORT ;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ TEST FOR CASE COMMENT TYPE TO PRINT
;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;4.0*9 11.11.2012 IHS.OIT.FCJ CHG FOR ICD-10
;
START ;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR17",BMCJOB,BMCBT)) W !,"No referrals to report",! G DONE
S BMCSORT="" K BMCQUIT
F S BMCSORT=$O(^XTMP("BMCRR17",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
W !!!,"NOTE: ",BMCNOES," referrals were missing an estimated Length of Stay value",!,"and were not included on this report.",!
DONE ;
K ^XTMP("BMCRR17",BMCJOB,BMCBT)
D DONE^BMCRLP2
Q
PRINT ;print one referral
I $G(BMCSPAGE),BMCPG'=1 D HEAD Q:$D(BMCQUIT)
I $Y>(IOSL-10) D HEAD Q:$D(BMCQUIT)
W !!,$S(BMCSTYPE="F":"FACILITY REFERRED TO: ",BMCSTYPE="C":"CASE MANAGER: ",BMCSTYPE="P":"PATIENT NAME: ",1:"???: "),BMCSORT,!
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR17",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)
S BMCHRN="????" S BMCHRN=$$HRN^AUPNPAT(DFN,DUZ(2)) I BMCHRN="" S BMCHRN="????"
W !,BMCHRN
DX ;
I $D(^BMCDX("AD",BMCREF)) D I 1
.K BMCX S (C,X)=0
.S BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N") ;BMC*4.0*9
.;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.11.2012 IHS.OIT.FCJ CHG FOR ICD-10
.;F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCDX(X,0) S BMCX(C)=$E($P(^ICD9(BMCD,0),U,3),1,26)_U_$P(^ICD9(BMCD,0),U)
.;F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCDX(X,0) S BMCX(C)=$E($P($$ICDDX^ICDCODE(BMCD,0),U,4),1,26)_U_$P($$ICDDX^ICDCODE(BMCD,0),U,2)
.F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCDX(X,0) S BMCX(C)=$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,26)_U_$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)
E D
.S BMCX(1)=$E($$GET1^DIQ(90001,BMCREF,.12),1,26)_U
W ?9,$P(BMCX(1),U),?37,$P(BMCX(1),U,2)
W ?46,$$AVDOS^BMCRLU(BMCREF,"C")
W ?61,$$VAL^XBDIQ1(90001,BMCREF,.1499)
S O=($$VAL^XBDIQ1(90001,BMCREF,.1499)-$$VAL^XBDIQ1(90001,BMCREF,1109))
W ?72,O
S Z=1 F S Z=$O(BMCX(Z)) Q:Z'=+Z D Q:$D(BMCQUIT)
.I $Y>(IOSL-3) D HEAD Q:$D(BMCQUIT)
.W !?9,$P(BMCX(Z),U),?37,$P(BMCX(Z),U,2)
I $Y>(IOSL-3) D HEAD Q:$D(BMCQUIT)
W !,"Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201),!
W !?9,"REVIEWED",?20,"BY ",?26,"CASE REVIEW COMMENTS",?52,"3RD PARTY: "
S O="",O=$S($$MCR^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"MCR",1:O)
S O=$S($$MCD^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"MCD",1:0)
S O=$S($$PI^AUPNPAT(DFN,$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"PRVT",1:O)
W ?64,O,?70,"ELIG: ",$$VALI^XBDIQ1(9000001,DFN,1112),!
W ?9,"-------- --- --- -------------------"
I '$D(^BMCCOM("AD",BMCREF)) W !?26,"<No comments on file.>",! Q
S BMCI=0 F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT)) D
.Q:$P(^BMCCOM(BMCI,0),U,5)'="C"
.S Y=$P(^BMCCOM(BMCI,0),U) W !?9,$$FMTE^XLFDT(Y,"5D")
.S Y=$P(^BMCCOM(BMCI,0),U,4),Y=$P(^VA(200,Y,0),U,2) W ?20,Y
.S BMCG="^BMCCOM("_BMCI_",1,BMCX)" D WP
.S Z=0 F S Z=$O(BMCSTR(Z)) Q:Z'=+Z D Q:$D(BMCQUIT)
..I $Y>(IOSL-3) D HEAD Q:$D(BMCQUIT)
..W:Z>1 ! W ?26,BMCSTR(Z)
Q
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
Q
WP ;EP - Entry point to print wp fields pass node in BMCNODE
;PASS FILE IN BMCFILE, ENTRY IN BMCREF
K ^UTILITY($J,"W")
S BMCX=0
I '$D(BMCG) S BMCG=^DIC(BMCFILE,0,"GL"),BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
S DIWL=1,DIWR=52,DIWF="C52" F S BMCX=$O(@BMCG) Q:BMCX'=+BMCX!($D(BMCQUIT)) D
.S Y=$P(BMCG,")")_",0)" S X=@Y D ^DIWP
.Q
WPS ;EP
K BMCSTR S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(BMCQUIT)) S BMCSTR(Z)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
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 ?33,"OUTLIER REPORT"
W !,"HRCN",?9,"DX CATEGORY/DX",?36,"ICD-9CM",?45,"ADM DATE",?57,"ACTUAL LOS",?71,"OUTLIER"
W !,BMC80D
Q
BMCRR17P ; IHS/PHXAO/TMJ - PRNT BILL VSTS;OUTLIER REPORT ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ TEST FOR CASE COMMENT TYPE TO PRINT
+3 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+4 ;4.0*9 11.11.2012 IHS.OIT.FCJ CHG FOR ICD-10
+5 ;
START ;
+1 SET BMC80E="==============================================================================="
+2 SET BMC80D="-------------------------------------------------------------------------------"
+3 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRR17",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
GOTO DONE
+4 SET BMCSORT=""
KILL BMCQUIT
+5 FOR
SET BMCSORT=$ORDER(^XTMP("BMCRR17",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
+8 WRITE !!!,"NOTE: ",BMCNOES," referrals were missing an estimated Length of Stay value",!,"and were not included on this report.",!
DONE ;
+1 KILL ^XTMP("BMCRR17",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 IF $Y>(IOSL-10)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+3 WRITE !!,$SELECT(BMCSTYPE="F":"FACILITY REFERRED TO: ",BMCSTYPE="C":"CASE MANAGER: ",BMCSTYPE="P":"PATIENT NAME: ",1:"???: "),BMCSORT,!
+4 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR17",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
+5 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 SET BMCHRN="????"
SET BMCHRN=$$HRN^AUPNPAT(DFN,DUZ(2))
IF BMCHRN=""
SET BMCHRN="????"
+3 WRITE !,BMCHRN
DX ;
+1 IF $DATA(^BMCDX("AD",BMCREF))
Begin DoDot:1
+2 KILL BMCX
SET (C,X)=0
+3 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+4 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES;4.0*9 11.11.2012 IHS.OIT.FCJ CHG FOR ICD-10
+5 ;F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCDX(X,0) S BMCX(C)=$E($P(^ICD9(BMCD,0),U,3),1,26)_U_$P(^ICD9(BMCD,0),U)
+6 ;F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCDX(X,0) S BMCX(C)=$E($P($$ICDDX^ICDCODE(BMCD,0),U,4),1,26)_U_$P($$ICDDX^ICDCODE(BMCD,0),U,2)
+7 FOR
SET X=$ORDER(^BMCDX("AD",BMCREF,X))
IF X'=+X!($DATA(BMCQUIT))
QUIT
SET C=C+1
SET BMCD=+^BMCDX(X,0)
SET BMCX(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,26)_U_$PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)
End DoDot:1
IF 1
+8 IF '$TEST
Begin DoDot:1
+9 SET BMCX(1)=$EXTRACT($$GET1^DIQ(90001,BMCREF,.12),1,26)_U
End DoDot:1
+10 WRITE ?9,$PIECE(BMCX(1),U),?37,$PIECE(BMCX(1),U,2)
+11 WRITE ?46,$$AVDOS^BMCRLU(BMCREF,"C")
+12 WRITE ?61,$$VAL^XBDIQ1(90001,BMCREF,.1499)
+13 SET O=($$VAL^XBDIQ1(90001,BMCREF,.1499)-$$VAL^XBDIQ1(90001,BMCREF,1109))
+14 WRITE ?72,O
+15 SET Z=1
FOR
SET Z=$ORDER(BMCX(Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+17 WRITE !?9,$PIECE(BMCX(Z),U),?37,$PIECE(BMCX(Z),U,2)
End DoDot:1
IF $DATA(BMCQUIT)
QUIT
+18 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+19 WRITE !,"Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201),!
+20 WRITE !?9,"REVIEWED",?20,"BY ",?26,"CASE REVIEW COMMENTS",?52,"3RD PARTY: "
+21 SET O=""
SET O=$SELECT($$MCR^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"MCR",1:O)
+22 SET O=$SELECT($$MCD^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"MCD",1:0)
+23 SET O=$SELECT($$PI^AUPNPAT(DFN,$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT)):"PRVT",1:O)
+24 WRITE ?64,O,?70,"ELIG: ",$$VALI^XBDIQ1(9000001,DFN,1112),!
+25 WRITE ?9,"-------- --- --- -------------------"
+1 IF '$DATA(^BMCCOM("AD",BMCREF))
WRITE !?26,"<No comments on file.>",!
QUIT
+2 SET BMCI=0
FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'=+BMCI!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCI,0),U,5)'="C"
QUIT
+4 SET Y=$PIECE(^BMCCOM(BMCI,0),U)
WRITE !?9,$$FMTE^XLFDT(Y,"5D")
+5 SET Y=$PIECE(^BMCCOM(BMCI,0),U,4)
SET Y=$PIECE(^VA(200,Y,0),U,2)
WRITE ?20,Y
+6 SET BMCG="^BMCCOM("_BMCI_",1,BMCX)"
DO WP
+7 SET Z=0
FOR
SET Z=$ORDER(BMCSTR(Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+8 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+9 IF Z>1
WRITE !
WRITE ?26,BMCSTR(Z)
End DoDot:2
IF $DATA(BMCQUIT)
QUIT
End DoDot:1
+10 QUIT
+11 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+12 QUIT
WP ;EP - Entry point to print wp fields pass node in BMCNODE
+1 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
+2 KILL ^UTILITY($JOB,"W")
+3 SET BMCX=0
+4 IF '$DATA(BMCG)
SET BMCG=^DIC(BMCFILE,0,"GL")
SET BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
+5 SET DIWL=1
SET DIWR=52
SET DIWF="C52"
FOR
SET BMCX=$ORDER(@BMCG)
IF BMCX'=+BMCX!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+6 SET Y=$PIECE(BMCG,")")_",0)"
SET X=@Y
DO ^DIWP
+7 QUIT
End DoDot:1
WPS ;EP
+1 KILL BMCSTR
SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(BMCQUIT))
QUIT
SET BMCSTR(Z)=^UTILITY($JOB,"W",DIWL,Z,0)
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
+4 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 ?33,"OUTLIER REPORT"
+5 WRITE !,"HRCN",?9,"DX CATEGORY/DX",?36,"ICD-9CM",?45,"ADM DATE",?57,"ACTUAL LOS",?71,"OUTLIER"
+6 WRITE !,BMC80D
+7 QUIT
