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

ABMMUFAC.m

Go to the documentation of this file. 
  1. ABMMUFAC ;IHS/SD/SDR - EHR Incentive Report (MU) ;
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**6,7,11,12,15,20**;NOV 12, 2009;Build 317
  1.  ;2.6*12-VMBP RQMT_104 - Added VAMB to report.
  1.  ;2.6*12-Relabeled hdrs to include 'Adult&Ped'; added swingbed
  1.  ;IHS/SD/SDR - 2.6*15 - HEAT183309 
  1.  ;    split routine due to size
  1.  ;    Req#B - added code so paid will still print for 'F' report so changes made for paid will work for both reports
  1.  ;IHS/SD/SDR - 2.6*20 - HEAT256154 - Added IP Ancillary Discharges category.  Added bill type and visit type to detail report.
  1.  ;
  1.  W !!,"This report will calculate the number of Covered Inpatient days for Medicare,"
  1.  W !,"Medicaid, and Private Insurance.  Outpatient All-Inclusive Rate (AIR) bills are"
  1.  W !,"counted.  A report can be selected to view the bills used in the calculations."
  1.  W !!!
  1.  K ABMY,ABMP
  1.  K ^TMP($J,"ABM-MUFAC")
  1.  K ^TMP($J,"ABM-MUVLST")
  1. DTTYP ;
  1.  D ^XBFMK
  1.  ;start new MU2 #8
  1.  S DIR("A")="Run report by FISCAL YEAR, DATE RANGE, or LOOKBACK DATE"
  1.  S DIR(0)="SO^F:FISCAL YEAR;D:DATE RANGE;L:LOOKBACK DATE"
  1.  ;end new MU2 #8
  1.  S DIR("B")="FISCAL YEAR"
  1.  D ^DIR
  1.  Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
  1.  S ABMDTYP=Y
  1.  S ABMY("FACHOS")="F"  ;default to F  ;abm*2.6*11 MU2 #8
  1.  W !
  1.  I ABMDTYP="F" D FDT
  1.  I ABMDTYP="D" D DTR
  1.  ;start new abm*2.6*11 MU2 #8
  1.  I ABMDTYP="L" D
  1.  .D LBK
  1.  Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
  1.  ;start new abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  D GETLOCS
  1.  I +ABMPAR=0 D  H 1  G DTTYP
  1.  .W !!?8,"** There are no active facilities for the date range selected. **"
  1.  .W !?24,"** Please re-select date span. **"
  1.  ;end new abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  D FACHOS
  1.  ;end new MU2 #8
  1.  D RTYPE
  1.  Q
  1. FDT ;
  1.  D ^XBFMK
  1.  S DIR("A")="Select REPORT DATE Fiscal year"
  1.  S DIR(0)="LO^1960:2100:0"
  1.  S DIR("B")=$E($$Y2KD2^ABMDUTL(DT),1,4)
  1.  D ^DIR
  1.  Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
  1.  S ABMY("DT",1)=Y
  1.  W !
  1.  Q
  1. DTR ;
  1.  D ^XBFMK
  1.  S DIR("A")="Enter STARTING Date"
  1.  S DIR(0)="DO^::EP"
  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 DTR:$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 DTR
  1.  Q
  1.  ;start new abm*2.6*11 MU2 #8
  1. LBK ;
  1.  D LBK^ABMMUFC1
  1.  Q
  1. FACHOS ;EP
  1.  D FACHOS^ABMMUFC1
  1.  Q
  1.  ;end new MU2 #8
  1. RTYPE ;sum or dtl?
  1.  W !
  1.  K DIC,DIE,DIR,X,Y,DA
  1.  S DIR(0)="S^S:SUMMARY;D:DETAIL;B:BOTH"
  1.  S DIR("A")="SUMMARY, DETAIL, or BOTH"
  1.  S DIR("B")="SUMMARY"
  1.  D ^DIR K DIR
  1.  Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
  1.  S ABMSUMDT=Y
  1. SEL ;Select device
  1.  I ABMSUMDT="B" 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.  I ABMSUMDT'="D" D
  1.  .S ABMQ("RX")=$S(ABMSUMDT="S":"XIT^ABMMUFAC",1:"XIT2^ABMMUFAC")
  1.  .S ABMQ("NS")="ABM"
  1.  .S ABMQ("RC")="GETTOTS^ABMMUFAC"
  1.  .S ABMQ("RP")="WRTSUM^ABMMUFAC"
  1.  .D ^ABMDRDBQ
  1.  I ABMSUMDT'="S" D
  1.  .W !!,"Will now write detail to file",!!
  1.  .D ^XBFMK
  1.  .;start old abm*2.6*20 IHS/SD/SDR HEAT256154
  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 GETTOTS  ;abm*2.6*7
  1.  .;D WRTDTL^ABMMUFC2
  1.  .;D CLOSE^%ZISH("ABM")
  1.  .;W "DONE" H 1
  1.  .;end old start new abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  .S ABMQ("RX")=$S(ABMSUMDT="S":"XIT^ABMMUFAC",1:"XIT2^ABMMUFAC")
  1.  .S ABMQ("NS")="ABM"
  1.  .S ABMQ("RC")="GETTOTS^ABMMUFAC"
  1.  .S ABMQ("RP")="WRTDTL^ABMMUFC2"
  1.  .D ^ABMDRDBQ
  1.  .;end new abm*2.6*20 IHS/SD/SDR HEAT256154
  1. XIT ;
  1.  K ^TMP($J,"ABM-MUFAC")
  1.  K ^TMP($J,"ABM-MUVLST")
  1.  K ABMP,ABMY,ABMPTINA,ABMPT,ABMMFLG,ABMC,ABMB
  1. XIT2 ;
  1.  Q
  1. QUE ;TASKMAN
  1.  S ZTRTN="WRTDTL^ABMMUFAC"
  1.  S ZTDESC="FACILITY EHR INCENTIVE REPORT"
  1.  S ZTSAVE("ABM*")=""
  1.  K ZTSK
  1.  D ^%ZTLOAD
  1.  W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
  1.  Q
  1. GETTOTS ;
  1.  D GETLOCS
  1.  ;start new abm*2.6*15 HEAT183309 keep 'F' option same as before
  1.  I ABMY("FACHOS")="F" D  Q
  1.  .S ABML=0
  1.  .S ABMDUZ2=DUZ(2)
  1.  .F  S ABML=$O(ABMLOC(ABML)) Q:'ABML  D
  1.  ..S DUZ(2)=ABML
  1.  ..D GETBILLS^ABMMUFC5
  1.  ;
  1.  ;only gets here if 'H' option
  1.  S ABML=0
  1.  S ABMDUZ2=DUZ(2)
  1.  F  S ABML=$O(ABMLOC(ABML)) Q:'ABML  D
  1.  .S DUZ(2)=ABML
  1.  .D GETBILLS^ABMMUFC1
  1.  .D CLAIMS^ABMMUFC3  ;abm*2.6*15 HEAT183309 Req#B
  1.  S DUZ(2)=ABMDUZ2
  1.  D VISITS^ABMMUFC1  ;abm*2.6*15 HEAT183309 Req#B
  1.  Q
  1. GETLOCS ;
  1.  I ABMDTYP="F" D
  1.  .S ABMP("SDT")=((+ABMY("DT",1)-1)_"1001")-17000000
  1.  .S ABMP("EDT")=((+ABMY("DT",1))_"0930")-16999999
  1.  I ABMDTYP="D"!(ABMDTYP="L") D  ;abm*2.6*11 MU2 #8
  1.  .S ABMP("SDT")=ABMY("DT",1)-.5
  1.  .S ABMP("EDT")=ABMY("DT",2)+.999999
  1.  K ABMPSFLG
  1.  S ABMPAR=0
  1.  F  S ABMPAR=$O(^BAR(90052.05,ABMPAR)) Q:+ABMPAR=0  D  Q:($G(ABMPSFLG)=1)
  1.  .I $D(^BAR(90052.05,ABMPAR,DUZ(2))) D
  1.  ..; Use A/R parent/sat is yes, but DUZ(2) is not parent for this 
  1.  ..; visit loc
  1.  ..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,3)'=ABMPAR
  1.  ..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>ABMP("EDT")
  1.  ..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($P(^(0),U,7)<ABMP("SDT"))
  1.  ..S ABMPSFLG=1
  1.  I +ABMPAR=0 Q  ;abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  S ABMLOC(ABMPAR)=""
  1.  S ABML=0
  1.  F  S ABML=$O(^BAR(90052.05,ABMPAR,ABML)) Q:'ABML  D
  1.  .Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>ABMP("EDT")
  1.  .Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($P(^(0),U,7)<ABMP("SDT"))
  1.  .S ABMLOC(ABML)=""
  1.  Q
  1. SETCAT ;
  1.  ;swingbed
  1.  I (ABMSC="H"!(ABMSC="I")),(+$G(ABMP("SWINGBED"))=1)!(($E(ABMP("BTYP"),1,2)=18)&(ABMP("VTYP")'=999)) S ABMP("RPT-CAT")="IP SB DISCHGS" Q  ;abm*2.6*12
  1.  I (ABMSC="H"!(ABMSC="I")),+$G(ABMP("NEWBORN"))=0,($E(ABMP("BTYP"),1,2)=11),(ABMP("VTYP")=111) S ABMP("RPT-CAT")="IP DISCHGS" Q  ;abm*2.6*7
  1.  I (ABMSC="H"!(ABMSC="I")),+$G(ABMP("NEWBORN"))=1,($E(ABMP("BTYP"),1,2)=11),(ABMP("VTYP")=111) S ABMP("RPT-CAT")="IP NB DISCHGS" Q  ;abm*2.6*7
  1.  I (ABMSC="H"!(ABMSC="I")),($E(ABMP("BTYP"),1,2)=11),(ABMP("VTYP")=999) S ABMP("RPT-CAT")="IP CHGS" Q
  1.  I (ABMSC'="H"&(ABMSC'="I")),(($E(ABMP("BTYP"),1,2)=13)!($E(ABMP("BTYP"),1,2)=85)!($E(ABMP("BTYP"),1,2)=73)),(ABMP("VTYP")=131),(ABMFFLG=1) S ABMP("RPT-CAT")="OP AIR" Q
  1.  I (ABMSC'="H"&(ABMSC'="I")),(($E(ABMP("BTYP"),1,2)=13)!($E(ABMP("BTYP"),1,2)=85)!($E(ABMP("BTYP"),1,2)=73)),(ABMP("VTYP")=131),(ABMFFLG=0) S ABMP("RPT-CAT")="OP ITEM" Q
  1.  I (ABMSC'="H"&(ABMSC'="I")),(($E(ABMP("BTYP"),1,2)=13)!($E(ABMP("BTYP"),1,2)=85)!($E(ABMP("BTYP"),1,2)=73)),(ABMP("VTYP")=999) S ABMP("RPT-CAT")="OP CHGS" Q
  1.  I ABMSC="H"!(ABMSC="I"),($E(ABMP("BTYP"),1,2)=12) S ABMP("RPT-CAT")="IP ANC DISCHGS" Q   ;abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  I ABMSC="H"!(ABMSC="I"),($E(ABMP("BTYP"),1,2)'=11) S ABMP("RPT-CAT")="IP CHGS" Q
  1.  I +$G(ABMFFLG)=1 S ABMP("RPT-CAT")="OP AIR" Q
  1.  S ABMP("RPT-CAT")="OP ITEM"
  1.  Q
  1. WRTSUM ;
  1.  I ABMY("FACHOS")="H" D WRTSUMHO^ABMMUFC2 Q  ;abm*2.6*12
  1.  S ABM("HD",0)="FACILITY EHR INCENTIVE REPORT"  ;abm*2.6*7
  1.  S ABM("PG")=1  ;abm*2.6*7
  1.  S ABMTYP="SUM" D WHD
  1.  S CENTER=IOM/2
  1.  S ABMITYP=""
  1.  F ABMITYP="MEDICARE","MEDICAID","PRIVATE","KIDSCARE/CHIP","VMBP","OTHER" D  ;abm*2.6*12 VMBP RQMT_104
  1.  .W !
  1.  .I ABMITYP="PRIVATE" W ?CENTER-($L("-- P R I V A T E  I N S U R A N C E --")/2),"-- P R I V A T E  I N S U R A N C E --"
  1.  .I ABMITYP="MEDICARE" W ?CENTER-($L("-- M E D I C A R E --")/2),"-- M E D I C A R E --"
  1.  .I ABMITYP="MEDICAID" W ?CENTER-($L("-- M E D I C A I D --")/2),"-- M E D I C A I D --"
  1.  .I ABMITYP="KIDSCARE/CHIP" W ?CENTER-($L("-- K I D S C A R E / C H I P --")/2),"-- K I D S C A R E / C H I P --"
  1.  .I ABMITYP="VMBP" W ?CENTER-($L("-- V E T E R A N S  M E D I C A L  B E N  P R O G --")/2),"-- V E T E R A N S  M E D I C A L  B E N  P R O G --"  ;abm*2.6*12 VMBP RQMT_104
  1.  .I ABMITYP="OTHER" W ?CENTER-($L("-- O T H E R --")/2),"-- O T H E R --"
  1.  .W !?4,"# Paid "_ABMITYP_" IP Discharges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP DISCHGS")),20)
  1.  .W !?4,"# Paid "_ABMITYP_" IP Newborn Discharges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP NB DISCHGS")),20)  ;abm*2.6*7
  1.  .;W !?4,"# Paid "_ABMITYP_" IP Charges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP CHGS")),20)  ;abm*2.6*11 MU2 #8
  1.  .W:$G(ABMY("FACHOS"))="F" !?4,"# Paid "_ABMITYP_" IP Charges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP CHGS")),20)  ;abm*2.6*11 MU2 #8
  1.  .W !?4,"# Paid "_ABMITYP_" IP Bed Days",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP DAYS")),20)
  1.  .W !?4,"# Paid "_ABMITYP_" IP Newborn Bed Days",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP NB DAYS")),20)  ;abm*2.6*7
  1.  .W !?4,"# Paid "_ABMITYP_" IP Bed Days Charges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"IP CHGS DAYS")),20)
  1.  .W !?4,"# Paid "_ABMITYP_" OP All-Inclusive",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"OP AIR")),20)
  1.  .W !?4,"# Paid "_ABMITYP_" OP Charges",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"OP CHGS")),20)
  1.  .W !?4,"# Paid "_ABMITYP_" OP Itemized",?59,$J(+$G(^TMP($J,"ABM-MUFAC",ABMITYP,"OP ITEM")),20)
  1.  .I $Y>(IOSL-5) D HD Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)  W " (cont)"
  1.  .W !
  1.  W !!,"(SUMMARY REPORT COMPLETE):"
  1.  D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  S DUZ(2)=ABMDUZ2
  1.  Q
  1. HD D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1. WHD ;EP
  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
  1.  W ABM("HD",0),?$S($D(ABM(132)):103,1:48) S Y=% X ^DD("DD") W Y,$S(ABMTYP="SUM":"   Page "_ABM("PG"),1:"")
  1.  S:ABMDTYP="F" ABM("HD",1)="For FISCAL YEAR: "_+(ABMY("DT",1))
  1.  S:ABMDTYP="D" ABM("HD",1)="For Date Range: "_$$SDT^ABMDUTL(ABMY("DT",1))_" to "_$$SDT^ABMDUTL(ABMY("DT",2))
  1.  S:ABMDTYP="L" ABM("HD",1)="Lookback Date Range: "_$$SDT^ABMDUTL(ABMY("DT",1))_" to "_$$SDT^ABMDUTL(ABMY("DT",2))  ;abm*2.6*11 MU2 #8
  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(ABMPAR,0)),U,2)
  1.  W !,ABM("LINE") K ABM("LINE")
  1.  S ABM("PG")=+$G(ABM("PG"))+1
  1.  I ABMTYP="DET" D
  1.  .;W !,"INSURER CATEGORY"_U_"IP/OP CATEGORY"_U_"INSURER"_U_"INSURER TYPE"  ;abm*2.6*15 HEAT183309 Req#B
  1.  .W !,"INSURER CATEGORY"_U_"RECORD TYPE"_U_"IP/OP CATEGORY"_U_"INSURER"_U_"INSURER TYPE"  ;abm*2.6*15 HEAT183309 Req#B
  1.  .W U_"BILL NUMBER"_U_"ADMIT DT"_U_"DISCHG DT"_U_"AMOUNT BILLED"_U_"PAYMENT"_U_"COVD DAYS"_U_"N-COVD DAYS"
  1.  .;I ABMY("FACHOS")="H" W U_"HRN"_U_"VISIT"_U_"VISIT LOCATION"  ;abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  .I ABMY("FACHOS")="H" W U_"HRN"_U_"VISIT"_U_"VISIT LOCATION"_U_"BILL TYPE"_U_"VISIT TYPE"_U_"ALL INSURER TYPES"_U_"ADMISSION TYPE"  ;abm*2.6*20 IHS/SD/SDR HEAT256154
  1.  .I ABMY("FACHOS")="F" W U_"VISIT"_U_"VISIT LOCATION"
  1.  I ABMTYP="SUM" D
  1.  .;W !?67,"# Discharges",!  ;abm*2.6*15 HEAT183309 Req#A
  1.  .;start new abm*2.6*15 HEAT183309 Req#A
  1.  .I ABMY("FACHOS")="F" D
  1.  ..W !?67,"# Discharges",!
  1.  .;end new HEAT183309 Req#A
  1.  .I ABMY("FACHOS")="H" D
  1.  ..W !?52,"Billed",?63,"Paid",?73,"Total",!  ;abm*2.6*15 HEAT183309 Req#B
  1.  .F ABMI=1:1:80 W "-"
  1.  Q