ABMM2PVH ;IHS/SD/SDR - MU Patient Volume Hospital Report ;
;;2.6;IHS 3P BILLING SYSTEM;**11,12,15**;NOV 12, 2009;Build 251
;IHS/SD/SDR - 2.6*15 - HEAT161159 - Changed PT LST to sort differently so there won't be duplicate vsts on pt lst.
;IHS/SD/SDR - 2.6*15 - HEAT156874 - Change for <SUBSCR>PTDATA+16^ABMM2PV7. Occurs when patient is missing from visit.
;IHS/SD/SDR - 2.6*15 - Added tag XIT and call to it in double queuer so global would get killed; it was hanging around and causing more data to print than should.
;IHS/SD/SDR - 2.6*15 - Changed insurer type FPL to P
;
EN ;
I $P($G(^ABMMUPRM(1,0)),U,2)="" D Q
.W !!,"Setup has not been done. Please do MUP option prior to running any reports",!
.S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
;
K ^XTMP("ABM-PVH2",$J)
K ABMDX
S ABMY("RTYP")="HOS"
D FAC^ABMM2PVP Q:'$D(ABMF)&($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT))
M ABMFAC=ABMF
;
W !!,"In order for an Eligible Hospital (EH) to participate in the Medicaid EHR"
W !,"Incentive program EHs have to meet a minimum patient volume requirement of 10%."
W !!,"For EHs the participation year is based on a federal fiscal year, this is the"
W !,"same year that the EH would be demonstrating Meaningful use. (Federal Fiscal"
W !,"Year is October 1 - September 30.)"
;
D PARTYR^ABMM2PVP Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;part. year
D SELINS^ABMM2PVP
D 90DAY^ABMM2PVP Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;select 90-day
I $G(ABMY("90"))="" K ABMY,ABMF G EN
D RFORMAT^ABMM2PVP Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;summ or pt list
D SUMMARY^ABMM2PVP Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;summ of selections
D ^XBFMK
S DIR(0)="S^P:Print Report;R:Return to Selection Criteria -Erases ALL previous selections"
S DIR("A")="<P> to Print or <R> to Reselect"
I ABMY("RFMT")="P" D
.S DIR(0)="S^P:Print Report;H:Print Delimited Report to the HOST FILE;R:Return to Selection Criteria -Erases ALL previous selections"
.S DIR("A")="<P> to Print, <H> to Host File, or <R> to Reselect"
D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
I $P(Y,U)="R" K ABMY,ABMF G EN
I $P(Y,U)="H" D Q ;HFS -prompt path/filename
.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
.I $G(Y)["^" S POP=1 Q
.S ABMPATH=$S($G(Y)="":ABMPATH,1:Y)
.D ^XBFMK
.S DIR(0)="F"
.S DIR("A")="Enter filename"
.D ^DIR K DIR
.I $G(Y)["^" S POP=1 Q
.S ABMFN=Y
.D COMPUTE^ABMM2PVH
;S ABMQ("RX")="POUT^ABMDRUTL" ;abm*2.6*15
S ABMQ("RX")="XIT^ABMM2PVP" ;made it so report has its own exit routine ;abm*2.6*15
S ABMQ("NS")="ABM"
S ABMQ("RP")="COMPUTE^ABMM2PVH"
D ^ABMDRDBQ
Q
;start new abm*2.6*15
XIT ;EP - exit option for report
D ^XBFMK
K ^XTMP("ABM-PVH2",$J)
Q
;end new abm*2.6*15
COMPUTE ;EP - gather data
;specified 90-day
I ABMY("90")="B" D Q
.S X1=ABMY("SDT")
.S X2=89
.D C^%DTC
.S ABMY("EDT")=X
.D VISITS
.D BILLS
.D ENROLL
.D CALC
.D PRINT
;
;User specified
I ABMY("90")="C" D Q
.D VISITS
.D BILLS
.D ENROLL
.D CALC
.D PRINT
;
;automated
I ABMY("90")="A" D
.S ABMY("SDT")=(ABMY("QYR")-1701)_"1001"
.S ABMY("EDT")=(ABMY("QYR")-1700)_"0930"
D VISITS
D BILLS
D ENROLL
D CALC
;
D PRINT
Q
VISITS ;
S ABMFILE="AUPNVINP"
S ABMSDT=ABMY("SDT")
S ABMEDT=ABMY("EDT")+.999999
F S ABMSDT=$O(^AUPNVINP("B",ABMSDT)) Q:'ABMSDT!(ABMSDT>ABMEDT) D
.S ABMVIEN=0
.F S ABMVIEN=$O(^AUPNVINP("B",ABMSDT,ABMVIEN)) Q:'ABMVIEN D
..S ABMVDFN=$$GET1^DIQ(9000010.02,ABMVIEN,.03,"I")
..S ABMSCAT=$$GET1^DIQ(9000010,ABMVDFN,.07,"I") ;service cat
..S ABMCLNC=$$GET1^DIQ(9000010,ABMVDFN,.08,"I") ;clinic
..Q:$$GET1^DIQ(9000010,ABMVDFN,".05","E")["DEMO,PATIENT" ;abm*2.6*15 HEAT161159 remove demo patients from list
..S ABMPT=$$GET1^DIQ(9000010,ABMVDFN,.05,"I") ;pt
..S ABMP("VDT")=$P($$GET1^DIQ(9000010.02,ABMVIEN,.01,"I"),".") ;disch dt
..D VISITCK
S ABMSDT=ABMY("SDT")
S ABMEDT=ABMY("EDT")+.999999
S ABMFILE="AUPNVSIT"
F S ABMSDT=$O(^AUPNVSIT("B",ABMSDT)) Q:'ABMSDT!(ABMSDT>ABMEDT) D
.S ABMVDFN=0
.F S ABMVDFN=$O(^AUPNVSIT("B",ABMSDT,ABMVDFN)) Q:'ABMVDFN D
..I ($D(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN))) Q ;already cnt'ed this vst on rpt
..S ABMSCAT=$$GET1^DIQ(9000010,ABMVDFN,.07,"I") ;service cat
..S ABMCLNC=$$GET1^DIQ(9000010,ABMVDFN,.08,"I") ;clinic
..Q:$$GET1^DIQ(9000010,ABMVDFN,".05","E")["DEMO,PATIENT" ;abm*2.6*15 HEAT161159 remove demo patients from list
..S ABMPT=$$GET1^DIQ(9000010,ABMVDFN,.05,"I") ;pt
..S ABMP("VDT")=$P($$GET1^DIQ(9000010,ABMVDFN,.01,"I"),".") ;vst dt
..D VISITCK
Q
VISITCK ;EP
;serv cat MUST be H, or (A w/clinic=30)
K ABMFLG,ABMCKDT
I ABMFILE="AUPNVINP",ABMSCAT="H" S ABMFLG=1
I (ABMFILE="AUPNVSIT")&((ABMSCAT="A")&(ABMCLNC=30)) S ABMFLG=1
Q:(+$G(ABMFLG)=0)
S ABMVLOC=$$GET1^DIQ(9000010,ABMVDFN,.06,"I")
;I ($$GET1^DIQ(9000010,ABMVDFN,.12)'="")&(ABMSDT>$$GET1^DIQ(9000010,ABMVDFN,.12,"I")&($$GET1^DIQ(9000010,ABMVDFN,1111,"I")'="R")) Q
I (ABMFILE="AUPNVSIT")&($$GET1^DIQ(9000010,ABMVDFN,.12)'="")&($$GET1^DIQ(9000010,$$GET1^DIQ(9000010,ABMVDFN,.12,"I"),1111,"I")'="R") Q
I (ABMFILE="AUPNVSIT")&($$GET1^DIQ(9000010,ABMVDFN,.12)="")&($$GET1^DIQ(9000010,ABMVDFN,1111,"I")'="R") Q
Q:'$D(ABMF(ABMVLOC)) ;not selected loc
D CALCDTS^ABMM2PV1
S ABMDTFLG=0
S ABMP("BDT")=ABMP("BSDT")
F D Q:ABMDTFLG=1
.I ABMP("VDT")<ABMP("BSDT") Q ;vst is before 90-day window
.S ^XTMP("ABM-PVH2",$J,"LOC-DENOM",ABMP("BDT"))=+$G(^XTMP("ABM-PVH2",$J,"LOC-DENOM",ABMP("BDT")))+1
.S ^XTMP("ABM-PVH2",$J,"LOC-DENOM",ABMP("BDT"),ABMVLOC)=+$G(^XTMP("ABM-PVH2",$J,"LOC-DENOM",ABMP("BDT"),ABMVLOC))+1
.S ^XTMP("ABM-PVH2",$J,"PT VSTS",ABMPT,ABMSDT,ABMVDFN)="" ;list of vsts by pt,DOS
.S ^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)="" ;list of vsts to chk for pymt
.S ^XTMP("ABM-PVH2",$J,"VISIT CNT",ABMP("BDT"))=+$G(^XTMP("ABM-PVH2",$J,"VISIT CNT",ABMP("BDT")))+1 ;cnt of vsts
.S ^XTMP("ABM-PVH2",$J,"ALL VISITS",ABMP("BDT"),ABMVDFN)="" ;list of all vsts looked at
.S ^XTMP("ABM-PVH2",$J,"ALL VISIT CNT")=+$G(^XTMP("ABM-PVH2",$J,"ALL VISIT CNT"))+1 ;cnt all vsts
.;I ^XTMP("ABM-PVH2",$J,"ALL VISIT CNT")#1000 U IO(0) W "." ;abm*2.6*15
.I (^XTMP("ABM-PVH2",$J,"ALL VISIT CNT")#1000&(IOST["C")) U IO(0) W "." ;abm*2.6*15 only write dots if to screen; was writing dots to HFS file
.K ABMITYP,ABMDX
.D PTDATA
.S X1=ABMP("BDT")
.S X2=1
.D C^%DTC
.I X>ABMP("BEDT") S ABMDTFLG=1 Q
.S ABMP("BDT")=X
Q
BILLS ;EP
S ABMCNT=0
S ABMDUZ2=0
S ABMFOUND=0
F S ABMDUZ2=$O(^ABMDBILL(ABMDUZ2)) Q:'ABMDUZ2 D
.Q:'$D(^ABMDBILL(ABMDUZ2,0))
.S ABMVDFN=0
.F S ABMVDFN=$O(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)) Q:'ABMVDFN D
..I (+$G(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)))=1 Q ;already cnt'd this vst on rpt
..Q:'$D(^ABMDBILL(ABMDUZ2,"AV",ABMVDFN)) ;vst not under this DUZ(2)
..K ABMBILLN,ABMSAV
..S ABMP("BDFN")=0
..F S ABMP("BDFN")=$O(^ABMDBILL(ABMDUZ2,"AV",ABMVDFN,ABMP("BDFN"))) Q:'ABMP("BDFN") D Q:(+$G(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)))=1
...S (ABMBILLN,ABMSAV)=$P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U)
...I $P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,4)="X" Q
...S ABMSDT=$P($$GET1^DIQ(9000010,ABMVDFN,".01","I"),".")
...I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),U,3)'=0 S ABMSDT=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),U,3)
...S ABMVLOC=$P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,3)
...S ABMP("VDT")=$P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),7)),U)
...S ABMINS=$P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,8)
...S ABMPT=$P($G(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,5)
...K ABMDX
...D PRIMPOV^ABMM2PV7
...D ARBILLS
...I +$G(ABMFOUND)=1 D OTHERVST ;chk for other vsts on DOS to mark as pd
..;
..;now look thru bills found & remove zero pays when pymt found
..S ABMP("BDT")=0
..F S ABMP("BDT")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM PD BILLS",ABMP("BDT"))) Q:'ABMP("BDT") D
...S ABMGRP=""
...F S ABMGRP=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP)) Q:ABMGRP="" D
....S ABMP("VDFN")=0
....F S ABMP("VDFN")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"))) Q:'ABMP("VDFN") D
.....S ABMP("BDFN")=0
.....F S ABMP("BDFN")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
......I $D(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN"))) D
.......K ^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN"))
......S ^XTMP("ABM-PVH2",$J,"LOC-NUM PD",ABMP("BDT"),ABMGRP)=+$G(^XTMP("ABM-PVH2",$J,"LOC-NUM PD",ABMP("BDT"),ABMGRP))+1
......S ^XTMP("ABM-PVH2",$J,"LOC-NUM PD",ABMP("BDT"),ABMVLOC,ABMGRP)=+$G(^XTMP("ABM-PVH2",$J,"LOC-NUM PD",ABMP("BDT"),ABMVLOC,ABMGRP))+1
..K ^XTMP("ABM-PVH2",$J,"LOC-NUM PD BILLS")
..;
..S ABMP("BDT")=0
..F S ABMP("BDT")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"))) Q:'ABMP("BDT") D
...S ABMGRP=""
...F S ABMGRP=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP)) Q:ABMGRP="" D
....S ABMP("VDFN")=0
....F S ABMP("VDFN")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"))) Q:'ABMP("VDFN") D
.....S ABMP("BDFN")=0
.....F S ABMP("BDFN")=$O(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
......S ^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD",ABMP("BDT"),ABMVLOC,ABMGRP)=+$G(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD",ABMP("BDT"),ABMVLOC,ABMGRP))+1
......S ^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD",ABMP("BDT"),ABMGRP)=+$G(^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD",ABMP("BDT"),ABMGRP))+1
..K ^XTMP("ABM-PVH2",$J,"LOC-NUM ZEROPD BILLS")
Q
ARBILLS ;EP
S ABMBILLN=+ABMBILLN_" "
S ABMSAV=+ABMSAV
F S ABMBILLN=$O(^BARBL(ABMPAR,"B",ABMBILLN)) Q:$G(ABMBILLN)=""!(ABMBILLN'[ABMSAV) D Q:(+$G(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)))=1
.S ABMARIEN=0
.S ABMHOLD=DUZ(2)
.S DUZ(2)=ABMPAR
.F S ABMARIEN=$O(^BARBL(DUZ(2),"B",ABMBILLN,ABMARIEN)) Q:'ABMARIEN D Q:(+$G(^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)))=1
..S ABMARACT=$$GET1^DIQ(90050.01,ABMARIEN_",",3,"I") ;A/R BILL, A/R ACCOUNT
..K ABMTRAMT,ABMTRIEN
..S D0=ABMARACT
..S ABMITYP=$$VALI^BARVPM(8) ;GET 'VIP INSURER TYPE' CODE
..I ABMITYP="FPL" S ABMITYP="P" ;change FPL to P abm*2.6*15 HEAT161159
..S ABMGRP=$S(ABMITYP="D":"MCD",$D(ABMI("INS",ABMINS)):"CHIP",1:"OTHR")
..S ABMABILN=$P($G(^BARBL(DUZ(2),ABMARIEN,0)),U)
..;I "^MCD^CHIP^"'[("^"_ABMGRP_"^") Q
..;S ^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)=1
..I "^MCD^CHIP^"[("^"_ABMGRP_"^") S ^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)=1
..I "^MCD^CHIP^"'[("^"_ABMGRP_"^") S ^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)=2
..;
..D CALCDTS^ABMM2PV1
..S ABMDTFLG=0
..S ABMP("BDT")=ABMP("BSDT")
..F D Q:ABMDTFLG=1
...I (ABMCNT#1000&(IOST["C")) W "."
...S ABMCNT=+$G(ABMCNT)+1
...D PTDATA
...S X1=ABMP("BDT")
...S X2=1
...D C^%DTC
...I X>ABMP("BEDT") S ABMDTFLG=1 Q
...S ABMP("BDT")=X
..;
..D TRANS
..S DUZ(2)=ABMHOLD
Q
TRANS ;EP
D TRANS^ABMM2PH3 ;abm*2.6*15 split routine due to size
Q
ZEROPD ;EP
D ZEROPD^ABMM2PH3 ;abm*2.6*15 split routine due to size
Q
OTHERVST ;EP
D OTHERVST^ABMM2PH3 ;abm*2.6*15 split routine due to size
Q
PTDATA ;EP
D PTDATA^ABMM2PH3 ;abm*2.6*15 split routine due to size
Q
CALC ;EP
D CALC^ABMM2PH2
Q
PRINT ;EP
I ABMY("RFMT")="P",$G(ABMFN)'="" D PTHSTFL^ABMM2PH1 Q
S ABMVLOC=0
F S ABMVLOC=$O(ABMFAC(ABMVLOC)) Q:'ABMVLOC D D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.S ABM("PG")=1
.S ABMSDT=$P($G(^XTMP("ABM-PVH2",$J,"LOC TOP",ABMVLOC)),U,2)
.I +$G(^XTMP("ABM-PVH2",$J,"LOC TOP",ABMVLOC))>9.5 S ABMPMET=1
.D HDR^ABMM2PV3
.W !,"Hospital used in this report: ",$$GET1^DIQ(9999999.06,ABMVLOC,.01,"E"),$S($D(^ABMMUPRM(1,1,"B",ABMVLOC)):" (FQHC/RHC/Tribal/Urban)",1:""),!
.S ABMPMET=0
.I ABMY("RFMT")="P" D PATIENT^ABMM2PH1 Q
.I +$G(^XTMP("ABM-PVH2",$J,"LOC TOP",ABMVLOC))>9.5 D MET^ABMM2PH1 Q
.D NOTMET^ABMM2PH1
K ^XTMP("ABM-PVH2",$J)
Q
ENROLL ;EP
D ENROLL^ABMM2PH2
Q
ABMM2PVH ;IHS/SD/SDR - MU Patient Volume Hospital Report ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**11,12,15**;NOV 12, 2009;Build 251
+2 ;IHS/SD/SDR - 2.6*15 - HEAT161159 - Changed PT LST to sort differently so there won't be duplicate vsts on pt lst.
+3 ;IHS/SD/SDR - 2.6*15 - HEAT156874 - Change for <SUBSCR>PTDATA+16^ABMM2PV7. Occurs when patient is missing from visit.
+4 ;IHS/SD/SDR - 2.6*15 - Added tag XIT and call to it in double queuer so global would get killed; it was hanging around and causing more data to print than should.
+5 ;IHS/SD/SDR - 2.6*15 - Changed insurer type FPL to P
+6 ;
EN ;
+1 IF $PIECE($GET(^ABMMUPRM(1,0)),U,2)=""
Begin DoDot:1
+2 WRITE !!,"Setup has not been done. Please do MUP option prior to running any reports",!
+3 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+4 ;
+5 KILL ^XTMP("ABM-PVH2",$JOB)
+6 KILL ABMDX
+7 SET ABMY("RTYP")="HOS"
+8 DO FAC^ABMM2PVP
IF '$DATA(ABMF)&($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT))
QUIT
+9 MERGE ABMFAC=ABMF
+10 ;
+11 WRITE !!,"In order for an Eligible Hospital (EH) to participate in the Medicaid EHR"
+12 WRITE !,"Incentive program EHs have to meet a minimum patient volume requirement of 10%."
+13 WRITE !!,"For EHs the participation year is based on a federal fiscal year, this is the"
+14 WRITE !,"same year that the EH would be demonstrating Meaningful use. (Federal Fiscal"
+15 WRITE !,"Year is October 1 - September 30.)"
+16 ;
+17 ;part. year
DO PARTYR^ABMM2PVP
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+18 DO SELINS^ABMM2PVP
+19 ;select 90-day
DO 90DAY^ABMM2PVP
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+20 IF $GET(ABMY("90"))=""
KILL ABMY,ABMF
GOTO EN
+21 ;summ or pt list
DO RFORMAT^ABMM2PVP
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+22 ;summ of selections
DO SUMMARY^ABMM2PVP
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+23 DO ^XBFMK
+24 SET DIR(0)="S^P:Print Report;R:Return to Selection Criteria -Erases ALL previous selections"
+25 SET DIR("A")="<P> to Print or <R> to Reselect"
+26 IF ABMY("RFMT")="P"
Begin DoDot:1
+27 SET DIR(0)="S^P:Print Report;H:Print Delimited Report to the HOST FILE;R:Return to Selection Criteria -Erases ALL previous selections"
+28 SET DIR("A")="<P> to Print, <H> to Host File, or <R> to Reselect"
End DoDot:1
+29 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+30 IF $PIECE(Y,U)="R"
KILL ABMY,ABMF
GOTO EN
+31 ;HFS -prompt path/filename
IF $PIECE(Y,U)="H"
Begin DoDot:1
+32 DO ^XBFMK
+33 SET DIR(0)="F"
+34 SET DIR("A")="Enter Path"
+35 SET DIR("B")=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),"^",7)
+36 DO ^DIR
KILL DIR
+37 IF $GET(Y)["^"
SET POP=1
QUIT
+38 SET ABMPATH=$SELECT($GET(Y)="":ABMPATH,1:Y)
+39 DO ^XBFMK
+40 SET DIR(0)="F"
+41 SET DIR("A")="Enter filename"
+42 DO ^DIR
KILL DIR
+43 IF $GET(Y)["^"
SET POP=1
QUIT
+44 SET ABMFN=Y
+45 DO COMPUTE^ABMM2PVH
End DoDot:1
QUIT
+46 ;S ABMQ("RX")="POUT^ABMDRUTL" ;abm*2.6*15
+47 ;made it so report has its own exit routine ;abm*2.6*15
SET ABMQ("RX")="XIT^ABMM2PVP"
+48 SET ABMQ("NS")="ABM"
+49 SET ABMQ("RP")="COMPUTE^ABMM2PVH"
+50 DO ^ABMDRDBQ
+51 QUIT
+52 ;start new abm*2.6*15
XIT ;EP - exit option for report
+1 DO ^XBFMK
+2 KILL ^XTMP("ABM-PVH2",$JOB)
+3 QUIT
+4 ;end new abm*2.6*15
COMPUTE ;EP - gather data
+1 ;specified 90-day
+2 IF ABMY("90")="B"
Begin DoDot:1
+3 SET X1=ABMY("SDT")
+4 SET X2=89
+5 DO C^%DTC
+6 SET ABMY("EDT")=X
+7 DO VISITS
+8 DO BILLS
+9 DO ENROLL
+10 DO CALC
+11 DO PRINT
End DoDot:1
QUIT
+12 ;
+13 ;User specified
+14 IF ABMY("90")="C"
Begin DoDot:1
+15 DO VISITS
+16 DO BILLS
+17 DO ENROLL
+18 DO CALC
+19 DO PRINT
End DoDot:1
QUIT
+20 ;
+21 ;automated
+22 IF ABMY("90")="A"
Begin DoDot:1
+23 SET ABMY("SDT")=(ABMY("QYR")-1701)_"1001"
+24 SET ABMY("EDT")=(ABMY("QYR")-1700)_"0930"
End DoDot:1
+25 DO VISITS
+26 DO BILLS
+27 DO ENROLL
+28 DO CALC
+29 ;
+30 DO PRINT
+31 QUIT
VISITS ;
+1 SET ABMFILE="AUPNVINP"
+2 SET ABMSDT=ABMY("SDT")
+3 SET ABMEDT=ABMY("EDT")+.999999
+4 FOR
SET ABMSDT=$ORDER(^AUPNVINP("B",ABMSDT))
IF 'ABMSDT!(ABMSDT>ABMEDT)
QUIT
Begin DoDot:1
+5 SET ABMVIEN=0
+6 FOR
SET ABMVIEN=$ORDER(^AUPNVINP("B",ABMSDT,ABMVIEN))
IF 'ABMVIEN
QUIT
Begin DoDot:2
+7 SET ABMVDFN=$$GET1^DIQ(9000010.02,ABMVIEN,.03,"I")
+8 ;service cat
SET ABMSCAT=$$GET1^DIQ(9000010,ABMVDFN,.07,"I")
+9 ;clinic
SET ABMCLNC=$$GET1^DIQ(9000010,ABMVDFN,.08,"I")
+10 ;abm*2.6*15 HEAT161159 remove demo patients from list
IF $$GET1^DIQ(9000010,ABMVDFN,".05","E")["DEMO,PATIENT"
QUIT
+11 ;pt
SET ABMPT=$$GET1^DIQ(9000010,ABMVDFN,.05,"I")
+12 ;disch dt
SET ABMP("VDT")=$PIECE($$GET1^DIQ(9000010.02,ABMVIEN,.01,"I"),".")
+13 DO VISITCK
End DoDot:2
End DoDot:1
+14 SET ABMSDT=ABMY("SDT")
+15 SET ABMEDT=ABMY("EDT")+.999999
+16 SET ABMFILE="AUPNVSIT"
+17 FOR
SET ABMSDT=$ORDER(^AUPNVSIT("B",ABMSDT))
IF 'ABMSDT!(ABMSDT>ABMEDT)
QUIT
Begin DoDot:1
+18 SET ABMVDFN=0
+19 FOR
SET ABMVDFN=$ORDER(^AUPNVSIT("B",ABMSDT,ABMVDFN))
IF 'ABMVDFN
QUIT
Begin DoDot:2
+20 ;already cnt'ed this vst on rpt
IF ($DATA(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)))
QUIT
+21 ;service cat
SET ABMSCAT=$$GET1^DIQ(9000010,ABMVDFN,.07,"I")
+22 ;clinic
SET ABMCLNC=$$GET1^DIQ(9000010,ABMVDFN,.08,"I")
+23 ;abm*2.6*15 HEAT161159 remove demo patients from list
IF $$GET1^DIQ(9000010,ABMVDFN,".05","E")["DEMO,PATIENT"
QUIT
+24 ;pt
SET ABMPT=$$GET1^DIQ(9000010,ABMVDFN,.05,"I")
+25 ;vst dt
SET ABMP("VDT")=$PIECE($$GET1^DIQ(9000010,ABMVDFN,.01,"I"),".")
+26 DO VISITCK
End DoDot:2
End DoDot:1
+27 QUIT
VISITCK ;EP
+1 ;serv cat MUST be H, or (A w/clinic=30)
+2 KILL ABMFLG,ABMCKDT
+3 IF ABMFILE="AUPNVINP"
IF ABMSCAT="H"
SET ABMFLG=1
+4 IF (ABMFILE="AUPNVSIT")&((ABMSCAT="A")&(ABMCLNC=30))
SET ABMFLG=1
+5 IF (+$GET(ABMFLG)=0)
QUIT
+6 SET ABMVLOC=$$GET1^DIQ(9000010,ABMVDFN,.06,"I")
+7 ;I ($$GET1^DIQ(9000010,ABMVDFN,.12)'="")&(ABMSDT>$$GET1^DIQ(9000010,ABMVDFN,.12,"I")&($$GET1^DIQ(9000010,ABMVDFN,1111,"I")'="R")) Q
+8 IF (ABMFILE="AUPNVSIT")&($$GET1^DIQ(9000010,ABMVDFN,.12)'="")&($$GET1^DIQ(9000010,$$GET1^DIQ(9000010,ABMVDFN,.12,"I"),1111,"I")'="R")
QUIT
+9 IF (ABMFILE="AUPNVSIT")&($$GET1^DIQ(9000010,ABMVDFN,.12)="")&($$GET1^DIQ(9000010,ABMVDFN,1111,"I")'="R")
QUIT
+10 ;not selected loc
IF '$DATA(ABMF(ABMVLOC))
QUIT
+11 DO CALCDTS^ABMM2PV1
+12 SET ABMDTFLG=0
+13 SET ABMP("BDT")=ABMP("BSDT")
+14 FOR
Begin DoDot:1
+15 ;vst is before 90-day window
IF ABMP("VDT")<ABMP("BSDT")
QUIT
+16 SET ^XTMP("ABM-PVH2",$JOB,"LOC-DENOM",ABMP("BDT"))=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-DENOM",ABMP("BDT")))+1
+17 SET ^XTMP("ABM-PVH2",$JOB,"LOC-DENOM",ABMP("BDT"),ABMVLOC)=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-DENOM",ABMP("BDT"),ABMVLOC))+1
+18 ;list of vsts by pt,DOS
SET ^XTMP("ABM-PVH2",$JOB,"PT VSTS",ABMPT,ABMSDT,ABMVDFN)=""
+19 ;list of vsts to chk for pymt
SET ^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)=""
+20 ;cnt of vsts
SET ^XTMP("ABM-PVH2",$JOB,"VISIT CNT",ABMP("BDT"))=+$GET(^XTMP("ABM-PVH2",$JOB,"VISIT CNT",ABMP("BDT")))+1
+21 ;list of all vsts looked at
SET ^XTMP("ABM-PVH2",$JOB,"ALL VISITS",ABMP("BDT"),ABMVDFN)=""
+22 ;cnt all vsts
SET ^XTMP("ABM-PVH2",$JOB,"ALL VISIT CNT")=+$GET(^XTMP("ABM-PVH2",$JOB,"ALL VISIT CNT"))+1
+23 ;I ^XTMP("ABM-PVH2",$J,"ALL VISIT CNT")#1000 U IO(0) W "." ;abm*2.6*15
+24 ;abm*2.6*15 only write dots if to screen; was writing dots to HFS file
IF (^XTMP("ABM-PVH2",$JOB,"ALL VISIT CNT")#1000&(IOST["C"))
USE IO(0)
WRITE "."
+25 KILL ABMITYP,ABMDX
+26 DO PTDATA
+27 SET X1=ABMP("BDT")
+28 SET X2=1
+29 DO C^%DTC
+30 IF X>ABMP("BEDT")
SET ABMDTFLG=1
QUIT
+31 SET ABMP("BDT")=X
End DoDot:1
IF ABMDTFLG=1
QUIT
+32 QUIT
BILLS ;EP
+1 SET ABMCNT=0
+2 SET ABMDUZ2=0
+3 SET ABMFOUND=0
+4 FOR
SET ABMDUZ2=$ORDER(^ABMDBILL(ABMDUZ2))
IF 'ABMDUZ2
QUIT
Begin DoDot:1
+5 IF '$DATA(^ABMDBILL(ABMDUZ2,0))
QUIT
+6 SET ABMVDFN=0
+7 FOR
SET ABMVDFN=$ORDER(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN))
IF 'ABMVDFN
QUIT
Begin DoDot:2
+8 ;already cnt'd this vst on rpt
IF (+$GET(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)))=1
QUIT
+9 ;vst not under this DUZ(2)
IF '$DATA(^ABMDBILL(ABMDUZ2,"AV",ABMVDFN))
QUIT
+10 KILL ABMBILLN,ABMSAV
+11 SET ABMP("BDFN")=0
+12 FOR
SET ABMP("BDFN")=$ORDER(^ABMDBILL(ABMDUZ2,"AV",ABMVDFN,ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:3
+13 SET (ABMBILLN,ABMSAV)=$PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U)
+14 IF $PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,4)="X"
QUIT
+15 SET ABMSDT=$PIECE($$GET1^DIQ(9000010,ABMVDFN,".01","I"),".")
+16 IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),U,3)'=0
SET ABMSDT=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),U,3)
+17 SET ABMVLOC=$PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,3)
+18 SET ABMP("VDT")=$PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),7)),U)
+19 SET ABMINS=$PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,8)
+20 SET ABMPT=$PIECE($GET(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0)),U,5)
+21 KILL ABMDX
+22 DO PRIMPOV^ABMM2PV7
+23 DO ARBILLS
+24 ;chk for other vsts on DOS to mark as pd
IF +$GET(ABMFOUND)=1
DO OTHERVST
End DoDot:3
IF (+$GET(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)))=1
QUIT
+25 ;
+26 ;now look thru bills found & remove zero pays when pymt found
+27 SET ABMP("BDT")=0
+28 FOR
SET ABMP("BDT")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD BILLS",ABMP("BDT")))
IF 'ABMP("BDT")
QUIT
Begin DoDot:3
+29 SET ABMGRP=""
+30 FOR
SET ABMGRP=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP))
IF ABMGRP=""
QUIT
Begin DoDot:4
+31 SET ABMP("VDFN")=0
+32 FOR
SET ABMP("VDFN")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN")))
IF 'ABMP("VDFN")
QUIT
Begin DoDot:5
+33 SET ABMP("BDFN")=0
+34 FOR
SET ABMP("BDFN")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:6
+35 IF $DATA(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN")))
Begin DoDot:7
+36 KILL ^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN"))
End DoDot:7
+37 SET ^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD",ABMP("BDT"),ABMGRP)=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD",ABMP("BDT"),ABMGRP))+1
+38 SET ^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD",ABMP("BDT"),ABMVLOC,ABMGRP)=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD",ABMP("BDT"),ABMVLOC,ABMGRP))+1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+39 KILL ^XTMP("ABM-PVH2",$JOB,"LOC-NUM PD BILLS")
+40 ;
+41 SET ABMP("BDT")=0
+42 FOR
SET ABMP("BDT")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT")))
IF 'ABMP("BDT")
QUIT
Begin DoDot:3
+43 SET ABMGRP=""
+44 FOR
SET ABMGRP=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP))
IF ABMGRP=""
QUIT
Begin DoDot:4
+45 SET ABMP("VDFN")=0
+46 FOR
SET ABMP("VDFN")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN")))
IF 'ABMP("VDFN")
QUIT
Begin DoDot:5
+47 SET ABMP("BDFN")=0
+48 FOR
SET ABMP("BDFN")=$ORDER(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS",ABMP("BDT"),ABMGRP,ABMP("VDFN"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:6
+49 SET ^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD",ABMP("BDT"),ABMVLOC,ABMGRP)=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD",ABMP("BDT"),ABMVLOC,ABMGRP))+1
+50 SET ^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD",ABMP("BDT"),ABMGRP)=+$GET(^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD",ABMP("BDT"),ABMGRP))+1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+51 KILL ^XTMP("ABM-PVH2",$JOB,"LOC-NUM ZEROPD BILLS")
End DoDot:2
End DoDot:1
+52 QUIT
ARBILLS ;EP
+1 SET ABMBILLN=+ABMBILLN_" "
+2 SET ABMSAV=+ABMSAV
+3 FOR
SET ABMBILLN=$ORDER(^BARBL(ABMPAR,"B",ABMBILLN))
IF $GET(ABMBILLN)=""!(ABMBILLN'[ABMSAV)
QUIT
Begin DoDot:1
+4 SET ABMARIEN=0
+5 SET ABMHOLD=DUZ(2)
+6 SET DUZ(2)=ABMPAR
+7 FOR
SET ABMARIEN=$ORDER(^BARBL(DUZ(2),"B",ABMBILLN,ABMARIEN))
IF 'ABMARIEN
QUIT
Begin DoDot:2
+8 ;A/R BILL, A/R ACCOUNT
SET ABMARACT=$$GET1^DIQ(90050.01,ABMARIEN_",",3,"I")
+9 KILL ABMTRAMT,ABMTRIEN
+10 SET D0=ABMARACT
+11 ;GET 'VIP INSURER TYPE' CODE
SET ABMITYP=$$VALI^BARVPM(8)
+12 ;change FPL to P abm*2.6*15 HEAT161159
IF ABMITYP="FPL"
SET ABMITYP="P"
+13 SET ABMGRP=$SELECT(ABMITYP="D":"MCD",$DATA(ABMI("INS",ABMINS)):"CHIP",1:"OTHR")
+14 SET ABMABILN=$PIECE($GET(^BARBL(DUZ(2),ABMARIEN,0)),U)
+15 ;I "^MCD^CHIP^"'[("^"_ABMGRP_"^") Q
+16 ;S ^XTMP("ABM-PVH2",$J,"VISITS",ABMVDFN)=1
+17 IF "^MCD^CHIP^"[("^"_ABMGRP_"^")
SET ^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)=1
+18 IF "^MCD^CHIP^"'[("^"_ABMGRP_"^")
SET ^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)=2
+19 ;
+20 DO CALCDTS^ABMM2PV1
+21 SET ABMDTFLG=0
+22 SET ABMP("BDT")=ABMP("BSDT")
+23 FOR
Begin DoDot:3
+24 IF (ABMCNT#1000&(IOST["C"))
WRITE "."
+25 SET ABMCNT=+$GET(ABMCNT)+1
+26 DO PTDATA
+27 SET X1=ABMP("BDT")
+28 SET X2=1
+29 DO C^%DTC
+30 IF X>ABMP("BEDT")
SET ABMDTFLG=1
QUIT
+31 SET ABMP("BDT")=X
End DoDot:3
IF ABMDTFLG=1
QUIT
+32 ;
+33 DO TRANS
+34 SET DUZ(2)=ABMHOLD
End DoDot:2
IF (+$GET(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)))=1
QUIT
End DoDot:1
IF (+$GET(^XTMP("ABM-PVH2",$JOB,"VISITS",ABMVDFN)))=1
QUIT
+35 QUIT
TRANS ;EP
+1 ;abm*2.6*15 split routine due to size
DO TRANS^ABMM2PH3
+2 QUIT
ZEROPD ;EP
+1 ;abm*2.6*15 split routine due to size
DO ZEROPD^ABMM2PH3
+2 QUIT
OTHERVST ;EP
+1 ;abm*2.6*15 split routine due to size
DO OTHERVST^ABMM2PH3
+2 QUIT
PTDATA ;EP
+1 ;abm*2.6*15 split routine due to size
DO PTDATA^ABMM2PH3
+2 QUIT
CALC ;EP
+1 DO CALC^ABMM2PH2
+2 QUIT
PRINT ;EP
+1 IF ABMY("RFMT")="P"
IF $GET(ABMFN)'=""
DO PTHSTFL^ABMM2PH1
QUIT
+2 SET ABMVLOC=0
+3 FOR
SET ABMVLOC=$ORDER(ABMFAC(ABMVLOC))
IF 'ABMVLOC
QUIT
Begin DoDot:1
+4 SET ABM("PG")=1
+5 SET ABMSDT=$PIECE($GET(^XTMP("ABM-PVH2",$JOB,"LOC TOP",ABMVLOC)),U,2)
+6 IF +$GET(^XTMP("ABM-PVH2",$JOB,"LOC TOP",ABMVLOC))>9.5
SET ABMPMET=1
+7 DO HDR^ABMM2PV3
+8 WRITE !,"Hospital used in this report: ",$$GET1^DIQ(9999999.06,ABMVLOC,.01,"E"),$SELECT($DATA(^ABMMUPRM(1,1,"B",ABMVLOC)):" (FQHC/RHC/Tribal/Urban)",1:""),!
+9 SET ABMPMET=0
+10 IF ABMY("RFMT")="P"
DO PATIENT^ABMM2PH1
QUIT
+11 IF +$GET(^XTMP("ABM-PVH2",$JOB,"LOC TOP",ABMVLOC))>9.5
DO MET^ABMM2PH1
QUIT
+12 DO NOTMET^ABMM2PH1
End DoDot:1
DO PAZ^ABMDRUTL
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+13 KILL ^XTMP("ABM-PVH2",$JOB)
+14 QUIT
ENROLL ;EP
+1 DO ENROLL^ABMM2PH2
+2 QUIT
