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

ABMPTPOP.m

Go to the documentation of this file. 
  1. ABMPTPOP ; IHS/SD/SDR - Patient Population Report ;  
  1.  ;;2.6;IHS Third Party Billing System;**21**;NOV 12, 2009;Build 379
  1.  ;IHS/SD/SDR 2.6*21 - New routine
  1.  ;
  1.  K ABMY
  1.  D PROMPTS
  1.  I '$D(ABMY("RLOC"))!('$D(ABMY("DT")))!('$D(ABMY("PTSTAT"))) Q  ;no location or dates selected
  1. SEL ;Select device
  1.  S %ZIS="Q"
  1.  S %ZIS("A")="Enter DEVICE: "
  1.  D ^%ZIS Q:POP
  1.  I IO'=IO(0) D QUE,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
  1.  S IOP=ION D ^%ZIS
  1. PRINT ;EP
  1.  D COMPILE
  1.  S ABM("HD",0)="PATIENT ELIGIBILITY STATUS REPORT"
  1.  S ABM("PG")=1
  1.  S ABMTYP="SUM" D WHD
  1.  S ABMLSUF=""
  1.  F  S ABMLSUF=$O(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF)) Q:$G(ABMLSUF)=""  D
  1.  .S ABMPDFN=0
  1.  .F  S ABMPDFN=$O(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)) Q:'ABMPDFN  D
  1.  ..W !,$G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN))
  1.  W !?5,"PATIENT COUNT: ",+$G(ABMT("PT"))
  1.  W !?7,"VISIT COUNT: ",+$G(ABMT("VST"))
  1.  I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR
  1.  I $E(IOST)="P" W $$EN^ABMVDF("IOF")
  1.  D ^%ZISC
  1.  K ABM
  1.  Q
  1. COMPILE ;EP
  1.  K ^XTMP("ABM-PTPOP",$J)
  1.  K ABMT
  1.  S ABMSDT=ABMY("DT",1)-.5
  1.  S ABMEDT=ABMY("DT",2)+.999999
  1.  F  S ABMSDT=$O(^AUPNVSIT("B",ABMSDT)) Q:'ABMSDT!(ABMSDT>ABMEDT)  D
  1.  .S ABMVDFN=0
  1.  .F  S ABMVDFN=$O(^AUPNVSIT("B",ABMSDT,ABMVDFN)) Q:'ABMVDFN  D
  1.  ..S ABMVLOC=+$P($G(^AUPNVSIT(ABMVDFN,0)),U,6)  ;visit location
  1.  ..Q:'ABMVLOC
  1.  ..I '$D(ABMY("RLOC",ABMVLOC)) Q  ;not selected location
  1.  ..S ABMT("VST")=+$G(ABMT("VST"))+1  ;total visits for report
  1.  ..S ABMPDFN=$P($G(^AUPNVSIT(ABMVDFN,0)),U,5)
  1.  ..I $P($G(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,5)="I" Q
  1.  ..;
  1.  ..;if it gets here we want this visit
  1.  ..S ABMLSUF=$P($G(^AUTTLOC(ABMVLOC,0)),U,7)
  1.  ..I '$D(^XTMP("ABM-PTPOP",$J,"PT",ABMPDFN)) S ABMT("PT")=+$G(ABMT("PT"))+1  ;count unique patients
  1.  ..S ^XTMP("ABM-PTPOP",$J,"PT",ABMPDFN)=""  ;keep track of patients
  1.  ..I $G(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN))="" D  ;if no data for visit location/patient yet
  1.  ...S ABMHRN=$P($G(^AUPNPAT(ABMPDFN,41,ABMVLOC,0)),U,2)
  1.  ...S ABMSEX=$P($G(^DPT(ABMPDFN,0)),U,2)
  1.  ...S ABMDOB=$$SDT^ABMDUTL($P($G(^DPT(ABMPDFN,0)),U,3))
  1.  ...S ABMPTNM=$P($G(^DPT(ABMPDFN,0)),U)
  1.  ...S ABMDEC=""
  1.  ...I +$P($G(^DPT(ABMPDFN,.35)),U)'=0 S ABMDEC="D"
  1.  ...S ABMAGE=$$GET1^DIQ(2,ABMPDFN,".033","E")
  1.  ...S ABMVET=$P($G(^DPT(ABMPDFN,"VET")),U)
  1.  ...S ABMLUPDT=$$SDT^ABMDUTL($P($G(^AUPNPAT(ABMPDFN,0)),U,3))
  1.  ...S ABMEMPLS=$$GET1^DIQ(9000001,ABMPDFN,".21","E")
  1.  ...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:"")
  1.  ...S ABMCHS=$P($G(^AUPNPAT(ABMPDFN,11)),U,12)  ;elig status
  1.  ...;
  1.  ...S ABMRES=""
  1.  ...S ABMRDT=$O(^AUPNPAT(ABMPDFN,51,99999999),-1)
  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:"")
  1.  ...;
  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
  1.  ...S ^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN)=ABMREC
  1.  ..D VSTCK  ;check if visit is billable/unbillable
  1.  ..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
  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
  1.  ..D ELGCK  ;see if patient had eligibility during the selected date range
  1.  ..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,9)=ABMMCR
  1.  ..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,10)=ABMMCD
  1.  ..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,11)=ABMPI
  1.  ..S $P(^XTMP("ABM-PTPOP",$J,"DATA",ABMLSUF,ABMPDFN),U,12)=ABMVET
  1.  Q
  1. QUE ;TASKMAN
  1.  S ZTRTN="PRINT^ABMPTPOP"
  1.  S ZTDESC="Patient Eligibility Report"
  1.  S ZTSAVE("ABM*")=""
  1.  K ZTSK
  1.  D ^%ZTLOAD
  1.  D ^%ZISC
  1.  W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
  1.  Q
  1.  ;
  1. PROMPTS ;EP
  1. REGLOC ;EP - registration location
  1.  ;location
  1.  D GETFACS^ABMMUMUP  ;get list of facilities
  1.  S ABMCNT=0,ABMDIR="",ABMFQHC=0
  1.  F  S ABMCNT=$O(ABMFLIST(ABMCNT)) Q:'ABMCNT  D
  1.  .S:ABMDIR'="" ABMDIR=ABMDIR_";"_ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
  1.  .S:ABMDIR="" ABMDIR=ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
  1.  .I $D(^ABMMUPRM(1,1,"B",ABMFLIST(ABMCNT))) S ABMFQHC=1
  1.  S ABMCNT=$O(ABMFLIST(99999),-1)  ;get last entry#
  1.  S (ABMCNT,ABMTOT)=ABMCNT+1
  1.  I ABMFQHC=0!(ABMCNT<2) S ABMDIR=ABMDIR_";"_ABMCNT_":All facilities"
  1.  W !!
  1.  K ABMFANS,ABMF
  1.  F  D  Q:+$G(Y)<0!(Y=ABMTOT)!$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)  ;they didn't answer or ALL was selected
  1.  .D ^XBFMK
  1.  .S DIR(0)="SO^"_$G(ABMDIR)
  1.  .S:'$D(ABMF) DIR(0)="S^"_$G(ABMDIR)
  1.  .S DIR("A")="Select one or more facilities"
  1.  .D ^DIR K DIR
  1.  .Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
  1.  .S ABMFANS=Y
  1.  .I ABMFANS'=(ABMTOT) S ABMF($G(ABMFLIST(ABMFANS)))=""
  1.  .I ABMFANS=(ABMTOT) D
  1.  ..S ABMCNT=0
  1.  ..F  S ABMCNT=$O(ABMFLIST(ABMCNT)) Q:'ABMCNT  S ABMF($G(ABMFLIST(ABMCNT)))=""
  1.  K ABMFQHC
  1.  M ABMY("RLOC")=ABMF
  1.  Q:'$D(ABMY)
  1. DT ;EP visit dates for report
  1.  W !!," ============ Entry of Visit Date Range =============",!
  1.  S DIR("A")="Enter STARTING Visit Date for the Report"
  1.  S DIR(0)="DO^::EP"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
  1.  S ABMY("DT",1)=Y
  1.  W !
  1.  S DIR("A")="Enter ENDING DATE for the Report"
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DIRUT) K ABMY("DT") G DT
  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. PTSTAT ;EP  patient status
  1.  D ^XBFMK
  1.  S DIR(0)="SO^C:Current patient;A:All-regardless"
  1.  S DIR("A")="Current Patient or ALL"
  1.  S DIR("B")="All"
  1.  D ^DIR K DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
  1.  S ABMY("PTSTAT")=Y
  1.  Q
  1. VSTCK ;EP
  1.  S ABMVFLG=0
  1.  S ABML="",ABMELG=0
  1.  ;check service category only for billable, unbillable
  1.  S SERVCAT=$P($G(^AUPNVSIT(ABMVDFN,0)),U,7)
  1.  I "^C^T^N^E^X^"[("^"_SERVCAT_"^") Q  ;these are unbillable visits
  1.  S ABMVFLG=1  ;the visit is billable to someone, don't care who
  1.  Q
  1. ELGCK ;EP
  1.  D MCR,RR
  1.  D MCD
  1.  D PI
  1.  Q
  1. MCR ;EP
  1.  S ABMMCR=""
  1.  S ABMI=0
  1.  F  S ABMI=$O(^AUPNMCR(ABMPDFN,11,ABMI)) Q:'ABMI  D  Q:(ABMMCR="A")
  1.  .S ABMISDT=$P($G(^AUPNMCR(ABMPDFN,11,ABMI,0)),U)
  1.  .S ABMIEDT=$P($G(^AUPNMCR(ABMPDFN,11,ABMI,0)),U,2)
  1.  .I ABMISDT=ABMIEDT Q  ;zero days coverage - skip
  1.  .I ABMISDT>ABMY("DT",2) Q  ;elig started after end date
  1.  .I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMMCR="T" Q  ;elig terminated during date range
  1.  .I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q  ;elig ended before start date
  1.  .S ABMMCR="A"
  1.  Q
  1. RR ;EP
  1.  Q:ABMMCR'=""  ;already found in MCR
  1.  S ABMI=0
  1.  F  S ABMI=$O(^AUPNRR(ABMPDFN,11,ABMI)) Q:'ABMI  D  Q:(ABMMCR="A")
  1.  .S ABMISDT=$P($G(^AUPNRR(ABMPDFN,11,ABMI,0)),U)
  1.  .S ABMIEDT=$P($G(^AUPNRR(ABMPDFN,11,ABMI,0)),U,2)
  1.  .I ABMISDT=ABMIEDT Q  ;zero days coverage - skip
  1.  .I ABMISDT>ABMY("DT",2) Q  ;elig started after end date
  1.  .I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMRR="T" Q  ;elig terminated during date range
  1.  .I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q  ;elig ended before start date
  1.  .S ABMMCR="A"
  1.  Q
  1. MCD ;EP
  1.  S ABMMCD=""
  1.  S ABMI=0
  1.  F  S ABMI=$O(^AUPNMCD("B",ABMPDFN,ABMI)) Q:'ABMI  D  Q:(ABMMCD="A")
  1.  .S ABMII=0
  1.  .F  S ABMII=$O(^AUPNMCD(ABMI,11,ABMII)) Q:'ABMII  D  Q:(ABMMCD="A")
  1.  ..S ABMISDT=$P($G(^AUPNMCD(ABMI,11,ABMII,0)),U)
  1.  ..S ABMIEDT=$P($G(^AUPNMCD(ABMI,11,ABMII,0)),U,2)
  1.  ..I ABMISDT=ABMIEDT Q  ;zero days coverage - skip
  1.  ..I ABMISDT>ABMY("DT",2) Q  ;elig started after end date
  1.  ..I (ABMIEDT'="")&(ABMIEDT>ABMY("DT",1))&(ABMIEDT<ABMY("DT",2)) S ABMMCD="T" Q  ;elig terminated during date range
  1.  ..I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q  ;elig ended before start date
  1.  ..S ABMMCD="A"
  1.  Q
  1. PI ;EP
  1.  S ABMPI="",ABMVET=""
  1.  S ABMI=0
  1.  F  S ABMI=$O(^AUPNPRVT(ABMPDFN,11,ABMI)) Q:'ABMI  D  Q:(ABMPI="A")
  1.  .S ABMP("INS")=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U)
  1.  .S ABMISDT=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,6)
  1.  .S ABMIEDT=$P($G(^AUPNPRVT(ABMPDFN,11,ABMI,0)),U,7)
  1.  .I ABMISDT=ABMIEDT Q  ;zero days coverage - skip
  1.  .I ABMISDT>ABMY("DT",2) Q  ;elig started after end date
  1.  .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
  1.  .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
  1.  .I ABMIEDT'=""&(ABMIEDT<ABMY("DT",1)) Q  ;elig ended before start date
  1.  .I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="V" S ABMVET="A"
  1.  .E  S ABMPI="A"
  1.  Q
  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
  1.  S ABM("HD",1)="For Visit Dates from "_$$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.  ;
  1.  W !,"Billing Location(s): "
  1.  S ABMRL=0
  1.  S ABMC=0
  1.  F  S ABMRL=$O(ABMY("RLOC",ABMRL)) Q:'ABMRL  D
  1.  .I ABMC'=0 W ", "
  1.  .S ABMC=1
  1.  .W $P($G(^DIC(4,ABMRL,0)),U)
  1.  ;
  1.  W !?40,"* - AGE AS OF REPORT DATE"
  1.  W !,ABM("LINE") K ABM("LINE")
  1.  ;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"
  1.  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"
  1.  Q