ABMMUELG ;IHS/SD/SDR - Meaningful Use Report - count patients/eligibility ;
;;2.6;IHS 3P BILLING SYSTEM;**5,11,12,15**;NOV 12, 2009;Build 251
;IHS/SD/SDR - 2.6*12 - HEAT120278 - Made change to correct Railroad member#
;IHS/SD/SDR - 2.6*12 - VMBP RQMT_103 - Added VA elig to summary and detail
;IHS/SD/SDR - 2.6*15 - HEAT119702 - Updated so both devices would print ok. Was issue with the summary not printing
; to the printer.
;IHS/SD/SDR - 2.6*15 - HEAT188548 - Updated so a complete date should be entered for CEMU report.
;
W !!,"The date range selected will be used for: "
W !,?3,"1. Was the patient's record active during that range"
W !,?3,"2. Did the patient have eligibility in that range"
W !,?3,"3. How many encounters they had during that time"
W !!,"Detail information will be supplied for validation purposes but once validated"
W !,"the summary option should be used."
K ABMY,ABMP
K ^TMP($J,"ABM-MURPT")
DT ;
W !!," ============ Entry of Date Range =============",!
D ^XBFMK
S DIR("A")="Enter STARTING Date"
;S DIR(0)="DO^::EP" ;abm*2.6*15 HEAT188548
S DIR(0)="DO^::EPX" ;abm*2.6*15 HEAT188548
D ^DIR
Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
S ABMY("DT",1)=Y
W !
S DIR("A")="Enter ENDING Date"
D ^DIR
K DIR
G DT:$D(DIRUT)
S ABMY("DT",2)=Y
I ABMY("DT",1)>ABMY("DT",2) W !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!! G DT
RTYPE ;
W !
K DIC,DIE,DIR,X,Y,DA
S DIR(0)="S^S:SUMMARY;D:DETAIL (will include Summary)"
S DIR("A")="SUMMARY OR DETAIL"
S DIR("B")="SUMMARY"
D ^DIR K DIR
Q:$D(DIROUT)!$D(DUOUT)!$D(DIRUT)!$D(DTOUT) ;exit from report if '^', timeout, etc ;abm*2.6*15 HEAT188548
S ABMSUMDT=Y
;start new abm*2.6*15 HEAT119702
W !!,"Searching...."
D GETPTS
D GETELIG
D GETVSTS
;end new HEAT119702
SEL ;
; Select device
I ABMSUMDT="D" D
.W !!,"There will be two outputs, one for SUMMARY and one for DETAIL."
.W !,"The first one should be a terminal or a printer."
.W !,"The second forces an HFS file because it could be a large file",!
;S %ZIS="NQ" ;abm*2.6*15 HEAT119702
S %ZIS("A")="Enter DEVICE: "
D ^%ZIS Q:POP
;start old abm*2.6*15 HEAT119702
;U IO(0) W !!,"Searching...."
;I IO=IO(0) D TOTALS S DIR(0)="E" D ^DIR K DIR
;I IO'=IO(0) D QUE^ABMMUELG,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
;I $D(IO("S")) S IOP=ION D ^%ZIS
;D ^%ZISC
;D HOME^%ZIS
;end old start new HEAT119702
U IO
D TOTALS^ABMMUELG
D ^%ZISC
D HOME^%ZIS S DIR(0)="E" D ^DIR K DIR
;end new HEAT119702
;
I ABMSUMDT="D" D
.W !!,"Will now write detail to file",!!
.D ^XBFMK
.S DIR(0)="F"
.S DIR("A")="Enter Path"
.S DIR("B")=$P($G(^ABMDPARM(DUZ(2),1,4)),"^",7)
.D ^DIR K DIR
.Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.S ABMPATH=Y
.S DIR(0)="F",DIR("A")="Enter File Name"
.D ^DIR K DIR
.Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.S ABMFN=Y
.W !!,"Creating file..."
.D OPEN^%ZISH("ABM",ABMPATH,ABMFN,"W")
.Q:POP
.U IO
.D WRTPTS
.D WRTELIG
.D WRTVSTS
.D CLOSE^%ZISH("ABM")
.W "DONE"
XIT1 ;
Q
XIT ;
K ^TMP($J,"ABM-MURPT")
K ABMP,ABMY,ABMPTINA,ABMPT,ABMMFLG
Q
QUE ;QUE TO TASKMAN
S ZTRTN="TOTALS^ABMMUELG"
S ZTDESC="3P MEANINGFUL USE ELIGIBILITY REPORT"
S ZTSAVE("ABM*")=""
K ZTSK
D ^%ZTLOAD
W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
Q
GETPTS ;
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^AUPNPAT(ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNPAT(ABMP("PDFN"),41,DUZ(2))) D
..S ABMPTINA=$P($G(^AUPNPAT(ABMP("PDFN"),41,DUZ(2),0)),U,3) ;dt inactive/deleted
..I ABMPTINA'=""&((ABMPTINA<ABMY("DT",1))!(ABMPTINA>ABMY("DT",2))) Q ;pt inactive prior to or after range of rpt
..S ^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))=""
..S ^TMP($J,"ABM-MURPT","CNT","PTS")=+$G(^TMP($J,"ABM-MURPT","CNT","PTS"))+1 ;cnt pts
Q
;
GETELIG ;
;medicaid
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNMCD("B",ABMP("PDFN"))) D ;pt has mcd entry
..S ABMP("MDFN")=0
..F S ABMP("MDFN")=$O(^AUPNMCD("B",ABMP("PDFN"),ABMP("MDFN"))) Q:'ABMP("MDFN") D
...S ABMP("EFFDT")=0,ABMMFLG=0
...F S ABMP("EFFDT")=$O(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT"))) Q:'ABMP("EFFDT") D Q:(ABMMFLG=1)
....S ABMP("ENDDT")=$P($G(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT"),0)),U,2) ;end date
....;effective date after end of range or end date before start of range
....I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
....S ABMMFLG=1 ;if it gets here pt has elig in our window
...I ABMMFLG=1 D ;pt has at least one entry that's what we want
....S ^TMP($J,"ABM-MURPT","MCD",ABMP("PDFN"),ABMP("MDFN"))=""
....S ^TMP($J,"ABM-MURPT","CNT","MCD")=+$G(^TMP($J,"ABM-MURPT","CNT","MCD"))+1 ;cnt mcd pts
;
;medicare
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNMCR(ABMP("PDFN"))) D ;pt had mcr entry
..S ABMP("MDFN")=0,ABMMFLG=0
..F S ABMP("MDFN")=$O(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN") D Q:(ABMMFLG=1)
...S ABMP("EFFDT")=$P($G(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U) ;effective dt
...S ABMP("ENDDT")=$P($G(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2) ;end dt
...;effective date after end of range or end date before start of range
...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
...S ABMMFLG=1 ;if it gets here pt has elig in our window
..I ABMMFLG=1 D ;pt has at least one entry that's what we want
...S ^TMP($J,"ABM-MURPT","MCR",ABMP("PDFN"),ABMP("MDFN"))=""
...S ^TMP($J,"ABM-MURPT","CNT","MCR")=+$G(^TMP($J,"ABM-MURPT","CNT","MCR"))+1 ;cnt mcr pts
;
;railroad
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNRRE(ABMP("PDFN"))) D ;patient had medicare entry
..S ABMP("MDFN")=0,ABMMFLG=0
..F S ABMP("MDFN")=$O(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN") D Q:(ABMMFLG=1)
...S ABMP("EFFDT")=$P($G(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U) ;effective dt
...S ABMP("ENDDT")=$P($G(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2) ;end dt
...;effective dt after end of range or end dt before start of range
...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
...S ABMMFLG=1 ;if it gets here pt has elig in our window
..I ABMMFLG=1 D ;pt has at least one entry that's what we want
...S ^TMP($J,"ABM-MURPT","RR",ABMP("PDFN"),ABMP("MDFN"))=""
...S ^TMP($J,"ABM-MURPT","CNT","RR")=+$G(^TMP($J,"ABM-MURPT","CNT","RR"))+1 ;cnt rr pts
;
;private
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNPRVT(ABMP("PDFN"))) D ;patient has private entry
..S ABMP("MDFN")=0,ABMMFLG=0
..F S ABMP("MDFN")=$O(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN") D Q:(ABMMFLG=1)
...S ABMP("EFFDT")=$P($G(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,6) ;effective dt
...S ABMP("ENDDT")=$P($G(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,7) ;end dt
...;effective dt after end of range or end dt before start of range
...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
...S ABMMFLG=1 ;if it gets here pt has elig in our window
..I ABMMFLG=1 D ;pt has at least one entry that's what we want
...S ^TMP($J,"ABM-MURPT","PI",ABMP("PDFN"),ABMP("MDFN"))=""
...S ^TMP($J,"ABM-MURPT","CNT","PI")=+$G(^TMP($J,"ABM-MURPT","CNT","PI"))+1 ;cnt private pts
;
;start new abm*2.6*12 VMBP RQMT_103
;medicare
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I $D(^AUPNVAMB(ABMP("PDFN"))) D ;pt had VAMB eligible entry
..S ABMP("MDFN")=0,ABMMFLG=0
..F S ABMP("MDFN")=$O(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN") D Q:(ABMMFLG=1)
...S ABMP("EFFDT")=$P($G(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U) ;effective dt
...S ABMP("ENDDT")=$P($G(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2) ;end dt
...;effective date after end of range or end date before start of range
...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
...S ABMMFLG=1 ;if it gets here pt has elig in our window
..I ABMMFLG=1 D ;pt has at least one entry that's what we want
...S ^TMP($J,"ABM-MURPT","VAMB",ABMP("PDFN"),ABMP("MDFN"))=""
...S ^TMP($J,"ABM-MURPT","CNT","VAMB")=+$G(^TMP($J,"ABM-MURPT","CNT","VAMB"))+1 ;cnt VAMB pts
;end new VMBP RQMT_103
;
;no insurance
S ABMP("PDFN")=0
F S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN") D
.I '$D(^TMP($J,"ABM-MURPT","PI",ABMP("PDFN")))&'$D(^TMP($J,"ABM-MURPT","MCD",ABMP("PDFN")))&'$D(^TMP($J,"ABM-MURPT","MCR",ABMP("PDFN")))&'$D(^TMP($J,"ABM-MURPT","RR",ABMP("PDFN"))) D
..S ^TMP($J,"ABM-MURPT","CNT","NO")=+$G(^TMP($J,"ABM-MURPT","CNT","NO"))+1 ;cnt no insurance pts
..S ^TMP($J,"ABM-MURPT","NO",ABMP("PDFN"))=""
;
Q
;
GETVSTS ;
S ABMP("SDT")=ABMY("DT",1)-.5
S ABMP("EDT")=ABMY("DT",2)+.999999
F S ABMP("SDT")=$O(^AUPNVSIT("B",ABMP("SDT"))) Q:('ABMP("SDT")!(ABMP("SDT")>ABMP("EDT"))) D
.S ABMP("VDFN")=0
.F S ABMP("VDFN")=$O(^AUPNVSIT("B",ABMP("SDT"),ABMP("VDFN"))) Q:'ABMP("VDFN") D
..S ABMPT=$P($G(^AUPNVSIT(ABMP("VDFN"),0)),U,5) ;pt
..Q:ABMPT="" ;no patient on visit
..I '$D(^TMP($J,"ABM-MURPT","PTS",ABMPT)) Q ;not one of our pts
..S ^TMP($J,"ABM-MURPT","ENC",ABMP("VDFN"))=""
..S ^TMP($J,"ABM-MURPT","CNT","ENC")=+$G(^TMP($J,"ABM-MURPT","CNT","ENC"))+1 ;cnt encounters
..I '$D(^TMP($J,"ABM-MURPT","UNQ",ABMPT)) D
...S ^TMP($J,"ABM-MURPT","UNQ",ABMPT)=""
...S ^TMP($J,"ABM-MURPT","CNT","UNQ")=+$G(^TMP($J,"ABM-MURPT","CNT","UNQ"))+1 ;cnt unique pts
Q
;
TOTALS ;
;Practice Demographics
;# of Patient
;Encounters/Year
;# of Unique Patients/Year
S ABM("HD",0)="Meaningful Use Eligibility Report"
S ABM("PG")=1
;start old abm*2.6*15 HEAT119702
;D GETPTS
;D GETELIG
;D GETVSTS
;end old HEAT119702
D WHD
W !!,"Practice Demographics"
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")),7)_" Patients"
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","ENC")),7)_" Encounters"
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","UNQ")),7)_" Unique Patients"
;
;Patient Demographics
I +$G(^TMP($J,"ABM-MURPT","CNT","PTS"))=0 W !!,"(REPORT COMPLETE)" Q ;no patients found so it cause a DIVIDE error if we continue
W !!,"Patient Demographics"
;medicaid
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","MCD")),7)_" Patients with Medicaid ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","MCD"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;medicare
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","MCR")),7)_" Patients with Medicare ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","MCR"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;railroad
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","RR")),7)_" Patients with Railroad ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","RR"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;private
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","PI")),7)_" Patients with Private ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","PI"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;no eligibility
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","NO")),7)_" Patients Uninsured ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","NO"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;start new abm*2.6*11 VMBP#9 RQMT_103
;vmbp
W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","VAMB")),7)_" Patients with VA Med B ( "_$J($FN((+$G(^TMP($J,"ABM-MURPT","CNT","VAMB"))/(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
;end new VMBP#9 RQMT_103
W !!,"(REPORT COMPLETE)"
Q
;
WRTPTS ;^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))
D WRTPTS^ABMMUEL1
Q
;
WRTELIG ;
D WRTELIG^ABMMUEL1
Q
;
WRTVSTS ;^TMP($J,"ABM-MURPT","ENC",ABMP("VDFN"))
D WRTVSTS^ABMMUEL1
Q
WHD ;EP for writing Report Header
W $$EN^ABMVDF("IOF"),!
K ABM("LINE") S $P(ABM("LINE"),"=",$S($D(ABM(132)):132,1:80))="" W ABM("LINE"),!
D NOW^%DTC ;abm*2.6*1 NO HEAT
W ABM("HD",0),?$S($D(ABM(132)):103,1:48) S Y=% X ^DD("DD") W Y," Page ",ABM("PG")
S ABM("HD",1)="For date range: "_$$SDT^ABMDUTL(ABMY("DT",1))_" to "_$$SDT^ABMDUTL(ABMY("DT",2))
W:$G(ABM("HD",1))]"" !,ABM("HD",1)
W:$G(ABM("HD",2))]"" !,ABM("HD",2)
W !,"Billing Location: ",$P($G(^AUTTLOC(DUZ(2),0)),U,2)
W !,ABM("LINE") K ABM("LINE")
Q
ABMMUELG ;IHS/SD/SDR - Meaningful Use Report - count patients/eligibility ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**5,11,12,15**;NOV 12, 2009;Build 251
+2 ;IHS/SD/SDR - 2.6*12 - HEAT120278 - Made change to correct Railroad member#
+3 ;IHS/SD/SDR - 2.6*12 - VMBP RQMT_103 - Added VA elig to summary and detail
+4 ;IHS/SD/SDR - 2.6*15 - HEAT119702 - Updated so both devices would print ok. Was issue with the summary not printing
+5 ; to the printer.
+6 ;IHS/SD/SDR - 2.6*15 - HEAT188548 - Updated so a complete date should be entered for CEMU report.
+7 ;
+8 WRITE !!,"The date range selected will be used for: "
+9 WRITE !,?3,"1. Was the patient's record active during that range"
+10 WRITE !,?3,"2. Did the patient have eligibility in that range"
+11 WRITE !,?3,"3. How many encounters they had during that time"
+12 WRITE !!,"Detail information will be supplied for validation purposes but once validated"
+13 WRITE !,"the summary option should be used."
+14 KILL ABMY,ABMP
+15 KILL ^TMP($JOB,"ABM-MURPT")
DT ;
+1 WRITE !!," ============ Entry of Date Range =============",!
+2 DO ^XBFMK
+3 SET DIR("A")="Enter STARTING Date"
+4 ;S DIR(0)="DO^::EP" ;abm*2.6*15 HEAT188548
+5 ;abm*2.6*15 HEAT188548
SET DIR(0)="DO^::EPX"
+6 DO ^DIR
+7 IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 SET ABMY("DT",1)=Y
+9 WRITE !
+10 SET DIR("A")="Enter ENDING Date"
+11 DO ^DIR
+12 KILL DIR
+13 IF $DATA(DIRUT)
GOTO DT
+14 SET ABMY("DT",2)=Y
+15 IF ABMY("DT",1)>ABMY("DT",2)
WRITE !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!!
GOTO DT
RTYPE ;
+1 WRITE !
+2 KILL DIC,DIE,DIR,X,Y,DA
+3 SET DIR(0)="S^S:SUMMARY;D:DETAIL (will include Summary)"
+4 SET DIR("A")="SUMMARY OR DETAIL"
+5 SET DIR("B")="SUMMARY"
+6 DO ^DIR
KILL DIR
+7 ;exit from report if '^', timeout, etc ;abm*2.6*15 HEAT188548
IF $DATA(DIROUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
QUIT
+8 SET ABMSUMDT=Y
+9 ;start new abm*2.6*15 HEAT119702
+10 WRITE !!,"Searching...."
+11 DO GETPTS
+12 DO GETELIG
+13 DO GETVSTS
+14 ;end new HEAT119702
SEL ;
+1 ; Select device
+2 IF ABMSUMDT="D"
Begin DoDot:1
+3 WRITE !!,"There will be two outputs, one for SUMMARY and one for DETAIL."
+4 WRITE !,"The first one should be a terminal or a printer."
+5 WRITE !,"The second forces an HFS file because it could be a large file",!
End DoDot:1
+6 ;S %ZIS="NQ" ;abm*2.6*15 HEAT119702
+7 SET %ZIS("A")="Enter DEVICE: "
+8 DO ^%ZIS
IF POP
QUIT
+9 ;start old abm*2.6*15 HEAT119702
+10 ;U IO(0) W !!,"Searching...."
+11 ;I IO=IO(0) D TOTALS S DIR(0)="E" D ^DIR K DIR
+12 ;I IO'=IO(0) D QUE^ABMMUELG,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
+13 ;I $D(IO("S")) S IOP=ION D ^%ZIS
+14 ;D ^%ZISC
+15 ;D HOME^%ZIS
+16 ;end old start new HEAT119702
+17 USE IO
+18 DO TOTALS^ABMMUELG
+19 DO ^%ZISC
+20 DO HOME^%ZIS
SET DIR(0)="E"
DO ^DIR
KILL DIR
+21 ;end new HEAT119702
+22 ;
+23 IF ABMSUMDT="D"
Begin DoDot:1
+24 WRITE !!,"Will now write detail to file",!!
+25 DO ^XBFMK
+26 SET DIR(0)="F"
+27 SET DIR("A")="Enter Path"
+28 SET DIR("B")=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),"^",7)
+29 DO ^DIR
KILL DIR
+30 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+31 SET ABMPATH=Y
+32 SET DIR(0)="F"
SET DIR("A")="Enter File Name"
+33 DO ^DIR
KILL DIR
+34 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+35 SET ABMFN=Y
+36 WRITE !!,"Creating file..."
+37 DO OPEN^%ZISH("ABM",ABMPATH,ABMFN,"W")
+38 IF POP
QUIT
+39 USE IO
+40 DO WRTPTS
+41 DO WRTELIG
+42 DO WRTVSTS
+43 DO CLOSE^%ZISH("ABM")
+44 WRITE "DONE"
End DoDot:1
XIT1 ;
+1 QUIT
XIT ;
+1 KILL ^TMP($JOB,"ABM-MURPT")
+2 KILL ABMP,ABMY,ABMPTINA,ABMPT,ABMMFLG
+3 QUIT
QUE ;QUE TO TASKMAN
+1 SET ZTRTN="TOTALS^ABMMUELG"
+2 SET ZTDESC="3P MEANINGFUL USE ELIGIBILITY REPORT"
+3 SET ZTSAVE("ABM*")=""
+4 KILL ZTSK
+5 DO ^%ZTLOAD
+6 IF $GET(ZTSK)
WRITE !,"Task # ",ZTSK," queued.",!
+7 QUIT
GETPTS ;
+1 SET ABMP("PDFN")=0
+2 FOR
SET ABMP("PDFN")=$ORDER(^AUPNPAT(ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+3 IF $DATA(^AUPNPAT(ABMP("PDFN"),41,DUZ(2)))
Begin DoDot:2
+4 ;dt inactive/deleted
SET ABMPTINA=$PIECE($GET(^AUPNPAT(ABMP("PDFN"),41,DUZ(2),0)),U,3)
+5 ;pt inactive prior to or after range of rpt
IF ABMPTINA'=""&((ABMPTINA<ABMY("DT",1))!(ABMPTINA>ABMY("DT",2)))
QUIT
+6 SET ^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN"))=""
+7 ;cnt pts
SET ^TMP($JOB,"ABM-MURPT","CNT","PTS")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS"))+1
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
GETELIG ;
+1 ;medicaid
+2 SET ABMP("PDFN")=0
+3 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+4 ;pt has mcd entry
IF $DATA(^AUPNMCD("B",ABMP("PDFN")))
Begin DoDot:2
+5 SET ABMP("MDFN")=0
+6 FOR
SET ABMP("MDFN")=$ORDER(^AUPNMCD("B",ABMP("PDFN"),ABMP("MDFN")))
IF 'ABMP("MDFN")
QUIT
Begin DoDot:3
+7 SET ABMP("EFFDT")=0
SET ABMMFLG=0
+8 FOR
SET ABMP("EFFDT")=$ORDER(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT")))
IF 'ABMP("EFFDT")
QUIT
Begin DoDot:4
+9 ;end date
SET ABMP("ENDDT")=$PIECE($GET(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT"),0)),U,2)
+10 ;effective date after end of range or end date before start of range
+11 IF (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1)))
QUIT
+12 ;if it gets here pt has elig in our window
SET ABMMFLG=1
End DoDot:4
IF (ABMMFLG=1)
QUIT
+13 ;pt has at least one entry that's what we want
IF ABMMFLG=1
Begin DoDot:4
+14 SET ^TMP($JOB,"ABM-MURPT","MCD",ABMP("PDFN"),ABMP("MDFN"))=""
+15 ;cnt mcd pts
SET ^TMP($JOB,"ABM-MURPT","CNT","MCD")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCD"))+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 ;medicare
+18 SET ABMP("PDFN")=0
+19 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+20 ;pt had mcr entry
IF $DATA(^AUPNMCR(ABMP("PDFN")))
Begin DoDot:2
+21 SET ABMP("MDFN")=0
SET ABMMFLG=0
+22 FOR
SET ABMP("MDFN")=$ORDER(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN")))
IF 'ABMP("MDFN")
QUIT
Begin DoDot:3
+23 ;effective dt
SET ABMP("EFFDT")=$PIECE($GET(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)
+24 ;end dt
SET ABMP("ENDDT")=$PIECE($GET(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)
+25 ;effective date after end of range or end date before start of range
+26 IF (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1)))
QUIT
+27 ;if it gets here pt has elig in our window
SET ABMMFLG=1
End DoDot:3
IF (ABMMFLG=1)
QUIT
+28 ;pt has at least one entry that's what we want
IF ABMMFLG=1
Begin DoDot:3
+29 SET ^TMP($JOB,"ABM-MURPT","MCR",ABMP("PDFN"),ABMP("MDFN"))=""
+30 ;cnt mcr pts
SET ^TMP($JOB,"ABM-MURPT","CNT","MCR")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCR"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 ;railroad
+33 SET ABMP("PDFN")=0
+34 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+35 ;patient had medicare entry
IF $DATA(^AUPNRRE(ABMP("PDFN")))
Begin DoDot:2
+36 SET ABMP("MDFN")=0
SET ABMMFLG=0
+37 FOR
SET ABMP("MDFN")=$ORDER(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN")))
IF 'ABMP("MDFN")
QUIT
Begin DoDot:3
+38 ;effective dt
SET ABMP("EFFDT")=$PIECE($GET(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)
+39 ;end dt
SET ABMP("ENDDT")=$PIECE($GET(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)
+40 ;effective dt after end of range or end dt before start of range
+41 IF (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1)))
QUIT
+42 ;if it gets here pt has elig in our window
SET ABMMFLG=1
End DoDot:3
IF (ABMMFLG=1)
QUIT
+43 ;pt has at least one entry that's what we want
IF ABMMFLG=1
Begin DoDot:3
+44 SET ^TMP($JOB,"ABM-MURPT","RR",ABMP("PDFN"),ABMP("MDFN"))=""
+45 ;cnt rr pts
SET ^TMP($JOB,"ABM-MURPT","CNT","RR")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","RR"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 ;private
+48 SET ABMP("PDFN")=0
+49 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+50 ;patient has private entry
IF $DATA(^AUPNPRVT(ABMP("PDFN")))
Begin DoDot:2
+51 SET ABMP("MDFN")=0
SET ABMMFLG=0
+52 FOR
SET ABMP("MDFN")=$ORDER(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN")))
IF 'ABMP("MDFN")
QUIT
Begin DoDot:3
+53 ;effective dt
SET ABMP("EFFDT")=$PIECE($GET(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,6)
+54 ;end dt
SET ABMP("ENDDT")=$PIECE($GET(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,7)
+55 ;effective dt after end of range or end dt before start of range
+56 IF (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1)))
QUIT
+57 ;if it gets here pt has elig in our window
SET ABMMFLG=1
End DoDot:3
IF (ABMMFLG=1)
QUIT
+58 ;pt has at least one entry that's what we want
IF ABMMFLG=1
Begin DoDot:3
+59 SET ^TMP($JOB,"ABM-MURPT","PI",ABMP("PDFN"),ABMP("MDFN"))=""
+60 ;cnt private pts
SET ^TMP($JOB,"ABM-MURPT","CNT","PI")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","PI"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 ;start new abm*2.6*12 VMBP RQMT_103
+63 ;medicare
+64 SET ABMP("PDFN")=0
+65 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+66 ;pt had VAMB eligible entry
IF $DATA(^AUPNVAMB(ABMP("PDFN")))
Begin DoDot:2
+67 SET ABMP("MDFN")=0
SET ABMMFLG=0
+68 FOR
SET ABMP("MDFN")=$ORDER(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN")))
IF 'ABMP("MDFN")
QUIT
Begin DoDot:3
+69 ;effective dt
SET ABMP("EFFDT")=$PIECE($GET(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)
+70 ;end dt
SET ABMP("ENDDT")=$PIECE($GET(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)
+71 ;effective date after end of range or end date before start of range
+72 IF (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1)))
QUIT
+73 ;if it gets here pt has elig in our window
SET ABMMFLG=1
End DoDot:3
IF (ABMMFLG=1)
QUIT
+74 ;pt has at least one entry that's what we want
IF ABMMFLG=1
Begin DoDot:3
+75 SET ^TMP($JOB,"ABM-MURPT","VAMB",ABMP("PDFN"),ABMP("MDFN"))=""
+76 ;cnt VAMB pts
SET ^TMP($JOB,"ABM-MURPT","CNT","VAMB")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","VAMB"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+77 ;end new VMBP RQMT_103
+78 ;
+79 ;no insurance
+80 SET ABMP("PDFN")=0
+81 FOR
SET ABMP("PDFN")=$ORDER(^TMP($JOB,"ABM-MURPT","PTS",ABMP("PDFN")))
IF 'ABMP("PDFN")
QUIT
Begin DoDot:1
+82 IF '$DATA(^TMP($JOB,"ABM-MURPT","PI",ABMP("PDFN")))&'$DATA(^TMP($JOB,"ABM-MURPT","MCD",ABMP("PDFN")))&'$DATA(^TMP($JOB,"ABM-MURPT","MCR",ABMP("PDFN")))&'$DATA(^TMP($JOB,"ABM-MURPT","RR",ABMP("PDFN")))
Begin DoDot:2
+83 ;cnt no insurance pts
SET ^TMP($JOB,"ABM-MURPT","CNT","NO")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","NO"))+1
+84 SET ^TMP($JOB,"ABM-MURPT","NO",ABMP("PDFN"))=""
End DoDot:2
End DoDot:1
+85 ;
+86 QUIT
+87 ;
GETVSTS ;
+1 SET ABMP("SDT")=ABMY("DT",1)-.5
+2 SET ABMP("EDT")=ABMY("DT",2)+.999999
+3 FOR
SET ABMP("SDT")=$ORDER(^AUPNVSIT("B",ABMP("SDT")))
IF ('ABMP("SDT")!(ABMP("SDT")>ABMP("EDT")))
QUIT
Begin DoDot:1
+4 SET ABMP("VDFN")=0
+5 FOR
SET ABMP("VDFN")=$ORDER(^AUPNVSIT("B",ABMP("SDT"),ABMP("VDFN")))
IF 'ABMP("VDFN")
QUIT
Begin DoDot:2
+6 ;pt
SET ABMPT=$PIECE($GET(^AUPNVSIT(ABMP("VDFN"),0)),U,5)
+7 ;no patient on visit
IF ABMPT=""
QUIT
+8 ;not one of our pts
IF '$DATA(^TMP($JOB,"ABM-MURPT","PTS",ABMPT))
QUIT
+9 SET ^TMP($JOB,"ABM-MURPT","ENC",ABMP("VDFN"))=""
+10 ;cnt encounters
SET ^TMP($JOB,"ABM-MURPT","CNT","ENC")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","ENC"))+1
+11 IF '$DATA(^TMP($JOB,"ABM-MURPT","UNQ",ABMPT))
Begin DoDot:3
+12 SET ^TMP($JOB,"ABM-MURPT","UNQ",ABMPT)=""
+13 ;cnt unique pts
SET ^TMP($JOB,"ABM-MURPT","CNT","UNQ")=+$GET(^TMP($JOB,"ABM-MURPT","CNT","UNQ"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
TOTALS ;
+1 ;Practice Demographics
+2 ;# of Patient
+3 ;Encounters/Year
+4 ;# of Unique Patients/Year
+5 SET ABM("HD",0)="Meaningful Use Eligibility Report"
+6 SET ABM("PG")=1
+7 ;start old abm*2.6*15 HEAT119702
+8 ;D GETPTS
+9 ;D GETELIG
+10 ;D GETVSTS
+11 ;end old HEAT119702
+12 DO WHD
+13 WRITE !!,"Practice Demographics"
+14 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")),7)_" Patients"
+15 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","ENC")),7)_" Encounters"
+16 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","UNQ")),7)_" Unique Patients"
+17 ;
+18 ;Patient Demographics
+19 ;no patients found so it cause a DIVIDE error if we continue
IF +$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS"))=0
WRITE !!,"(REPORT COMPLETE)"
QUIT
+20 WRITE !!,"Patient Demographics"
+21 ;medicaid
+22 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCD")),7)_" Patients with Medicaid ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCD"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+23 ;medicare
+24 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCR")),7)_" Patients with Medicare ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","MCR"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+25 ;railroad
+26 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","RR")),7)_" Patients with Railroad ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","RR"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+27 ;private
+28 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PI")),7)_" Patients with Private ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","PI"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+29 ;no eligibility
+30 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","NO")),7)_" Patients Uninsured ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","NO"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+31 ;start new abm*2.6*11 VMBP#9 RQMT_103
+32 ;vmbp
+33 WRITE !?2,$JUSTIFY(+$GET(^TMP($JOB,"ABM-MURPT","CNT","VAMB")),7)_" Patients with VA Med B ( "_$JUSTIFY($FNUMBER((+$GET(^TMP($JOB,"ABM-MURPT","CNT","VAMB"))/(+$GET(^TMP($JOB,"ABM-MURPT","CNT","PTS")))*100),",",2),5)_"% )"
+34 ;end new VMBP#9 RQMT_103
+35 WRITE !!,"(REPORT COMPLETE)"
+36 QUIT
+37 ;
WRTPTS ;^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))
+1 DO WRTPTS^ABMMUEL1
+2 QUIT
+3 ;
WRTELIG ;
+1 DO WRTELIG^ABMMUEL1
+2 QUIT
+3 ;
WRTVSTS ;^TMP($J,"ABM-MURPT","ENC",ABMP("VDFN"))
+1 DO WRTVSTS^ABMMUEL1
+2 QUIT
WHD ;EP for writing Report Header
+1 WRITE $$EN^ABMVDF("IOF"),!
+2 KILL ABM("LINE")
SET $PIECE(ABM("LINE"),"=",$SELECT($DATA(ABM(132)):132,1:80))=""
WRITE ABM("LINE"),!
+3 ;abm*2.6*1 NO HEAT
DO NOW^%DTC
+4 WRITE ABM("HD",0),?$SELECT($DATA(ABM(132)):103,1:48)
SET Y=%
XECUTE ^DD("DD")
WRITE Y," Page ",ABM("PG")
+5 SET ABM("HD",1)="For date range: "_$$SDT^ABMDUTL(ABMY("DT",1))_" to "_$$SDT^ABMDUTL(ABMY("DT",2))
+6 IF $GET(ABM("HD",1))]""
WRITE !,ABM("HD",1)
+7 IF $GET(ABM("HD",2))]""
WRITE !,ABM("HD",2)
+8 WRITE !,"Billing Location: ",$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,2)
+9 WRITE !,ABM("LINE")
KILL ABM("LINE")
+10 QUIT
