- 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
