BMCRR8P ; IHS/PHXAO/TMJ - PRNT BILL VSTS;POT HIGH COST CASES ; [ 09/27/2006 2:16 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,3,9**;JAN 09, 2006;Build 101
;4.0*1 3.24.06 IHS/OIT/FCJ PRINT BEG AND END DT
;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("BMCRR8",BMCJOB,BMCBTH)) W !,"No referrals to report",! G DONE
S BMCPN="" K BMCQUIT
F S BMCPN=$O(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) D DFN
G:$D(BMCQUIT) DONE
I $Y>(IOSL-6) D HEAD G:$D(BMCQUIT) DONE
DONE ;
K ^XTMP("BMCRR8",BMCJOB,BMCBTH)
D DONE^BMCRLP2
Q
DFN ;
S DFN="" F S DFN=$O(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN)) Q:DFN=""!($D(BMCQUIT)) D PRINT
Q
PRINT ;print one referral
S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT)) S BMCRREC=^BMCREF(BMCREF,0) D PRINT1
Q
PRINT1 ;
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
W !,$$AVDOS^BMCRLU(BMCREF,"C")
W ?13,$$VALI^XBDIQ1(90001,BMCREF,.15)
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 ?17,BMCHRN
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)
S BMCFAC=$$FACREF^BMCRLU(BMCREF)
I BMCFAC="" S BMCFAC="????"
W ?59,$E(BMCFAC,1,20)
I $$VAL^XBDIQ1(90001,BMCREF,.09)]"" W !?59,$E($$VAL^XBDIQ1(90001,BMCREF,.09),1,20)
PURPOSE ;
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
K BMCP W !,"Purpose:"
S BMCP=$$GET1^DIQ(90001,BMCREF,1,"","BMCP")
S DIWL=1,DIWF="C66",BMCX=0 F S BMCX=$O(BMCP(BMCX)) Q:BMCX'=+BMCX!($D(BMCQUIT)) D
.S X=BMCP(BMCX) 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:C'=1 ! W ?12,^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z,^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
DX ;
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
I $D(^BMCDX("AD",BMCREF)) D I 1
.W !,"Dx:"
.S BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N") ;BMC*4.0*9
.S (C,X)=0 F S X=$O(^BMCDX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) D
..;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
..;S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P(^ICD9(BMCD,0),U),?19," - ",$E($P(^ICD9(BMCD,0),U,3),1,50)
..;S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P($$ICDDX^ICDCODE(BMCD,0),U,2),?19," - ",$E($P($$ICDDX^ICDCODE(BMCD,0),U,4),1,50)
..S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2),?19," - ",$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50)
E D
.W !,"Dx Cat:",?12,$$GET1^DIQ(90001,BMCREF,.12)
PROC ;
I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)
I $D(^BMCPX("AD",BMCREF)) D I 1
.W !,"Proc:"
.S (C,X)=0
.;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
.;F S X=$O(^BMCPX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCPX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P(^ICPT(BMCD,0),U),?19," - ",$E($P(^ICPT(BMCD,0),U,2),1,50)
.F S X=$O(^BMCPX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCPX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P($$CPT^ICPTCOD(BMCD,0),U,2),?19," - ",$E($P($$CPT^ICPTCOD(BMCD,0),U,3),1,50)
E D
.W !,"Srv Cat:",?12,$$GET1^DIQ(90001,BMCREF,.13)
;
THIRD ;Third Party Coverage
;W !
Q:'$G(DFN)
S BMCRDATE=DT
NEW BMCMSG,BMCI,BMCX
S BMCI=1
S BMCX=$$BEN^AUPNPAT(DFN,"E")
S:BMCX="" BMCX="UNKNOWN"
S BMCMSG(BMCI)="CLASSIFICATION/BENEFICIARY IS: "_BMCX,BMCI=+BMCI+1
S BMCX=$$ELIGSTAT^AUPNPAT(DFN,"E")
S:BMCX="" BMCX="UNKNOWN"
S BMCMSG(BMCI)="ELIGIBILITY STATUS IS: "_BMCX,BMCI=+BMCI+1
NEW BMCELG
S BMCELG=BMCI
I $$MCR^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICARE",BMCI=BMCI+1
;I $$MCD^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID--",BMCI=BMCI+1
S BMCX=$$MCDPN^AUPNPAT(DFN,BMCRDATE,"E")
S:BMCX="" BMCX="UNKNOWN"
I $$MCD^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX,BMCI=+BMCI+1
;I $$PI^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS PRIVATE INSURANCE--",BMCI=BMCI+1
S BMCX=$$PIN^AUPNPAT(DFN,BMCRDATE,"E")
S:BMCX="" BMCX="UNKNOWN"
I $$PI^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS INSURANCE-INSURER: "_BMCX,BMCI=BMCI+1
I BMCELG=BMCI S BMCMSG(BMCI)="NO THIRD PARTY COVERAGE RECORDED",BMCI=BMCI+1
I $D(^AUPNPAT(DFN,13)) D
.S BMCMSG(BMCI)="",BMCI=BMCI+1,BMCMSG(BMCI)="ADDITIONAL REGISTRATION INFORMATION:",BMCI=BMCI+1
.K BMCAR D ENP^XBDIQ1(9000001,DFN,1301,"BMCAR(","E")
.S I=0 F S I=$O(BMCAR(1301,I)) Q:I'=+I S BMCMSG(BMCI)=BMCAR(1301,I),BMCI=BMCI+1
W:BMCI !!
S BMCI=0
F S BMCI=$O(BMCMSG(BMCI)) Q:'BMCI W BMCMSG(BMCI),!
;
W !,"--------------------",!
Q
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,!
;4.0*1 3.24.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT
S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
S X="POTENTIAL HIGH COST CASES - BASED ON DIAGNOSIS"
W ?(80-$L(X))/2,X,!
W !,?49,"REF"
W !,"BEGIN D.O.S.",?13,"ST",?17,"HRN",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"
W !,BMC80D
Q
BMCRR8P ; IHS/PHXAO/TMJ - PRNT BILL VSTS;POT HIGH COST CASES ; [ 09/27/2006 2:16 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,3,9**;JAN 09, 2006;Build 101
+2 ;4.0*1 3.24.06 IHS/OIT/FCJ PRINT BEG AND END DT
+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("BMCRR8",BMCJOB,BMCBTH))
WRITE !,"No referrals to report",!
GOTO DONE
+4 SET BMCPN=""
KILL BMCQUIT
+5 FOR
SET BMCPN=$ORDER(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN))
IF BMCPN=""!($DATA(BMCQUIT))
QUIT
DO DFN
+6 IF $DATA(BMCQUIT)
GOTO DONE
+7 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(BMCQUIT)
GOTO DONE
DONE ;
+1 KILL ^XTMP("BMCRR8",BMCJOB,BMCBTH)
+2 DO DONE^BMCRLP2
+3 QUIT
DFN ;
+1 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN))
IF DFN=""!($DATA(BMCQUIT))
QUIT
DO PRINT
+2 QUIT
PRINT ;print one referral
+1 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR8",BMCJOB,BMCBTH,"DATA HITS",BMCPN,DFN,BMCREF))
IF BMCREF'=+BMCREF!($DATA(BMCQUIT))
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
DO PRINT1
+2 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 WRITE !,$$AVDOS^BMCRLU(BMCREF,"C")
+3 WRITE ?13,$$VALI^XBDIQ1(90001,BMCREF,.15)
+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 ?17,BMCHRN
+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 SET BMCFAC=$$FACREF^BMCRLU(BMCREF)
+10 IF BMCFAC=""
SET BMCFAC="????"
+11 WRITE ?59,$EXTRACT(BMCFAC,1,20)
+12 IF $$VAL^XBDIQ1(90001,BMCREF,.09)]""
WRITE !?59,$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,20)
PURPOSE ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 KILL BMCP
WRITE !,"Purpose:"
+3 SET BMCP=$$GET1^DIQ(90001,BMCREF,1,"","BMCP")
+4 SET DIWL=1
SET DIWF="C66"
SET BMCX=0
FOR
SET BMCX=$ORDER(BMCP(BMCX))
IF BMCX'=+BMCX!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+5 SET X=BMCP(BMCX)
DO ^DIWP
End DoDot:1
+6 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
IF C'=1
WRITE !
WRITE ?12,^UTILITY($JOB,"W",DIWL,Z,0)
+7 KILL DIWL,DIWR,DIWF,Z,^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
DX ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 IF $DATA(^BMCDX("AD",BMCREF))
Begin DoDot:1
+3 WRITE !,"Dx:"
+4 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+5 SET (C,X)=0
FOR
SET X=$ORDER(^BMCDX("AD",BMCREF,X))
IF X'=+X!($DATA(BMCQUIT))
QUIT
Begin DoDot:2
+6 ;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
+7 ;S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P(^ICD9(BMCD,0),U),?19," - ",$E($P(^ICD9(BMCD,0),U,3),1,50)
+8 ;S C=C+1,BMCD=+^BMCDX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P($$ICDDX^ICDCODE(BMCD,0),U,2),?19," - ",$E($P($$ICDDX^ICDCODE(BMCD,0),U,4),1,50)
+9 SET C=C+1
SET BMCD=+^BMCDX(X,0)
IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
IF C'=1
WRITE !
WRITE ?12,$PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2),?19," - ",$EXTRACT($PIECE($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50)
End DoDot:2
End DoDot:1
IF 1
+10 IF '$TEST
Begin DoDot:1
+11 WRITE !,"Dx Cat:",?12,$$GET1^DIQ(90001,BMCREF,.12)
End DoDot:1
PROC ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 IF $DATA(^BMCPX("AD",BMCREF))
Begin DoDot:1
+3 WRITE !,"Proc:"
+4 SET (C,X)=0
+5 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+6 ;F S X=$O(^BMCPX("AD",BMCREF,X)) Q:X'=+X!($D(BMCQUIT)) S C=C+1,BMCD=+^BMCPX(X,0) D:$Y>(IOSL-4) HEAD Q:$D(BMCQUIT) W:C'=1 ! W ?12,$P(^ICPT(BMCD,0),U),?19," - ",$E($P(^ICPT(BMCD,0),U,2),1,50)
+7 FOR
SET X=$ORDER(^BMCPX("AD",BMCREF,X))
IF X'=+X!($DATA(BMCQUIT))
QUIT
SET C=C+1
SET BMCD=+^BMCPX(X,0)
IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
IF C'=1
WRITE !
WRITE ?12,$PIECE($$CPT^ICPTCOD(BMCD,0),U,2),?19," - ",$EXTRACT($PIECE($$CPT^ICPTCOD(BMCD,0),U,3),1,50)
End DoDot:1
IF 1
+8 IF '$TEST
Begin DoDot:1
+9 WRITE !,"Srv Cat:",?12,$$GET1^DIQ(90001,BMCREF,.13)
End DoDot:1
+10 ;
THIRD ;Third Party Coverage
+1 ;W !
+2 IF '$GET(DFN)
QUIT
+3 SET BMCRDATE=DT
+4 NEW BMCMSG,BMCI,BMCX
+5 SET BMCI=1
+6 SET BMCX=$$BEN^AUPNPAT(DFN,"E")
+7 IF BMCX=""
SET BMCX="UNKNOWN"
+8 SET BMCMSG(BMCI)="CLASSIFICATION/BENEFICIARY IS: "_BMCX
SET BMCI=+BMCI+1
+9 SET BMCX=$$ELIGSTAT^AUPNPAT(DFN,"E")
+10 IF BMCX=""
SET BMCX="UNKNOWN"
+11 SET BMCMSG(BMCI)="ELIGIBILITY STATUS IS: "_BMCX
SET BMCI=+BMCI+1
+12 NEW BMCELG
+13 SET BMCELG=BMCI
+14 IF $$MCR^AUPNPAT(DFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS MEDICARE"
SET BMCI=BMCI+1
+15 ;I $$MCD^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID--",BMCI=BMCI+1
+16 SET BMCX=$$MCDPN^AUPNPAT(DFN,BMCRDATE,"E")
+17 IF BMCX=""
SET BMCX="UNKNOWN"
+18 IF $$MCD^AUPNPAT(DFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX
SET BMCI=+BMCI+1
+19 ;I $$PI^AUPNPAT(DFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS PRIVATE INSURANCE--",BMCI=BMCI+1
+20 SET BMCX=$$PIN^AUPNPAT(DFN,BMCRDATE,"E")
+21 IF BMCX=""
SET BMCX="UNKNOWN"
+22 IF $$PI^AUPNPAT(DFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS INSURANCE-INSURER: "_BMCX
SET BMCI=BMCI+1
+23 IF BMCELG=BMCI
SET BMCMSG(BMCI)="NO THIRD PARTY COVERAGE RECORDED"
SET BMCI=BMCI+1
+24 IF $DATA(^AUPNPAT(DFN,13))
Begin DoDot:1
+25 SET BMCMSG(BMCI)=""
SET BMCI=BMCI+1
SET BMCMSG(BMCI)="ADDITIONAL REGISTRATION INFORMATION:"
SET BMCI=BMCI+1
+26 KILL BMCAR
DO ENP^XBDIQ1(9000001,DFN,1301,"BMCAR(","E")
+27 SET I=0
FOR
SET I=$ORDER(BMCAR(1301,I))
IF I'=+I
QUIT
SET BMCMSG(BMCI)=BMCAR(1301,I)
SET BMCI=BMCI+1
End DoDot:1
+28 IF BMCI
WRITE !!
+29 SET BMCI=0
+30 FOR
SET BMCI=$ORDER(BMCMSG(BMCI))
IF 'BMCI
QUIT
WRITE BMCMSG(BMCI),!
+31 ;
+32 WRITE !,"--------------------",!
+33 QUIT
+34 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 ;4.0*1 3.24.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT
+5 SET Y=BMCBD
DO DD^%DT
WRITE ?17,"BEG DATE: "_Y
+6 SET Y=BMCED
DO DD^%DT
WRITE ?40,"END DATE: "_Y,!
+7 SET X="POTENTIAL HIGH COST CASES - BASED ON DIAGNOSIS"
+8 WRITE ?(80-$LENGTH(X))/2,X,!
+9 WRITE !,?49,"REF"
+10 WRITE !,"BEGIN D.O.S.",?13,"ST",?17,"HRN",?28,"PATIENT NAME",?49,"PROV",?54,"TYPE",?59,"FACILITY REFERRED TO"
+11 WRITE !,BMC80D
+12 QUIT
