ABMRMCRD.m

ABMRMCRD ;IHS/SD/SDR - MEDICARE PART D REPORT ;    

 ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

 ;

 ;IHS/SD/SDR - 2.6*21 - HEAT119339 - fix <UNDEF>RAILROAD+9^ABMRMCRD if user typed '^' at

 ;   exclude inactive/deceased pt prompt

 ;;

 ;; ABMILIST(insurer IEN)=insurer type--list of insurers for report

 ;; ABMINAME(insurer name,insurer IEN)=""--by name for display alphabetically

 ;; ABMICNT(SU,insurer name,insurer IEN)=count--count by insurer

 ;; ABMITOT(SU,"TOTAL")=total by service unit

 ;; ABMISU=(SU)=city, state of SU

 ;; ABMITOT("TOTAL")=total for report

 ;; ^TMP($J,"ABM-MCRD",Service Unit,patient IEN)--what patients have been counted

 ;; ABMIDUP=count--if patient is counted under more than one SU

 ;;

 S $P(ABMLINE,"-",79)="-"

 D MESSAGE  ;message about report

 D GETINS  ;get list of insurers we're looking for

 D DISP  ;display list

 D GETMORE  ;do they want to add others to list?

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 I $G(ABMDFLG)=1 D DISP  ;display list if more added

 D ELIGDT  ;get list for what date?

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 D INACT  ;include inactive/deceased pts?

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)  ;abm*2.6*21 IHS/SD/SDR HEAT119339

 D DETAILQ  ;detail?

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 D ^%ZIS Q:POP

 U IO

 D COUNTIT  ;go count data

 D OUTPUT  ;display results

 D ^%ZISC

 Q

 ;

MESSAGE ;

 W !?2,"This option will print a list of Patients who are registered at the"

 W !?2,"facility you select who are currently enrolled in a Medicare Part D"

 W !?2,"plan."

 W !!?2,"You will be asked to enter an ""As of"" date to be used in determining"

 W !?2,"those patients who are ""actively"" enrolled in a plan."

 W !!?2,"The report will be sorted alphabetically by Plan Name."

 Q

 ;

GETINS ;loop thru insurers and get ones with MD

 ;insurer type

 ;

 K ABMILIST,ABMINAME,ABMDFLG,ABMIDUP,^TMP($J,"ABM-MCRD"),ABMITOT

 K ^TMP($J,"ABM-MCRAB")

 S ABMINS=0

 F  S ABMINS=$O(^AUTNINS(ABMINS)) Q:+ABMINS=0  D

 .I $E($P($G(^AUTNINS(ABMINS,0)),U),1,2)="D-" D

 ..;S ABMILIST(ABMINS)=$P($G(^AUTNINS(ABMINS,2)),U)  ;abm*2.6*10 HEAT73780

 ..S ABMILIST(ABMINS)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")  ;abm*2.6*10 HEAT73780

 ..S ABMINAME($P($G(^AUTNINS(ABMINS,0)),U),ABMINS)=""

 .;I $P($G(^AUTNINS(ABMINS,2)),U)="MD" D  ;abm*2.6*10 HEAT73780

 .I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")="MD" D  ;abm*2.6*10 HEAT73780

 ..;S ABMILIST(ABMINS)=$P($G(^AUTNINS(ABMINS,2)),U)  ;abm*2.6*10 HEAT73780

 ..S ABMILIST(ABMINS)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")  ;abm*2.6*10 HEAT73780

 ..S ABMINAME($P($G(^AUTNINS(ABMINS,0)),U),ABMINS)=""

 Q

 ;

DISP ;display list of insurers

 K ABMIFLG

 W !!?2

 I +$G(ABMDFLG)=0 D

 .W "The following insurers contain the Insurer Type code of ""MD"" or contain "

 .W !?2,"""D-"" in the name of the plan:"

 W:+$G(ABMDFLG)=1 "The following insurers will be included on this report:"

 W !!

 S ABMNAME=""

 F  S ABMNAME=$O(ABMINAME(ABMNAME)) Q:ABMNAME=""  D

 .W ?10,ABMNAME

 .S ABMINS=$O(ABMINAME(ABMNAME,0))

 .S IT=$P($G(ABMILIST(ABMINS)),U)

 .W ?45,$S(IT="P":"PRIVATE",IT="MD":"MCR PART D",1:IT)

 .W !

 .S ABMIFLG=1

 I +$G(ABMIFLG)=0 D

 .W !?10,"THERE ARE NO INSURERS THAT CURRENTLY HAVE 'MD' AS THE INSURER TYPE"

 Q

 ;

GETMORE ;do they want more PI insurers?

 S DIR(0)="Y"

 S DIR("A")="Do you wish to include any other insurers?"

 S DIR("B")="N"

 D ^DIR

 K DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 I Y=1 D

 .S ABMDFLG=1

 .F  D  Q:($G(Y)="")!($G(X)=""&(Y<0))

 ..W !

 ..K X,Y,DIC,DR

 ..S DIC="^AUTNINS("

 ..S DIC(0)="AEMQ"

 ..;S DIC("S")="I $P(^AUTNINS(Y,2),U)=""P"""  ;PIs only!  ;abm*2.6*10 HEAT73780

 ..S DIC("S")="I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,Y,"".211"",""I""),1,""I"")=""P"""  ;PIs only!  ;abm*2.6*10 HEAT73780

 ..D ^DIC

 ..I Y>0 D

 ...W $P(Y,U,2)

 ...;S ABMILIST(+Y)=$P($G(^AUTNINS(+Y,2)),U)  ;abm*2.6*10 HEAT73780

 ...S ABMILIST(+Y)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+Y,".211","I"),1,"I")  ;abm*2.6*10 HEAT73780

 ...S ABMINAME($P(Y,U,2),+Y)=""

 Q

 ;

ELIGDT ;get list for what date-default to today

 W !

 K DIR,DIC,DIE,X,Y,DR

 S DIR(0)="D"

 S DIR("A")="Display eligibility as of what date?"

 S DIR("B")="Today"

 D ^DIR

 K DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 S ABMODT=+Y

 W "  ("_Y(0)_")"  ;display date selected

 Q

 ;

INACT ;include inactive/deceased pts?

 W !

 K DIR,DIC,DIE,X,Y,DR

 S DIR(0)="Y"

 S DIR("A")="Do you wish to EXCLUDE inactive and deceased patients"

 S DIR("B")="YES"

 D ^DIR

 K DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 I Y=1 S ABMALL=0  ;exclude

 E  S ABMALL=1  ;include all patients

 Q

DETAILQ ;

 W !

 K DIR,DIC,DIE,X,Y,DR

 S DIR(0)="Y"

 S DIR("A")="Do you wish to view detail (patients)"

 S DIR("B")="NO"

 D ^DIR

 K DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)

 I Y=1 S ABMDTAIL=1  ;detail

 E  S ABMDTAIL=0  ;summary

 Q

 ;

COUNTIT ;do counts for selected insurers

 D RAILROAD

 D MEDICARE

 D PRIVATE

 Q

 ;

RAILROAD ;

 S ABMIEN=0

 F  S ABMIEN=$O(^AUPNRRE(ABMIEN)) Q:+ABMIEN=0  D

 .S ABMEIEN=0

 .F  S ABMEIEN=$O(^AUPNRRE(ABMIEN,11,ABMEIEN)) Q:+ABMEIEN=0  D

 ..S ABMCOV=$P($G(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,3)

 ..I ABMCOV="D" S ABMPIEN=$P($G(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,4)

 ..I ABMCOV="D",($G(ABMPIEN)="") Q

 ..I ABMCOV="D",($G(ABMILIST(ABMPIEN))="") Q  ;no entry for insurer on requested list

 ..I ABMALL=0,($P($G(^DPT(ABMIEN,.35)),U)'="") Q  ;check exclude flag and DOD

 ..K ABMSDT,ABMEDT

 ..S ABMSDT=$P($G(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U)

 ..S ABMEDT=$P($G(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,2)

 ..I ((ABMSDT<ABMODT)!(ABMSDT=ABMODT)),((ABMEDT>ABMODT)!(ABMEDT="")) D

 ...S ABMHRN=0

 ...F  S ABMHRN=$O(^AUPNPAT(ABMIEN,41,ABMHRN)) Q:+ABMHRN=0  D

 ....S ABMHRNS=$P($G(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,5)  ;inactive?

 ....I ABMALL=0,ABMHRN="I" Q  ;check exclude inactive flag and status

 ....S ABMSU=$S($P($G(^AUTTLOC(ABMHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABMHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABMISU(ABMSU)=$P($G(^AUTTLOC(ABMHRN,0)),U,13)_", "_$S($P($G(^AUTTLOC(ABMHRN,0)),U,14)'="":$P($G(^DIC(5,$P($G(^AUTTLOC(ABMHRN,0)),U,14),0)),U,2),1:"")

 ....S:ABMCOV="D" ABMINAME=$P($G(^AUTNINS(ABMPIEN,0)),U)  ;insurer name

 ....I ABMCOV="D",($G(^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))="") D

 .....S ABMPN=$P($G(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,6)  ;ID

 .....S ABMHRNN=$P($G(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN

 .....S ABMICNT(ABMSU,ABMINAME,ABMPIEN)=+$G(ABMICNT(ABMSU,ABMINAME,ABMPIEN))+1

 .....S ABMITOT(ABMSU,"TOTAL")=+$G(ABMITOT(ABMSU,"TOTAL"))+1

 .....S ABMITOT("TOTAL")=+$G(ABMITOT("TOTAL"))+1

 .....S ABMBTHCT(ABMSU,"TOTAL")=$G(ABMBTHCT(ABMSU,"TOTAL"))+1

 ....I ABMCOV="D",($G(^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))'="") S ABMIDUP=+$G(ABMIDUP)+1

 ....I ABMCOV="A"!(ABMCOV="B") D  ;count patients with active A and/or B

 .....Q:$G(^TMP($J,"ABM-MCRAB",ABMSU,ABMIEN))'=""

 .....S ^TMP($J,"ABM-MCRAB",ABMSU,ABMIEN)=ABMIEN

 .....S ^TMP($J,"ABM-MCRAB",ABMSU,"TOTAL")=+$G(^TMP($J,"ABM-MCRAB",ABMSU,"TOTAL"))+1

 Q

 ;

MEDICARE ;

 S ABMIEN=0

 F  S ABMIEN=$O(^AUPNMCR(ABMIEN)) Q:+ABMIEN=0  D

 .S ABMEIEN=0

 .F  S ABMEIEN=$O(^AUPNMCR(ABMIEN,11,ABMEIEN)) Q:+ABMEIEN=0  D

 ..S ABMCOV=$P($G(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,3)

 ..I ABMCOV="D" S ABMPIEN=$P($G(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,4)

 ..I ABMCOV="D",($G(ABMPIEN)="") Q

 ..I ABMCOV="D",($G(ABMILIST(ABMPIEN))="") Q  ;no entry for insurer on requested list

 ..I ABMALL=0,($P($G(^DPT(ABMIEN,.35)),U)'="") Q  ;check exclude flag and DOD

 ..K ABMSDT,ABMEDT

 ..S ABMSDT=$P($G(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U)

 ..S ABMEDT=$P($G(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,2)

 ..I ((ABMSDT<ABMODT)!(ABMSDT=ABMODT)),((ABMEDT>ABMODT)!(ABMEDT="")) D

 ...S ABMHRN=0

 ...F  S ABMHRN=$O(^AUPNPAT(ABMIEN,41,ABMHRN)) Q:+ABMHRN=0  D

 ....S ABMHRNS=$P($G(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,5)  ;inactive?

 ....I ABMALL=0,ABMHRN="I" Q  ;check exclude inactive flag and status

 ....S ABMSU=$S($P($G(^AUTTLOC(ABMHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABMHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABMSUC=$P($G(^AUTTLOC(ABMHRN,0)),U,13)

 ....S ABMSUS=$P($G(^AUTTLOC(ABMHRN,0)),U,14)

 ....S ABMISU(ABMSU)=ABMSUC_", "_$S(ABMSUS'="":$P($G(^DIC(5,ABMSUS,0)),U,2),1:"")

 ....S:ABMCOV="D" ABMINAME=$P($G(^AUTNINS(ABMPIEN,0)),U)  ;insurer name

 ....I ABMCOV="D",($G(^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))="") D  ;part D and not on list already

 .....S ABMPN=$P($G(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,6)  ;ID

 .....S ABMHRNN=$P($G(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN

 .....S ABMICNT(ABMSU,ABMINAME,ABMPIEN)=+$G(ABMICNT(ABMSU,ABMINAME,ABMPIEN))+1

 .....S ABMITOT(ABMSU,"TOTAL")=+$G(ABMITOT(ABMSU,"TOTAL"))+1

 .....S ABMITOT("TOTAL")=+$G(ABMITOT("TOTAL"))+1

 ....I ABMCOV="D",($G(^TMP($J,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))'="") S ABMIDUP=+$G(ABMIDUP)+1  ;part D dup pt

 ....I ABMCOV="A"!(ABMCOV="B") D  ;count patients with active A and/or B

 .....Q:$G(^TMP($J,"ABM-MCRAB",ABMSU,ABMIEN))'=""

 .....S ^TMP($J,"ABM-MCRAB",ABMSU,ABMIEN)=ABMIEN

 .....S ^TMP($J,"ABM-MCRAB",ABMSU,"TOTAL")=+$G(^TMP($J,"ABM-MCRAB",ABMSU,"TOTAL"))+1

 Q

 ;

PRIVATE ;

 S ABMPTIEN=0

 F  S ABMPTIEN=$O(^AUPNPRVT(ABMPTIEN)) Q:+ABMPTIEN=0  D

 .S ABMIEN=0

 .F  S ABMIEN=$O(^AUPNPRVT(ABMPTIEN,11,ABMIEN)) Q:+ABMIEN=0  D

 ..S ABMINS=$P($G(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U)

 ..Q:$G(ABMILIST(ABMINS))=""  ;not on list

 ..S ABMSDT=$P($G(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,6)

 ..S ABMEDT=$P($G(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,7)

 ..I ((ABMSDT=ABMODT)!(ABMSDT<ABMODT)),((ABMEDT>ABMODT)!(ABMEDT="")) D  ;inside date range

 ...S ABMHRN=0

 ...F  S ABMHRN=$O(^AUPNPAT(ABMPTIEN,41,ABMHRN)) Q:+ABMHRN=0  D

 ....S ABMHRNS=$P($G(^AUPNPAT(ABMPTIEN,41,ABMHRN,0)),U,5)  ;inactive?

 ....I ABMALL=0,ABMHRNS="I" Q  ;check exclude inactive flag and status

 ....S ABMSU=$S($P($G(^AUTTLOC(ABMHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABMHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABMISU(ABMSU)=$P($G(^AUTTLOC(ABMHRN,0)),U,13)_", "_$S($P($G(^AUTTLOC(ABMHRN,0)),U,14)'="":$P($G(^DIC(5,$P($G(^AUTTLOC(ABMHRN,0)),U,14),0)),U,2),1:"")

 ....S ABMINAME=$P($G(^AUTNINS(ABMINS,0)),U)  ;insurer name

 ....I $G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN))="" D

 .....S:$P($G(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,8)'="" ABMPN=$P($G(^AUPN3PPH($P($G(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,8),0)),U,4)

 .....S ABMHRNN=$P($G(^AUPNPAT(ABMPTIEN,41,ABMHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN

 .....S ABMICNT(ABMSU,ABMINAME,ABMINS)=+$G(ABMICNT(ABMSU,ABMINAME,ABMINS))+1

 .....S ABMITOT(ABMSU,"TOTAL")=+$G(ABMITOT(ABMSU,"TOTAL"))+1

 .....S ABMITOT("TOTAL")=+$G(ABMITOT("TOTAL"))+1

 ....I $G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN))'="" S ABMIDUP=+$G(ABMIDUP)+1

 Q

 ;

OUTPUT ;

 ;make sure at minimum 0 will print for each insurer selected

 S ESCAPE=0

 S ABMSU=""

 F  S ABMSU=$O(^TMP($J,"ABM-MCRAB",ABMSU)) Q:ABMSU=""  D

 .S ABMNAME=""

 .F  S ABMNAME=$O(ABMINAME(ABMNAME)) Q:ABMNAME=""  D

 ..S ABMINS=$O(ABMINAME(ABMNAME,0))

 ..I '$D(ABMICNT(ABMSU,ABMNAME)) S ABMICNT(ABMSU,ABMNAME,ABMINS)=0

 ;

 S ABMPG=0

 S ABMSU=""

 S ABMSUOLD=""

 D HDR

 F  S ABMSU=$O(ABMICNT(ABMSU)) Q:ABMSU=""  D

 .S ABMNAME=""

 .F  S ABMNAME=$O(ABMICNT(ABMSU,ABMNAME)) Q:ABMNAME=""  D

 ..S ABMINS=0

 ..F  S ABMINS=$O(ABMICNT(ABMSU,ABMNAME,ABMINS)) Q:+ABMINS=0  D

 ...I ABMSUOLD=""!(ABMSUOLD'=ABMSU) D:ABMPG'=1 HDR D SUHDR S ABMSUOLD=ABMSU

 ...W !?2,ABMNAME

 ...S IT=$G(ABMILIST(ABMINS))

 ...W ?40,$S(IT="P":"PRIVATE",IT="MD":"MCR PART D",1:IT)

 ...W ?63,+$G(ABMICNT(ABMSU,ABMNAME,ABMINS))

 ...I $G(ABMDTAIL)=1 D DETAIL

 .W !!,?10,"TOTAL PART D FOR "_ABMSU_" SERVICE UNIT:",?63,+$G(ABMITOT(ABMSU,"TOTAL"))

 .W !,?10,"TOTAL NUMBER OF MEDICARE/RAILROAD ELIG ENROLLEES:",?63,+$G(^TMP($J,"ABM-MCRAB",ABMSU,"TOTAL"))

 ;total

 W !!,?2,"TOTAL NUMBER OF ACTIVE MEDICARE PART D ENROLLEES: "

 W ?63,+$G(ABMITOT("TOTAL")),!

 W !,"(REPORT COMPLETE)",!

 I (IOST[("C-")) Q:ESCAPE  Q:$D(IO("S"))  K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U

 ;cleanup

 K ABMICNT,ABMINAME,ABMILIST

 K ABMLINE,IT,ABMIEN,ABMEIEN,ABMPIEN,ABMNAME,ABMINAME

 K ABMIDUP

 K ABMITOT

 K ^TMP($J,"ABM-MCRD")

 K ^TMP($J,"ABM-MCRAB")

 Q

 ;

HDR ;

 W @IOF

 S ABMPG=ABMPG+1

 S Y=DT X ^DD("DD")

 W !,Y,?68,"Page ",ABMPG

 W !

 D CENTER("REGISTERED PATIENTS - ACTIVE MEDICARE PART D ENROLLEES")

 W !

 S Y=ABMODT X ^DD("DD")

 D CENTER("Actively enrolled as of "_Y)

 Q

SUHDR W !!?2,"Service Unit: ",ABMSU,"  "_$G(ABMISU(ABMSU)),!

 W !?2,"PLAN NAME",?40,"INS TYPE",?60,"COUNT"

 I $G(ABMDTAIL)=1 D

 .W !,?3,"HRN",?15,"SUBSCRIBER NAME",?45,"EFF.DT",?57,"END.DT",?69,"SUBSCR.ID"

 W !,ABMLINE,!

 Q

CENTER(X) ;EP -

 S CENTER=IOM/2

 W ?CENTER-($L(X)/2),X

 Q

DETAIL ;

 S ABMPT=0

 F  S ABMPT=$O(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPT)) Q:+ABMPT=0  D

 .W !?3,$P($G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U)

 .W ?15,$P($G(^DPT(ABMPT,0)),U)

 .W ?45,$$SDT^ABMDUTL($P($G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,2))

 .W ?57,$$SDT^ABMDUTL($P($G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,3))

 .W ?69,$P($G(^TMP($J,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,4)

 .I (IOST[("C-")),(($Y>IOSL)!($Y=IOSL)) Q:ESCAPE  Q:$D(IO("S"))  K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U D HDR,SUHDR

 Q

ABMRMCRD  ;IHS/SD/SDR - MEDICARE PART D REPORT ;    

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

 +2       ;

 +3       ;IHS/SD/SDR - 2.6*21 - HEAT119339 - fix <UNDEF>RAILROAD+9^ABMRMCRD if user typed '^' at

 +4       ;   exclude inactive/deceased pt prompt

 +5       ;;

 +6       ;; ABMILIST(insurer IEN)=insurer type--list of insurers for report

 +7       ;; ABMINAME(insurer name,insurer IEN)=""--by name for display alphabetically

 +8       ;; ABMICNT(SU,insurer name,insurer IEN)=count--count by insurer

 +9       ;; ABMITOT(SU,"TOTAL")=total by service unit

 +10      ;; ABMISU=(SU)=city, state of SU

 +11      ;; ABMITOT("TOTAL")=total for report

 +12      ;; ^TMP($J,"ABM-MCRD",Service Unit,patient IEN)--what patients have been counted

 +13      ;; ABMIDUP=count--if patient is counted under more than one SU

 +14      ;;

 +15       SET $PIECE(ABMLINE,"-",79)="-"

 +16      ;message about report

           DO MESSAGE

 +17      ;get list of insurers we're looking for

           DO GETINS

 +18      ;display list

           DO DISP

 +19      ;do they want to add others to list?

           DO GETMORE

 +20       IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +21      ;display list if more added

           IF $GET(ABMDFLG)=1

               DO DISP

 +22      ;get list for what date?

           DO ELIGDT

 +23       IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +24      ;include inactive/deceased pts?

           DO INACT

 +25      ;abm*2.6*21 IHS/SD/SDR HEAT119339

           IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +26      ;detail?

           DO DETAILQ

 +27       IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +28       DO ^%ZIS

           IF POP

               QUIT 

 +29       USE IO

 +30      ;go count data

           DO COUNTIT

 +31      ;display results

           DO OUTPUT

 +32       DO ^%ZISC

 +33       QUIT 

 +34      ;

MESSAGE   ;

 +1        WRITE !?2,"This option will print a list of Patients who are registered at the"

 +2        WRITE !?2,"facility you select who are currently enrolled in a Medicare Part D"

 +3        WRITE !?2,"plan."

 +4        WRITE !!?2,"You will be asked to enter an ""As of"" date to be used in determining"

 +5        WRITE !?2,"those patients who are ""actively"" enrolled in a plan."

 +6        WRITE !!?2,"The report will be sorted alphabetically by Plan Name."

 +7        QUIT 

 +8       ;

GETINS    ;loop thru insurers and get ones with MD

 +1       ;insurer type

 +2       ;

 +3        KILL ABMILIST,ABMINAME,ABMDFLG,ABMIDUP,^TMP($JOB,"ABM-MCRD"),ABMITOT

 +4        KILL ^TMP($JOB,"ABM-MCRAB")

 +5        SET ABMINS=0

 +6        FOR 

               SET ABMINS=$ORDER(^AUTNINS(ABMINS))

               IF +ABMINS=0

                   QUIT 

               Begin DoDot:1

 +7                IF $EXTRACT($PIECE($GET(^AUTNINS(ABMINS,0)),U),1,2)="D-"

                       Begin DoDot:2

 +8       ;S ABMILIST(ABMINS)=$P($G(^AUTNINS(ABMINS,2)),U)  ;abm*2.6*10 HEAT73780

 +9       ;abm*2.6*10 HEAT73780

                           SET ABMILIST(ABMINS)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")

 +10                       SET ABMINAME($PIECE($GET(^AUTNINS(ABMINS,0)),U),ABMINS)=""

                       End DoDot:2

 +11      ;I $P($G(^AUTNINS(ABMINS,2)),U)="MD" D  ;abm*2.6*10 HEAT73780

 +12      ;abm*2.6*10 HEAT73780

                   IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")="MD"

                       Begin DoDot:2

 +13      ;S ABMILIST(ABMINS)=$P($G(^AUTNINS(ABMINS,2)),U)  ;abm*2.6*10 HEAT73780

 +14      ;abm*2.6*10 HEAT73780

                           SET ABMILIST(ABMINS)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMINS,".211","I"),1,"I")

 +15                       SET ABMINAME($PIECE($GET(^AUTNINS(ABMINS,0)),U),ABMINS)=""

                       End DoDot:2

               End DoDot:1

 +16       QUIT 

 +17      ;

DISP      ;display list of insurers

 +1        KILL ABMIFLG

 +2        WRITE !!?2

 +3        IF +$GET(ABMDFLG)=0

               Begin DoDot:1

 +4                WRITE "The following insurers contain the Insurer Type code of ""MD"" or contain "

 +5                WRITE !?2,"""D-"" in the name of the plan:"

               End DoDot:1

 +6        IF +$GET(ABMDFLG)=1

               WRITE "The following insurers will be included on this report:"

 +7        WRITE !!

 +8        SET ABMNAME=""

 +9        FOR 

               SET ABMNAME=$ORDER(ABMINAME(ABMNAME))

               IF ABMNAME=""

                   QUIT 

               Begin DoDot:1

 +10               WRITE ?10,ABMNAME

 +11               SET ABMINS=$ORDER(ABMINAME(ABMNAME,0))

 +12               SET IT=$PIECE($GET(ABMILIST(ABMINS)),U)

 +13               WRITE ?45,$SELECT(IT="P":"PRIVATE",IT="MD":"MCR PART D",1:IT)

 +14               WRITE !

 +15               SET ABMIFLG=1

               End DoDot:1

 +16       IF +$GET(ABMIFLG)=0

               Begin DoDot:1

 +17               WRITE !?10,"THERE ARE NO INSURERS THAT CURRENTLY HAVE 'MD' AS THE INSURER TYPE"

               End DoDot:1

 +18       QUIT 

 +19      ;

GETMORE   ;do they want more PI insurers?

 +1        SET DIR(0)="Y"

 +2        SET DIR("A")="Do you wish to include any other insurers?"

 +3        SET DIR("B")="N"

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +7        IF Y=1

               Begin DoDot:1

 +8                SET ABMDFLG=1

 +9                FOR 

                       Begin DoDot:2

 +10                       WRITE !

 +11                       KILL X,Y,DIC,DR

 +12                       SET DIC="^AUTNINS("

 +13                       SET DIC(0)="AEMQ"

 +14      ;S DIC("S")="I $P(^AUTNINS(Y,2),U)=""P"""  ;PIs only!  ;abm*2.6*10 HEAT73780

 +15      ;PIs only!  ;abm*2.6*10 HEAT73780

                           SET DIC("S")="I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,Y,"".211"",""I""),1,""I"")=""P"""

 +16                       DO ^DIC

 +17                       IF Y>0

                               Begin DoDot:3

 +18                               WRITE $PIECE(Y,U,2)

 +19      ;S ABMILIST(+Y)=$P($G(^AUTNINS(+Y,2)),U)  ;abm*2.6*10 HEAT73780

 +20      ;abm*2.6*10 HEAT73780

                                   SET ABMILIST(+Y)=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+Y,".211","I"),1,"I")

 +21                               SET ABMINAME($PIECE(Y,U,2),+Y)=""

                               End DoDot:3

                       End DoDot:2

                       IF ($GET(Y)="")!($GET(X)=""&(Y<0))

                           QUIT 

               End DoDot:1

 +22       QUIT 

 +23      ;

ELIGDT    ;get list for what date-default to today

 +1        WRITE !

 +2        KILL DIR,DIC,DIE,X,Y,DR

 +3        SET DIR(0)="D"

 +4        SET DIR("A")="Display eligibility as of what date?"

 +5        SET DIR("B")="Today"

 +6        DO ^DIR

 +7        KILL DIR

 +8        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +9        SET ABMODT=+Y

 +10      ;display date selected

           WRITE "  ("_Y(0)_")"

 +11       QUIT 

 +12      ;

INACT     ;include inactive/deceased pts?

 +1        WRITE !

 +2        KILL DIR,DIC,DIE,X,Y,DR

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="Do you wish to EXCLUDE inactive and deceased patients"

 +5        SET DIR("B")="YES"

 +6        DO ^DIR

 +7        KILL DIR

 +8        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +9       ;exclude

           IF Y=1

               SET ABMALL=0

 +10      ;include all patients

          IF '$TEST

               SET ABMALL=1

 +11       QUIT 

DETAILQ   ;

 +1        WRITE !

 +2        KILL DIR,DIC,DIE,X,Y,DR

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="Do you wish to view detail (patients)"

 +5        SET DIR("B")="NO"

 +6        DO ^DIR

 +7        KILL DIR

 +8        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT 

 +9       ;detail

           IF Y=1

               SET ABMDTAIL=1

 +10      ;summary

          IF '$TEST

               SET ABMDTAIL=0

 +11       QUIT 

 +12      ;

COUNTIT   ;do counts for selected insurers

 +1        DO RAILROAD

 +2        DO MEDICARE

 +3        DO PRIVATE

 +4        QUIT 

 +5       ;

RAILROAD  ;

 +1        SET ABMIEN=0

 +2        FOR 

               SET ABMIEN=$ORDER(^AUPNRRE(ABMIEN))

               IF +ABMIEN=0

                   QUIT 

               Begin DoDot:1

 +3                SET ABMEIEN=0

 +4                FOR 

                       SET ABMEIEN=$ORDER(^AUPNRRE(ABMIEN,11,ABMEIEN))

                       IF +ABMEIEN=0

                           QUIT 

                       Begin DoDot:2

 +5                        SET ABMCOV=$PIECE($GET(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,3)

 +6                        IF ABMCOV="D"

                               SET ABMPIEN=$PIECE($GET(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,4)

 +7                        IF ABMCOV="D"

                               IF ($GET(ABMPIEN)="")

                                   QUIT 

 +8       ;no entry for insurer on requested list

                           IF ABMCOV="D"

                               IF ($GET(ABMILIST(ABMPIEN))="")

                                   QUIT 

 +9       ;check exclude flag and DOD

                           IF ABMALL=0

                               IF ($PIECE($GET(^DPT(ABMIEN,.35)),U)'="")

                                   QUIT 

 +10                       KILL ABMSDT,ABMEDT

 +11                       SET ABMSDT=$PIECE($GET(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U)

 +12                       SET ABMEDT=$PIECE($GET(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,2)

 +13                       IF ((ABMSDT<ABMODT)!(ABMSDT=ABMODT))

                               IF ((ABMEDT>ABMODT)!(ABMEDT=""))

                                   Begin DoDot:3

 +14                                   SET ABMHRN=0

 +15                                   FOR 

                                           SET ABMHRN=$ORDER(^AUPNPAT(ABMIEN,41,ABMHRN))

                                           IF +ABMHRN=0

                                               QUIT 

                                           Begin DoDot:4

 +16      ;inactive?

                                               SET ABMHRNS=$PIECE($GET(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,5)

 +17      ;check exclude inactive flag and status

                                               IF ABMALL=0

                                                   IF ABMHRN="I"

                                                       QUIT 

 +18      ;SU name

                                               SET ABMSU=$SELECT($PIECE($GET(^AUTTLOC(ABMHRN,0)),U,5)'="":$PIECE($GET(^AUTTSU($PIECE($GET(^AUTTLOC(ABMHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")

 +19                                           SET ABMISU(ABMSU)=$PIECE($GET(^AUTTLOC(ABMHRN,0)),U,13)_", "_$SELECT($PIECE($GET(^AUTTLOC(ABMHRN,0)),U,14)'="":$PIECE($GET(^DIC(5,$PIECE($GET(^AUTTLOC(ABMHRN,0)),U,14),0)),U,2),1:"")

 +20      ;insurer name

                                               IF ABMCOV="D"

                                                   SET ABMINAME=$PIECE($GET(^AUTNINS(ABMPIEN,0)),U)

 +21                                           IF ABMCOV="D"

                                                   IF ($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))="")

                                                       Begin DoDot:5

 +22      ;ID

                                                           SET ABMPN=$PIECE($GET(^AUPNRRE(ABMIEN,11,ABMEIEN,0)),U,6)

 +23      ;HRN