Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABMMUELG

ABMMUELG.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/SD/SDR - 2.6*12 - HEAT120278 - Made change to correct Railroad member#
  1.  ;IHS/SD/SDR - 2.6*12 - VMBP RQMT_103 - Added VA elig to summary and detail
  1.  ;IHS/SD/SDR - 2.6*15 - HEAT119702 - Updated so both devices would print ok.  Was issue with the summary not printing
  1.  ;  to the printer.
  1.  ;IHS/SD/SDR - 2.6*15 - HEAT188548 - Updated so a complete date should be entered for CEMU report.
  1.  ;
  1.  W !!,"The date range selected will be used for: "
  1.  W !,?3,"1. Was the patient's record active during that range"
  1.  W !,?3,"2. Did the patient have eligibility in that range"
  1.  W !,?3,"3. How many encounters they had during that time"
  1.  W !!,"Detail information will be supplied for validation purposes but once validated"
  1.  W !,"the summary option should be used."
  1.  K ABMY,ABMP
  1.  K ^TMP($J,"ABM-MURPT")
  1. DT ;
  1.  W !!," ============ Entry of Date Range =============",!
  1.  D ^XBFMK
  1.  S DIR("A")="Enter STARTING Date"
  1.  ;S DIR(0)="DO^::EP"  ;abm*2.6*15 HEAT188548
  1.  S DIR(0)="DO^::EPX"  ;abm*2.6*15 HEAT188548
  1.  D ^DIR
  1.  Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
  1.  S ABMY("DT",1)=Y
  1.  W !
  1.  S DIR("A")="Enter ENDING Date"
  1.  D ^DIR
  1.  K DIR
  1.  G DT:$D(DIRUT)
  1.  S ABMY("DT",2)=Y
  1.  I ABMY("DT",1)>ABMY("DT",2) W !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!! G DT
  1. RTYPE ;
  1.  W !
  1.  K DIC,DIE,DIR,X,Y,DA
  1.  S DIR(0)="S^S:SUMMARY;D:DETAIL (will include Summary)"
  1.  S DIR("A")="SUMMARY OR DETAIL"
  1.  S DIR("B")="SUMMARY"
  1.  D ^DIR K DIR
  1.  Q:$D(DIROUT)!$D(DUOUT)!$D(DIRUT)!$D(DTOUT)  ;exit from report if '^', timeout, etc  ;abm*2.6*15 HEAT188548
  1.  S ABMSUMDT=Y
  1.  ;start new abm*2.6*15 HEAT119702
  1.  W !!,"Searching...."
  1.  D GETPTS
  1.  D GETELIG
  1.  D GETVSTS
  1.  ;end new HEAT119702
  1. SEL ;
  1.  ; Select device
  1.  I ABMSUMDT="D" D
  1.  .W !!,"There will be two outputs, one for SUMMARY and one for DETAIL."
  1.  .W !,"The first one should be a terminal or a printer."
  1.  .W !,"The second forces an HFS file because it could be a large file",!
  1.  ;S %ZIS="NQ"  ;abm*2.6*15 HEAT119702
  1.  S %ZIS("A")="Enter DEVICE: "
  1.  D ^%ZIS Q:POP
  1.  ;start old abm*2.6*15 HEAT119702
  1.  ;U IO(0) W !!,"Searching...."
  1.  ;I IO=IO(0) D TOTALS S DIR(0)="E" D ^DIR K DIR
  1.  ;I IO'=IO(0) D QUE^ABMMUELG,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
  1.  ;I $D(IO("S")) S IOP=ION D ^%ZIS
  1.  ;D ^%ZISC
  1.  ;D HOME^%ZIS
  1.  ;end old start new HEAT119702
  1.  U IO
  1.  D TOTALS^ABMMUELG
  1.  D ^%ZISC
  1.  D HOME^%ZIS S DIR(0)="E" D ^DIR K DIR
  1.  ;end new HEAT119702
  1.  ;
  1.  I ABMSUMDT="D" D
  1.  .W !!,"Will now write detail to file",!!
  1.  .D ^XBFMK
  1.  .S DIR(0)="F"
  1.  .S DIR("A")="Enter Path"
  1.  .S DIR("B")=$P($G(^ABMDPARM(DUZ(2),1,4)),"^",7)
  1.  .D ^DIR K DIR
  1.  .Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  .S ABMPATH=Y
  1.  .S DIR(0)="F",DIR("A")="Enter File Name"
  1.  .D ^DIR K DIR
  1.  .Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  .S ABMFN=Y
  1.  .W !!,"Creating file..."
  1.  .D OPEN^%ZISH("ABM",ABMPATH,ABMFN,"W")
  1.  .Q:POP
  1.  .U IO
  1.  .D WRTPTS
  1.  .D WRTELIG
  1.  .D WRTVSTS
  1.  .D CLOSE^%ZISH("ABM")
  1.  .W "DONE"
  1. XIT1 ;
  1.  Q
  1. XIT ;
  1.  K ^TMP($J,"ABM-MURPT")
  1.  K ABMP,ABMY,ABMPTINA,ABMPT,ABMMFLG
  1.  Q
  1. QUE ;QUE TO TASKMAN
  1.  S ZTRTN="TOTALS^ABMMUELG"
  1.  S ZTDESC="3P MEANINGFUL USE ELIGIBILITY REPORT"
  1.  S ZTSAVE("ABM*")=""
  1.  K ZTSK
  1.  D ^%ZTLOAD
  1.  W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
  1.  Q
  1. GETPTS ;
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^AUPNPAT(ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNPAT(ABMP("PDFN"),41,DUZ(2))) D
  1.  ..S ABMPTINA=$P($G(^AUPNPAT(ABMP("PDFN"),41,DUZ(2),0)),U,3)  ;dt inactive/deleted
  1.  ..I ABMPTINA'=""&((ABMPTINA<ABMY("DT",1))!(ABMPTINA>ABMY("DT",2))) Q  ;pt inactive prior to or after range of rpt
  1.  ..S ^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))=""
  1.  ..S ^TMP($J,"ABM-MURPT","CNT","PTS")=+$G(^TMP($J,"ABM-MURPT","CNT","PTS"))+1  ;cnt pts
  1.  Q
  1.  ;
  1. GETELIG ;
  1.  ;medicaid
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNMCD("B",ABMP("PDFN"))) D  ;pt has mcd entry
  1.  ..S ABMP("MDFN")=0
  1.  ..F  S ABMP("MDFN")=$O(^AUPNMCD("B",ABMP("PDFN"),ABMP("MDFN"))) Q:'ABMP("MDFN")  D
  1.  ...S ABMP("EFFDT")=0,ABMMFLG=0
  1.  ...F  S ABMP("EFFDT")=$O(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT"))) Q:'ABMP("EFFDT")  D  Q:(ABMMFLG=1)
  1.  ....S ABMP("ENDDT")=$P($G(^AUPNMCD(ABMP("MDFN"),11,ABMP("EFFDT"),0)),U,2)  ;end date
  1.  ....;effective date after end of range or end date before start of range
  1.  ....I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
  1.  ....S ABMMFLG=1  ;if it gets here pt has elig in our window
  1.  ...I ABMMFLG=1 D  ;pt has at least one entry that's what we want
  1.  ....S ^TMP($J,"ABM-MURPT","MCD",ABMP("PDFN"),ABMP("MDFN"))=""
  1.  ....S ^TMP($J,"ABM-MURPT","CNT","MCD")=+$G(^TMP($J,"ABM-MURPT","CNT","MCD"))+1  ;cnt mcd pts
  1.  ;
  1.  ;medicare
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNMCR(ABMP("PDFN"))) D  ;pt had mcr entry
  1.  ..S ABMP("MDFN")=0,ABMMFLG=0
  1.  ..F  S ABMP("MDFN")=$O(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN")  D  Q:(ABMMFLG=1)
  1.  ...S ABMP("EFFDT")=$P($G(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)  ;effective dt
  1.  ...S ABMP("ENDDT")=$P($G(^AUPNMCR(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)  ;end dt
  1.  ...;effective date after end of range or end date before start of range
  1.  ...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
  1.  ...S ABMMFLG=1  ;if it gets here pt has elig in our window
  1.  ..I ABMMFLG=1 D  ;pt has at least one entry that's what we want
  1.  ...S ^TMP($J,"ABM-MURPT","MCR",ABMP("PDFN"),ABMP("MDFN"))=""
  1.  ...S ^TMP($J,"ABM-MURPT","CNT","MCR")=+$G(^TMP($J,"ABM-MURPT","CNT","MCR"))+1  ;cnt mcr pts
  1.  ;
  1.  ;railroad
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNRRE(ABMP("PDFN"))) D  ;patient had medicare entry
  1.  ..S ABMP("MDFN")=0,ABMMFLG=0
  1.  ..F  S ABMP("MDFN")=$O(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN")  D  Q:(ABMMFLG=1)
  1.  ...S ABMP("EFFDT")=$P($G(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)  ;effective dt
  1.  ...S ABMP("ENDDT")=$P($G(^AUPNRRE(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)  ;end dt
  1.  ...;effective dt after end of range or end dt before start of range
  1.  ...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
  1.  ...S ABMMFLG=1  ;if it gets here pt has elig in our window
  1.  ..I ABMMFLG=1 D  ;pt has at least one entry that's what we want
  1.  ...S ^TMP($J,"ABM-MURPT","RR",ABMP("PDFN"),ABMP("MDFN"))=""
  1.  ...S ^TMP($J,"ABM-MURPT","CNT","RR")=+$G(^TMP($J,"ABM-MURPT","CNT","RR"))+1  ;cnt rr pts
  1.  ;
  1.  ;private
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNPRVT(ABMP("PDFN"))) D  ;patient has private entry
  1.  ..S ABMP("MDFN")=0,ABMMFLG=0
  1.  ..F  S ABMP("MDFN")=$O(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN")  D  Q:(ABMMFLG=1)
  1.  ...S ABMP("EFFDT")=$P($G(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,6)  ;effective dt
  1.  ...S ABMP("ENDDT")=$P($G(^AUPNPRVT(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,7)  ;end dt
  1.  ...;effective dt after end of range or end dt before start of range
  1.  ...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
  1.  ...S ABMMFLG=1  ;if it gets here pt has elig in our window
  1.  ..I ABMMFLG=1 D  ;pt has at least one entry that's what we want
  1.  ...S ^TMP($J,"ABM-MURPT","PI",ABMP("PDFN"),ABMP("MDFN"))=""
  1.  ...S ^TMP($J,"ABM-MURPT","CNT","PI")=+$G(^TMP($J,"ABM-MURPT","CNT","PI"))+1  ;cnt private pts
  1.  ;
  1.  ;start new abm*2.6*12 VMBP RQMT_103
  1.  ;medicare
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .I $D(^AUPNVAMB(ABMP("PDFN"))) D  ;pt had VAMB eligible entry
  1.  ..S ABMP("MDFN")=0,ABMMFLG=0
  1.  ..F  S ABMP("MDFN")=$O(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"))) Q:'ABMP("MDFN")  D  Q:(ABMMFLG=1)
  1.  ...S ABMP("EFFDT")=$P($G(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U)  ;effective dt
  1.  ...S ABMP("ENDDT")=$P($G(^AUPNVAMB(ABMP("PDFN"),11,ABMP("MDFN"),0)),U,2)  ;end dt
  1.  ...;effective date after end of range or end date before start of range
  1.  ...I (ABMP("EFFDT")>ABMY("DT",2))!((ABMP("ENDDT")'="")&(ABMP("ENDDT")<ABMY("DT",1))) Q
  1.  ...S ABMMFLG=1  ;if it gets here pt has elig in our window
  1.  ..I ABMMFLG=1 D  ;pt has at least one entry that's what we want
  1.  ...S ^TMP($J,"ABM-MURPT","VAMB",ABMP("PDFN"),ABMP("MDFN"))=""
  1.  ...S ^TMP($J,"ABM-MURPT","CNT","VAMB")=+$G(^TMP($J,"ABM-MURPT","CNT","VAMB"))+1  ;cnt VAMB pts
  1.  ;end new VMBP RQMT_103
  1.  ;
  1.  ;no insurance
  1.  S ABMP("PDFN")=0
  1.  F  S ABMP("PDFN")=$O(^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))) Q:'ABMP("PDFN")  D
  1.  .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
  1.  ..S ^TMP($J,"ABM-MURPT","CNT","NO")=+$G(^TMP($J,"ABM-MURPT","CNT","NO"))+1  ;cnt no insurance pts
  1.  ..S ^TMP($J,"ABM-MURPT","NO",ABMP("PDFN"))=""
  1.  ;
  1.  Q
  1.  ;
  1. GETVSTS ;
  1.  S ABMP("SDT")=ABMY("DT",1)-.5
  1.  S ABMP("EDT")=ABMY("DT",2)+.999999
  1.  F  S ABMP("SDT")=$O(^AUPNVSIT("B",ABMP("SDT"))) Q:('ABMP("SDT")!(ABMP("SDT")>ABMP("EDT")))  D
  1.  .S ABMP("VDFN")=0
  1.  .F  S ABMP("VDFN")=$O(^AUPNVSIT("B",ABMP("SDT"),ABMP("VDFN"))) Q:'ABMP("VDFN")  D
  1.  ..S ABMPT=$P($G(^AUPNVSIT(ABMP("VDFN"),0)),U,5)  ;pt
  1.  ..Q:ABMPT=""  ;no patient on visit
  1.  ..I '$D(^TMP($J,"ABM-MURPT","PTS",ABMPT)) Q  ;not one of our pts
  1.  ..S ^TMP($J,"ABM-MURPT","ENC",ABMP("VDFN"))=""
  1.  ..S ^TMP($J,"ABM-MURPT","CNT","ENC")=+$G(^TMP($J,"ABM-MURPT","CNT","ENC"))+1  ;cnt encounters
  1.  ..I '$D(^TMP($J,"ABM-MURPT","UNQ",ABMPT)) D
  1.  ...S ^TMP($J,"ABM-MURPT","UNQ",ABMPT)=""
  1.  ...S ^TMP($J,"ABM-MURPT","CNT","UNQ")=+$G(^TMP($J,"ABM-MURPT","CNT","UNQ"))+1  ;cnt unique pts
  1.  Q
  1.  ;
  1. TOTALS ;
  1.  ;Practice Demographics
  1.  ;# of Patient
  1.  ;Encounters/Year
  1.  ;# of Unique Patients/Year
  1.  S ABM("HD",0)="Meaningful Use Eligibility Report"
  1.  S ABM("PG")=1
  1.  ;start old abm*2.6*15 HEAT119702
  1.  ;D GETPTS
  1.  ;D GETELIG
  1.  ;D GETVSTS
  1.  ;end old HEAT119702
  1.  D WHD
  1.  W !!,"Practice Demographics"
  1.  W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","PTS")),7)_" Patients"
  1.  W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","ENC")),7)_" Encounters"
  1.  W !?2,$J(+$G(^TMP($J,"ABM-MURPT","CNT","UNQ")),7)_" Unique Patients"
  1.  ;
  1.  ;Patient Demographics
  1.  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
  1.  W !!,"Patient Demographics"
  1.  ;medicaid
  1.  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)_"% )"
  1.  ;medicare
  1.  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)_"% )"
  1.  ;railroad
  1.  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)_"% )"
  1.  ;private
  1.  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)_"% )"
  1.  ;no eligibility
  1.  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)_"% )"
  1.  ;start new abm*2.6*11 VMBP#9 RQMT_103
  1.  ;vmbp
  1.  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)_"% )"
  1.  ;end new VMBP#9 RQMT_103
  1.  W !!,"(REPORT COMPLETE)"
  1.  Q
  1.  ;
  1. WRTPTS ;^TMP($J,"ABM-MURPT","PTS",ABMP("PDFN"))
  1.  D WRTPTS^ABMMUEL1
  1.  Q
  1.  ;
  1. WRTELIG ;
  1.  D WRTELIG^ABMMUEL1
  1.  Q
  1.  ;
  1. WRTVSTS ;^TMP($J,"ABM-MURPT","ENC",ABMP("VDFN"))
  1.  D WRTVSTS^ABMMUEL1
  1.  Q
  1. WHD ;EP for writing Report Header
  1.  W $$EN^ABMVDF("IOF"),!
  1.  K ABM("LINE") S $P(ABM("LINE"),"=",$S($D(ABM(132)):132,1:80))="" W ABM("LINE"),!
  1.  D NOW^%DTC  ;abm*2.6*1 NO HEAT
  1.  W ABM("HD",0),?$S($D(ABM(132)):103,1:48) S Y=% X ^DD("DD") W Y,"   Page ",ABM("PG")
  1.  S ABM("HD",1)="For date range: "_$$SDT^ABMDUTL(ABMY("DT",1))_" to "_$$SDT^ABMDUTL(ABMY("DT",2))
  1.  W:$G(ABM("HD",1))]"" !,ABM("HD",1)
  1.  W:$G(ABM("HD",2))]"" !,ABM("HD",2)
  1.  W !,"Billing Location: ",$P($G(^AUTTLOC(DUZ(2),0)),U,2)
  1.  W !,ABM("LINE") K ABM("LINE")
  1.  Q