ABMPTPOP ; IHS/SD/SDR - Patient Population Report ;
;;2.6;IHS Third Party Billing System;**21**;NOV 12, 2009;Build 379
;IHS/SD/SDR 2.6*21 - New routine
;
K ABMY
D PROMPTS
I '$D(ABMY("RLOC"))!('$D(ABMY("DT")))!('$D(ABMY("PTSTAT"))) Q ;no location or dates selected
SEL ;Select device
S %ZIS="Q"
S %ZIS("A")="Enter DEVICE: "
D ^%ZIS Q:POP
I IO'=IO(0) D QUE,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
S IOP=ION D ^%ZIS
PRINT ;EP
D COMPILE
S ABM("HD",0)="PATIENT ELIGIBILITY STATUS REPORT"
S ABM("PG")=1
S ABMTYP="SUM" D WHD
S ABMLSUF=""
F S ABMLSUF=$O(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF)) Q:$G(ABMLSUF)="" D
.S ABMPDFN=0
.F S ABMPDFN=$O(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)) Q:'ABMPDFN D
..W !,$G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN))
W !?5,"PATIENT COUNT: ",+$G(ABMT("PT"))
W !?7,"VISIT COUNT: ",+$G(ABMT("VST"))
I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR
I $E(IOST)="P" W $$EN^ABMVDF("IOF")
D ^%ZISC
K ABM
Q
COMPILE ;EP
K ^XTMP("ABM-PTPOP",$J)
K ABMT
S ABMSDT=ABMY("DT",1)-.5
S ABMEDT=ABMY("DT",2)+.999999
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
..S ABMVLOC=+$P($G(^AUPNVSIT(ABMVDFN,0)),U,6) ;visit location
..Q:'ABMVLOC
..I '$D(ABMY("RLOC",ABMVLOC)) Q ;not selected location
..S ABMT("VST")=+$G(ABMT("VST"))+1 ;total visits for report
..S ABMPDFN=$P($G(^AUPNVSIT(ABMVDFN,0)),U,5)
..I $P($G(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,5)="I" Q
..;
..;if it gets here we want this visit
..S ABMLSUF=$P($G(^AUTTLOC(ABMVLOC,0)),U,7)
..I '$D(^XTMP("ABM-PTPOP",$J,"PT",ABMPDFN)) S ABMT("PT")=+$G(ABMT("PT"))+1 ;count unique patients
..S ^XTMP("ABM-PTPOP",$J,"PT",ABMPDFN)="" ;keep track of patients
..I $G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN))="" D ;if no data for visit location/patient yet
...S ABMHRN=$P($G(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,2)
...S ABMSEX=$P($G(^DPT(ABMPDFN,0)),U,2)
...S ABMDOB=$$SDT^ABMDUTL($P($G(^DPT(ABMPDFN,0)),U,3))
...S ABMPTNM=$P($G(^DPT(ABMPDFN,0)),U)
...S ABMDEC=""
...I +$P($G(^DPT(ABMPDFN,.35)),U)'=0 S ABMDEC="D"
...S ABMAGE=$$GET1^DIQ(2,ABMPDFN,".033","E")
...S ABMVET=$P($G(^DPT(ABMPDFN,"VET")),U)
...S ABMLUPDT=$$SDT^ABMDUTL($P($G(^AUPNPAT(ABMPDFN,0)),U,3))
...S ABMEMPLS=$$GET1^DIQ(9000001,ABMPDFN,".21","E")
...S ABMBEN=$S(+$P($G(^AUPNPAT(ABMPDFN,11)),U,11)'=0:$P($G(^AUTTBEN($P($G(^AUPNPAT(ABMPDFN,11)),U,11),0)),U,2),1:"")
...S ABMCHS=$P($G(^AUPNPAT(ABMPDFN,11)),U,12) ;elig status
...;
...S ABMRES=""
...S ABMRDT=$O(^AUPNPAT(ABMPDFN,51,99999999),-1)
...I +ABMRDT'=0 S ABMRES=$S(+$P($G(^AUPNPAT(ABMPDFN,51,ABMRDT,0)),U,3)'=0:$$GET1^DIQ(9999999.05,$P($G(^AUPNPAT(ABMPDFN,51,ABMRDT,0)),U,3),".01","E"),1:"")
...;
...S ABMREC=ABMLSUF_U_ABMHRN_U_ABMPTNM_U_ABMDEC_U_ABMDOB_U_ABMSEX_U_ABMAGE_U_ABMBEN_U_U_U_U_U_ABMCHS_U_ABMRES_U_ABMVET_U_ABMLUPDT_U_ABMEMPLS
...S ^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)=ABMREC
..D VSTCK ;check if visit is billable/unbillable
..I ABMVFLG=1 S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,18)=+$P($G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)),U,18)+1
..I ABMVFLG=0 S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,19)=+$P($G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)),U,19)+1
..D ELGCK ;see if patient had eligibility during the selected date range
..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,9)=ABMMCR
..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,10)=ABMMCD
..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,11)=ABMPI
..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,12)=ABMVET
Q
QUE ;TASKMAN
S ZTRTN="PRINT^ABMPTPOP"
S ZTDESC="Patient Eligibility Report"
S ZTSAVE("ABM*")=""
K ZTSK
D ^%ZTLOAD
D ^%ZISC
W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
Q
;
PROMPTS ;EP
REGLOC ;EP - registration location
;location
D GETFACS^ABMMUMUP ;get list of facilities
S ABMCNT=0,ABMDIR="",ABMFQHC=0
F S ABMCNT=$O(ABMFLIST(ABMCNT)) Q:'ABMCNT D
.S:ABMDIR'="" ABMDIR=ABMDIR_";"_ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
.S:ABMDIR="" ABMDIR=ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
.I $D(^ABMMUPRM(1,1,"B",ABMFLIST(ABMCNT))) S ABMFQHC=1
S ABMCNT=$O(ABMFLIST(99999),-1) ;get last entry#
S (ABMCNT,ABMTOT)=ABMCNT+1
I ABMFQHC=0!(ABMCNT<2) S ABMDIR=ABMDIR_";"_ABMCNT_":All facilities"
W !!
K ABMFANS,ABMF
F D Q:+$G(Y)<0!(Y=ABMTOT)!$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;they didn't answer or ALL was selected
.D ^XBFMK
.S DIR(0)="SO^"_$G(ABMDIR)
.S:'$D(ABMF) DIR(0)="S^"_$G(ABMDIR)
.S DIR("A")="Select one or more facilities"
.D ^DIR K DIR
.Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
.S ABMFANS=Y
.I ABMFANS'=(ABMTOT) S ABMF($G(ABMFLIST(ABMFANS)))=""
.I ABMFANS=(ABMTOT) D
..S ABMCNT=0
..F S ABMCNT=$O(ABMFLIST(ABMCNT)) Q:'ABMCNT S ABMF($G(ABMFLIST(ABMCNT)))=""
K ABMFQHC
M ABMY("RLOC")=ABMF
Q:'$D(ABMY)
DT ;EP visit dates for report
W !!," ============ Entry of Visit Date Range =============",!
S DIR("A")="Enter STARTING Visit Date for the Report"
S DIR(0)="DO^::EP"
D ^DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
S ABMY("DT",1)=Y
W !
S DIR("A")="Enter ENDING DATE for the Report"
D ^DIR
K DIR
I $D(DIRUT) K ABMY("DT") G DT
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
PTSTAT ;EP patient status
D ^XBFMK
S DIR(0)="SO^C:Current patient;A:All-regardless"
S DIR("A")="Current Patient or ALL"
S DIR("B")="All"
D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
S ABMY("PTSTAT")=Y
Q
VSTCK ;EP
S ABMVFLG=0
S ABML="",ABMELG=0
;check service category only for billable, unbillable
S SERVCAT=$P($G(^AUPNVSIT(ABMVDFN,0)),U,7)
I "^C^T^N^E^X^"[("^"_SERVCAT_"^") Q ;these are unbillable visits
S ABMVFLG=1 ;the visit is billable to someone, don't care who
Q
ELGCK ;EP
D MCR,RR
D MCD
D PI
Q
MCR ;EP
S ABMMCR=""
S ABMI=0
F S ABMI=$O(^AUPNMCR(ABMPDFN,11,ABMI)) Q:'ABMI D Q:(ABMMCR="A")
.S ABMISDT=$P($G(^AUPNMCR(ABMPDFN,11,ABMI,0)),U)
.S ABMIEDT=$P($G(^AUPNMCR(ABMPDFN,11,ABMI,0)),U,2)
.I ABMISDT=ABMIEDT Q ;zero days coverage - skip
.I ABMISDT>ABMY("DT",2) Q ;elig started after end date
.I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMMCR="T" Q ;elig terminated during date range
.I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q ;elig ended before start date
.S ABMMCR="A"
Q
RR ;EP
Q:ABMMCR'="" ;already found in MCR
S ABMI=0
F S ABMI=$O(^AUPNRR(ABMPDFN,11,ABMI)) Q:'ABMI D Q:(ABMMCR="A")
.S ABMISDT=$P($G(^AUPNRR(ABMPDFN,11,ABMI,0)),U)
.S ABMIEDT=$P($G(^AUPNRR(ABMPDFN,11,ABMI,0)),U,2)
.I ABMISDT=ABMIEDT Q ;zero days coverage - skip
.I ABMISDT>ABMY("DT",2) Q ;elig started after end date
.I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMRR="T" Q ;elig terminated during date range
.I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q ;elig ended before start date
.S ABMMCR="A"
Q
MCD ;EP
S ABMMCD=""
S ABMI=0
F S ABMI=$O(^AUPNMCD("B",ABMPDFN,ABMI)) Q:'ABMI D Q:(ABMMCD="A")
.S ABMII=0
.F S ABMII=$O(^AUPNMCD(ABMI,11,ABMII)) Q:'ABMII D Q:(ABMMCD="A")
..S ABMISDT=$P($G(^AUPNMCD(ABMI,11,ABMII,0)),U)
..S ABMIEDT=$P($G(^AUPNMCD(ABMI,11,ABMII,0)),U,2)
..I ABMISDT=ABMIEDT Q ;zero days coverage - skip
..I ABMISDT>ABMY("DT",2) Q ;elig started after end date
..I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMMCD="T" Q ;elig terminated during date range
..I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q ;elig ended before start date
..S ABMMCD="A"
Q
PI ;EP
S ABMPI="",ABMVET=""
S ABMI=0
F S ABMI=$O(^AUPNPRVT(ABMPDFN,11,ABMI)) Q:'ABMI D Q:(ABMPI="A")
.S ABMP("INS")=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U)
.S ABMISDT=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,6)
.S ABMIEDT=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,7)
.I ABMISDT=ABMIEDT Q ;zero days coverage - skip
.I ABMISDT>ABMY("DT",2) Q ;elig started after end date
.I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))&($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="V") S ABMVET="T" Q ;elig terminated during date range
.I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))&($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")'="V") S ABMPI="T" Q ;elig terminated during date range
.I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q ;elig ended before start date
.I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="V" S ABMVET="A"
.E S ABMPI="A"
Q
WHD ;EP
W $$EN^ABMVDF("IOF"),!
K ABM("LINE") S $P(ABM("LINE"),"=",$S($D(ABM(132)):132,1:80))="" W ABM("LINE"),!
D NOW^%DTC
W ABM("HD",0),?$S($D(ABM(132)):103,1:48) S Y=% X ^DD("DD") W Y
S ABM("HD",1)="For Visit Dates from "_$$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(s): "
S ABMRL=0
S ABMC=0
F S ABMRL=$O(ABMY("RLOC",ABMRL)) Q:'ABMRL D
.I ABMC'=0 W ", "
.S ABMC=1
.W $P($G(^DIC(4,ABMRL,0)),U)
;
W !?40,"* - AGE AS OF REPORT DATE"
W !,ABM("LINE") K ABM("LINE")
;W !,"REG"_U_U_U_"BIRTH"_U_U_U_U_"Eligibility"_U_U_U_U_U_"VET"_U_"DATE OF"_U_"EMPL"_U_"BILL"_U_"UNBIL"
W !,"REG LOC"_U_"HRN"_U_"NAME"_U_"DEC"_U_"BIRTH DATE"_U_"SEX"_U_"AGE*"_U_"BEN"_U_"MCR"_U_"MCD"_U_"PVT"_U_"VET"_U_"CHS"_U_"RESIDENCE"_U_"VET Y/N"_U_"DATE OF LAST UPD"_U_"EMPL STATUS"_U_"BILL VISIT"_U_"UNBILL VISIT"
Q
ABMPTPOP ; IHS/SD/SDR - Patient Population Report ;
+1 ;;2.6;IHS Third Party Billing System;**21**;NOV 12, 2009;Build 379
+2 ;IHS/SD/SDR 2.6*21 - New routine
+3 ;
+4 KILL ABMY
+5 DO PROMPTS
+6 ;no location or dates selected
IF '$DATA(ABMY("RLOC"))!('$DATA(ABMY("DT")))!('$DATA(ABMY("PTSTAT")))
QUIT
SEL ;Select device
+1 SET %ZIS="Q"
+2 SET %ZIS("A")="Enter DEVICE: "
+3 DO ^%ZIS
IF POP
QUIT
+4 IF IO'=IO(0)
DO QUE
DO HOME^%ZIS
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+5 SET IOP=ION
DO ^%ZIS
PRINT ;EP
+1 DO COMPILE
+2 SET ABM("HD",0)="PATIENT ELIGIBILITY STATUS REPORT"
+3 SET ABM("PG")=1
+4 SET ABMTYP="SUM"
DO WHD
+5 SET ABMLSUF=""
+6 FOR
SET ABMLSUF=$ORDER(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF))
IF $GET(ABMLSUF)=""
QUIT
Begin DoDot:1
+7 SET ABMPDFN=0
+8 FOR
SET ABMPDFN=$ORDER(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN))
IF 'ABMPDFN
QUIT
Begin DoDot:2
+9 WRITE !,$GET(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN))
End DoDot:2
End DoDot:1
+10 WRITE !?5,"PATIENT COUNT: ",+$GET(ABMT("PT"))
+11 WRITE !?7,"VISIT COUNT: ",+$GET(ABMT("VST"))
+12 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+13 IF $EXTRACT(IOST)="P"
WRITE $$EN^ABMVDF("IOF")
+14 DO ^%ZISC
+15 KILL ABM
+16 QUIT
COMPILE ;EP
+1 KILL ^XTMP("ABM-PTPOP",$JOB)
+2 KILL ABMT
+3 SET ABMSDT=ABMY("DT",1)-.5
+4 SET ABMEDT=ABMY("DT",2)+.999999
+5 FOR
SET ABMSDT=$ORDER(^AUPNVSIT("B",ABMSDT))
IF 'ABMSDT!(ABMSDT>ABMEDT)
QUIT
Begin DoDot:1
+6 SET ABMVDFN=0
+7 FOR
SET ABMVDFN=$ORDER(^AUPNVSIT("B",ABMSDT,ABMVDFN))
IF 'ABMVDFN
QUIT
Begin DoDot:2
+8 ;visit location
SET ABMVLOC=+$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U,6)
+9 IF 'ABMVLOC
QUIT
+10 ;not selected location
IF '$DATA(ABMY("RLOC",ABMVLOC))
QUIT
+11 ;total visits for report
SET ABMT("VST")=+$GET(ABMT("VST"))+1
+12 SET ABMPDFN=$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U,5)
+13 IF $PIECE($GET(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,5)="I"
QUIT
+14 ;
+15 ;if it gets here we want this visit
+16 SET ABMLSUF=$PIECE($GET(^AUTTLOC(ABMVLOC,0)),U,7)
+17 ;count unique patients
IF '$DATA(^XTMP("ABM-PTPOP",$JOB,"PT",ABMPDFN))
SET ABMT("PT")=+$GET(ABMT("PT"))+1
+18 ;keep track of patients
SET ^XTMP("ABM-PTPOP",$JOB,"PT",ABMPDFN)=""
+19 ;if no data for visit location/patient yet
IF $GET(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN))=""
Begin DoDot:3
+20 SET ABMHRN=$PIECE($GET(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,2)
+21 SET ABMSEX=$PIECE($GET(^DPT(ABMPDFN,0)),U,2)
+22 SET ABMDOB=$$SDT^ABMDUTL($PIECE($GET(^DPT(ABMPDFN,0)),U,3))
+23 SET ABMPTNM=$PIECE($GET(^DPT(ABMPDFN,0)),U)
+24 SET ABMDEC=""
+25 IF +$PIECE($GET(^DPT(ABMPDFN,.35)),U)'=0
SET ABMDEC="D"
+26 SET ABMAGE=$$GET1^DIQ(2,ABMPDFN,".033","E")
+27 SET ABMVET=$PIECE($GET(^DPT(ABMPDFN,"VET")),U)
+28 SET ABMLUPDT=$$SDT^ABMDUTL($PIECE($GET(^AUPNPAT(ABMPDFN,0)),U,3))
+29 SET ABMEMPLS=$$GET1^DIQ(9000001,ABMPDFN,".21","E")
+30 SET ABMBEN=$SELECT(+$PIECE($GET(^AUPNPAT(ABMPDFN,11)),U,11)'=0:$PIECE($GET(^AUTTBEN($PIECE($GET(^AUPNPAT(ABMPDFN,11)),U,11),0)),U,2),1:"")
+31 ;elig status
SET ABMCHS=$PIECE($GET(^AUPNPAT(ABMPDFN,11)),U,12)
+32 ;
+33 SET ABMRES=""
+34 SET ABMRDT=$ORDER(^AUPNPAT(ABMPDFN,51,99999999),-1)
+35 IF +ABMRDT'=0
SET ABMRES=$SELECT(+$PIECE($GET(^AUPNPAT(ABMPDFN,51,ABMRDT,0)),U,3)'=0:$$GET1^DIQ(9999999.05,$PIECE($GET(^AUPNPAT(ABMPDFN,51,ABMRDT,0)),U,3),".01","E"),1:"")
+36 ;
+37 SET ABMREC=ABMLSUF_U_ABMHRN_U_ABMPTNM_U_ABMDEC_U_ABMDOB_U_ABMSEX_U_ABMAGE_U_ABMBEN_U_U_U_U_U_ABMCHS_U_ABMRES_U_ABMVET_U_ABMLUPDT_U_ABMEMPLS
+38 SET ^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN)=ABMREC
End DoDot:3
+39 ;check if visit is billable/unbillable
DO VSTCK
+40 IF ABMVFLG=1
SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,18)=+$PIECE($GET(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN)),U,18)+1
+41 IF ABMVFLG=0
SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,19)=+$PIECE($GET(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN)),U,19)+1
+42 ;see if patient had eligibility during the selected date range
DO ELGCK
+43 SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,9)=ABMMCR
+44 SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,10)=ABMMCD
+45 SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,11)=ABMPI
+46 SET $PIECE(^XTMP("ABM-PTPOP",$JOB,"DATA",ABMLSUF,ABMPDFN),U,12)=ABMVET
End DoDot:2
End DoDot:1
+47 QUIT
QUE ;TASKMAN
+1 SET ZTRTN="PRINT^ABMPTPOP"
+2 SET ZTDESC="Patient Eligibility Report"
+3 SET ZTSAVE("ABM*")=""
+4 KILL ZTSK
+5 DO ^%ZTLOAD
+6 DO ^%ZISC
+7 IF $GET(ZTSK)
WRITE !,"Task # ",ZTSK," queued.",!
+8 QUIT
+9 ;
PROMPTS ;EP
REGLOC ;EP - registration location
+1 ;location
+2 ;get list of facilities
DO GETFACS^ABMMUMUP
+3 SET ABMCNT=0
SET ABMDIR=""
SET ABMFQHC=0
+4 FOR
SET ABMCNT=$ORDER(ABMFLIST(ABMCNT))
IF 'ABMCNT
QUIT
Begin DoDot:1
+5 IF ABMDIR'=""
SET ABMDIR=ABMDIR_";"_ABMCNT_":"_$$GET1^DIQ(9999999.06,$GET(ABMFLIST(ABMCNT)),.01,"E")
+6 IF ABMDIR=""
SET ABMDIR=ABMCNT_":"_$$GET1^DIQ(9999999.06,$GET(ABMFLIST(ABMCNT)),.01,"E")
+7 IF $DATA(^ABMMUPRM(1,1,"B",ABMFLIST(ABMCNT)))
SET ABMFQHC=1
End DoDot:1
+8 ;get last entry#
SET ABMCNT=$ORDER(ABMFLIST(99999),-1)
+9 SET (ABMCNT,ABMTOT)=ABMCNT+1
+10 IF ABMFQHC=0!(ABMCNT<2)
SET ABMDIR=ABMDIR_";"_ABMCNT_":All facilities"
+11 WRITE !!
+12 KILL ABMFANS,ABMF
+13 ;they didn't answer or ALL was selected
FOR
Begin DoDot:1
+14 DO ^XBFMK
+15 SET DIR(0)="SO^"_$GET(ABMDIR)
+16 IF '$DATA(ABMF)
SET DIR(0)="S^"_$GET(ABMDIR)
+17 SET DIR("A")="Select one or more facilities"
+18 DO ^DIR
KILL DIR
+19 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+20 SET ABMFANS=Y
+21 IF ABMFANS'=(ABMTOT)
SET ABMF($GET(ABMFLIST(ABMFANS)))=""
+22 IF ABMFANS=(ABMTOT)
Begin DoDot:2
+23 SET ABMCNT=0
+24 FOR
SET ABMCNT=$ORDER(ABMFLIST(ABMCNT))
IF 'ABMCNT
QUIT
SET ABMF($GET(ABMFLIST(ABMCNT)))=""
End DoDot:2
End DoDot:1
IF +$GET(Y)<0!(Y=ABMTOT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+25 KILL ABMFQHC
+26 MERGE ABMY("RLOC")=ABMF
+27 IF '$DATA(ABMY)
QUIT
DT ;EP visit dates for report
+1 WRITE !!," ============ Entry of Visit Date Range =============",!
+2 SET DIR("A")="Enter STARTING Visit Date for the Report"
+3 SET DIR(0)="DO^::EP"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+6 SET ABMY("DT",1)=Y
+7 WRITE !
+8 SET DIR("A")="Enter ENDING DATE for the Report"
+9 DO ^DIR
+10 KILL DIR
+11 IF $DATA(DIRUT)
KILL ABMY("DT")
GOTO DT
+12 SET ABMY("DT",2)=Y
+13 IF ABMY("DT",1)>ABMY("DT",2)
WRITE !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!!
GOTO DT
PTSTAT ;EP patient status
+1 DO ^XBFMK
+2 SET DIR(0)="SO^C:Current patient;A:All-regardless"
+3 SET DIR("A")="Current Patient or ALL"
+4 SET DIR("B")="All"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+7 SET ABMY("PTSTAT")=Y
+8 QUIT
VSTCK ;EP
+1 SET ABMVFLG=0
+2 SET ABML=""
SET ABMELG=0
+3 ;check service category only for billable, unbillable
+4 SET SERVCAT=$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U,7)
+5 ;these are unbillable visits
IF "^C^T^N^E^X^"[("^"_SERVCAT_"^")
QUIT
+6 ;the visit is billable to someone, don't care who
SET ABMVFLG=1
+7 QUIT
ELGCK ;EP
+1 DO MCR
DO RR
+2 DO MCD
+3 DO PI
+4 QUIT
MCR ;EP
+1 SET ABMMCR=""
+2 SET ABMI=0
+3 FOR
SET ABMI=$ORDER(^AUPNMCR(ABMPDFN,11,ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+4 SET ABMISDT=$PIECE($GET(^AUPNMCR(ABMPDFN,11,ABMI,0)),U)
+5 SET ABMIEDT=$PIECE($GET(^AUPNMCR(ABMPDFN,11,ABMI,0)),U,2)
+6 ;zero days coverage - skip
IF ABMISDT=ABMIEDT
QUIT
+7 ;elig started after end date
IF ABMISDT>ABMY("DT",2)
QUIT
+8 ;elig terminated during date range
IF (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))
SET ABMMCR="T"
QUIT
+9 ;elig ended before start date
IF ABMIEDT'=""&(ABMIEDT<ABMY("DT",1))
QUIT
+10 SET ABMMCR="A"
End DoDot:1
IF (ABMMCR="A")
QUIT
+11 QUIT
RR ;EP
+1 ;already found in MCR
IF ABMMCR'=""
QUIT
+2 SET ABMI=0
+3 FOR
SET ABMI=$ORDER(^AUPNRR(ABMPDFN,11,ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+4 SET ABMISDT=$PIECE($GET(^AUPNRR(ABMPDFN,11,ABMI,0)),U)
+5 SET ABMIEDT=$PIECE($GET(^AUPNRR(ABMPDFN,11,ABMI,0)),U,2)
+6 ;zero days coverage - skip
IF ABMISDT=ABMIEDT
QUIT
+7 ;elig started after end date
IF ABMISDT>ABMY("DT",2)
QUIT
+8 ;elig terminated during date range
IF (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))
SET ABMRR="T"
QUIT
+9 ;elig ended before start date
IF ABMIEDT'=""&(ABMIEDT<ABMY("DT",1))
QUIT
+10 SET ABMMCR="A"
End DoDot:1
IF (ABMMCR="A")
QUIT
+11 QUIT
MCD ;EP
+1 SET ABMMCD=""
+2 SET ABMI=0
+3 FOR
SET ABMI=$ORDER(^AUPNMCD("B",ABMPDFN,ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+4 SET ABMII=0
+5 FOR
SET ABMII=$ORDER(^AUPNMCD(ABMI,11,ABMII))
IF 'ABMII
QUIT
Begin DoDot:2
+6 SET ABMISDT=$PIECE($GET(^AUPNMCD(ABMI,11,ABMII,0)),U)
+7 SET ABMIEDT=$PIECE($GET(^AUPNMCD(ABMI,11,ABMII,0)),U,2)
+8 ;zero days coverage - skip
IF ABMISDT=ABMIEDT
QUIT
+9 ;elig started after end date
IF ABMISDT>ABMY("DT",2)
QUIT
+10 ;elig terminated during date range
IF (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))
SET ABMMCD="T"
QUIT
+11 ;elig ended before start date
IF ABMIEDT'=""&(ABMIEDT<ABMY("DT",1))
QUIT
+12 SET ABMMCD="A"
End DoDot:2
IF (ABMMCD="A")
QUIT
End DoDot:1
IF (ABMMCD="A")
QUIT
+13 QUIT
PI ;EP
+1 SET ABMPI=""
SET ABMVET=""
+2 SET ABMI=0
+3 FOR
SET ABMI=$ORDER(^AUPNPRVT(ABMPDFN,11,ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+4 SET ABMP("INS")=$PIECE($GET(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U)
+5 SET ABMISDT=$PIECE($GET(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,6)
+6 SET ABMIEDT=$PIECE($GET(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,7)
+7 ;zero days coverage - skip
IF ABMISDT=ABMIEDT
QUIT
+8 ;elig started after end date
IF ABMISDT>ABMY("DT",2)
QUIT
+9 ;elig terminated during date range
IF (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))&($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="V")
SET ABMVET="T"
QUIT
+10 ;elig terminated during date range
IF (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2))&($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")'="V")
SET ABMPI="T"
QUIT
+11 ;elig ended before start date
IF ABMIEDT'=""&(ABMIEDT<ABMY("DT",1))
QUIT
+12 IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="V"
SET ABMVET="A"
+13 IF '$TEST
SET ABMPI="A"
End DoDot:1
IF (ABMPI="A")
QUIT
+14 QUIT
WHD ;EP
+1 WRITE $$EN^ABMVDF("IOF"),!
+2 KILL ABM("LINE")
SET $PIECE(ABM("LINE"),"=",$SELECT($DATA(ABM(132)):132,1:80))=""
WRITE ABM("LINE"),!
+3 DO NOW^%DTC
+4 WRITE ABM("HD",0),?$SELECT($DATA(ABM(132)):103,1:48)
SET Y=%
XECUTE ^DD("DD")
WRITE Y
+5 SET ABM("HD",1)="For Visit Dates from "_$$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 ;
+9 WRITE !,"Billing Location(s): "
+10 SET ABMRL=0
+11 SET ABMC=0
+12 FOR
SET ABMRL=$ORDER(ABMY("RLOC",ABMRL))
IF 'ABMRL
QUIT
Begin DoDot:1
+13 IF ABMC'=0
WRITE ", "
+14 SET ABMC=1
+15 WRITE $PIECE($GET(^DIC(4,ABMRL,0)),U)
End DoDot:1
+16 ;
+17 WRITE !?40,"* - AGE AS OF REPORT DATE"
+18 WRITE !,ABM("LINE")
KILL ABM("LINE")
+19 ;W !,"REG"_U_U_U_"BIRTH"_U_U_U_U_"Eligibility"_U_U_U_U_U_"VET"_U_"DATE OF"_U_"EMPL"_U_"BILL"_U_"UNBIL"
+20 WRITE !,"REG LOC"_U_"HRN"_U_"NAME"_U_"DEC"_U_"BIRTH DATE"_U_"SEX"_U_"AGE*"_U_"BEN"_U_"MCR"_U_"MCD"_U_"PVT"_U_"VET"_U_"CHS"_U_"RESIDENCE"_U_"VET Y/N"_U_"DATE OF LAST UPD"_U_"EMPL STATUS"_U_"BILL VISIT"_U_"UNBILL VISIT"
+21 QUIT
