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
SET ABMHRNN=$PIECE($GET(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,2)
+24 SET ^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN
+25 SET ABMICNT(ABMSU,ABMINAME,ABMPIEN)=+$GET(ABMICNT(ABMSU,ABMINAME,ABMPIEN))+1
+26 SET ABMITOT(ABMSU,"TOTAL")=+$GET(ABMITOT(ABMSU,"TOTAL"))+1
+27 SET ABMITOT("TOTAL")=+$GET(ABMITOT("TOTAL"))+1
+28 SET ABMBTHCT(ABMSU,"TOTAL")=$GET(ABMBTHCT(ABMSU,"TOTAL"))+1
End DoDot:5
+29 IF ABMCOV="D"
IF ($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))'="")
SET ABMIDUP=+$GET(ABMIDUP)+1
+30 ;count patients with active A and/or B
IF ABMCOV="A"!(ABMCOV="B")
Begin DoDot:5
+31 IF $GET(^TMP($JOB,"ABM-MCRAB",ABMSU,ABMIEN))'=""
QUIT
+32 SET ^TMP($JOB,"ABM-MCRAB",ABMSU,ABMIEN)=ABMIEN
+33 SET ^TMP($JOB,"ABM-MCRAB",ABMSU,"TOTAL")=+$GET(^TMP($JOB,"ABM-MCRAB",ABMSU,"TOTAL"))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
MEDICARE ;
+1 SET ABMIEN=0
+2 FOR
SET ABMIEN=$ORDER(^AUPNMCR(ABMIEN))
IF +ABMIEN=0
QUIT
Begin DoDot:1
+3 SET ABMEIEN=0
+4 FOR
SET ABMEIEN=$ORDER(^AUPNMCR(ABMIEN,11,ABMEIEN))
IF +ABMEIEN=0
QUIT
Begin DoDot:2
+5 SET ABMCOV=$PIECE($GET(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,3)
+6 IF ABMCOV="D"
SET ABMPIEN=$PIECE($GET(^AUPNMCR(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(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U)
+12 SET ABMEDT=$PIECE($GET(^AUPNMCR(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 ABMSUC=$PIECE($GET(^AUTTLOC(ABMHRN,0)),U,13)
+20 SET ABMSUS=$PIECE($GET(^AUTTLOC(ABMHRN,0)),U,14)
+21 SET ABMISU(ABMSU)=ABMSUC_", "_$SELECT(ABMSUS'="":$PIECE($GET(^DIC(5,ABMSUS,0)),U,2),1:"")
+22 ;insurer name
IF ABMCOV="D"
SET ABMINAME=$PIECE($GET(^AUTNINS(ABMPIEN,0)),U)
+23 ;part D and not on list already
IF ABMCOV="D"
IF ($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))="")
Begin DoDot:5
+24 ;ID
SET ABMPN=$PIECE($GET(^AUPNMCR(ABMIEN,11,ABMEIEN,0)),U,6)
+25 ;HRN
SET ABMHRNN=$PIECE($GET(^AUPNPAT(ABMIEN,41,ABMHRN,0)),U,2)
+26 SET ^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN
+27 SET ABMICNT(ABMSU,ABMINAME,ABMPIEN)=+$GET(ABMICNT(ABMSU,ABMINAME,ABMPIEN))+1
+28 SET ABMITOT(ABMSU,"TOTAL")=+$GET(ABMITOT(ABMSU,"TOTAL"))+1
+29 SET ABMITOT("TOTAL")=+$GET(ABMITOT("TOTAL"))+1
End DoDot:5
+30 ;part D dup pt
IF ABMCOV="D"
IF ($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMPIEN,ABMIEN))'="")
SET ABMIDUP=+$GET(ABMIDUP)+1
+31 ;count patients with active A and/or B
IF ABMCOV="A"!(ABMCOV="B")
Begin DoDot:5
+32 IF $GET(^TMP($JOB,"ABM-MCRAB",ABMSU,ABMIEN))'=""
QUIT
+33 SET ^TMP($JOB,"ABM-MCRAB",ABMSU,ABMIEN)=ABMIEN
+34 SET ^TMP($JOB,"ABM-MCRAB",ABMSU,"TOTAL")=+$GET(^TMP($JOB,"ABM-MCRAB",ABMSU,"TOTAL"))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
PRIVATE ;
+1 SET ABMPTIEN=0
+2 FOR
SET ABMPTIEN=$ORDER(^AUPNPRVT(ABMPTIEN))
IF +ABMPTIEN=0
QUIT
Begin DoDot:1
+3 SET ABMIEN=0
+4 FOR
SET ABMIEN=$ORDER(^AUPNPRVT(ABMPTIEN,11,ABMIEN))
IF +ABMIEN=0
QUIT
Begin DoDot:2
+5 SET ABMINS=$PIECE($GET(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U)
+6 ;not on list
IF $GET(ABMILIST(ABMINS))=""
QUIT
+7 SET ABMSDT=$PIECE($GET(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,6)
+8 SET ABMEDT=$PIECE($GET(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,7)
+9 ;inside date range
IF ((ABMSDT=ABMODT)!(ABMSDT<ABMODT))
IF ((ABMEDT>ABMODT)!(ABMEDT=""))
Begin DoDot:3
+10 SET ABMHRN=0
+11 FOR
SET ABMHRN=$ORDER(^AUPNPAT(ABMPTIEN,41,ABMHRN))
IF +ABMHRN=0
QUIT
Begin DoDot:4
+12 ;inactive?
SET ABMHRNS=$PIECE($GET(^AUPNPAT(ABMPTIEN,41,ABMHRN,0)),U,5)
+13 ;check exclude inactive flag and status
IF ABMALL=0
IF ABMHRNS="I"
QUIT
+14 ;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")
+15 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:"")
+16 ;insurer name
SET ABMINAME=$PIECE($GET(^AUTNINS(ABMINS,0)),U)
+17 IF $GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN))=""
Begin DoDot:5
+18 IF $PIECE($GET(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,8)'=""
SET ABMPN=$PIECE($GET(^AUPN3PPH($PIECE($GET(^AUPNPRVT(ABMPTIEN,11,ABMIEN,0)),U,8),0)),U,4)
+19 ;HRN
SET ABMHRNN=$PIECE($GET(^AUPNPAT(ABMPTIEN,41,ABMHRN,0)),U,2)
+20 SET ^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN)=ABMHRNN_U_ABMSDT_U_ABMEDT_U_ABMPN
+21 SET ABMICNT(ABMSU,ABMINAME,ABMINS)=+$GET(ABMICNT(ABMSU,ABMINAME,ABMINS))+1
+22 SET ABMITOT(ABMSU,"TOTAL")=+$GET(ABMITOT(ABMSU,"TOTAL"))+1
+23 SET ABMITOT("TOTAL")=+$GET(ABMITOT("TOTAL"))+1
End DoDot:5
+24 IF $GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPTIEN))'=""
SET ABMIDUP=+$GET(ABMIDUP)+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
OUTPUT ;
+1 ;make sure at minimum 0 will print for each insurer selected
+2 SET ESCAPE=0
+3 SET ABMSU=""
+4 FOR
SET ABMSU=$ORDER(^TMP($JOB,"ABM-MCRAB",ABMSU))
IF ABMSU=""
QUIT
Begin DoDot:1
+5 SET ABMNAME=""
+6 FOR
SET ABMNAME=$ORDER(ABMINAME(ABMNAME))
IF ABMNAME=""
QUIT
Begin DoDot:2
+7 SET ABMINS=$ORDER(ABMINAME(ABMNAME,0))
+8 IF '$DATA(ABMICNT(ABMSU,ABMNAME))
SET ABMICNT(ABMSU,ABMNAME,ABMINS)=0
End DoDot:2
End DoDot:1
+9 ;
+10 SET ABMPG=0
+11 SET ABMSU=""
+12 SET ABMSUOLD=""
+13 DO HDR
+14 FOR
SET ABMSU=$ORDER(ABMICNT(ABMSU))
IF ABMSU=""
QUIT
Begin DoDot:1
+15 SET ABMNAME=""
+16 FOR
SET ABMNAME=$ORDER(ABMICNT(ABMSU,ABMNAME))
IF ABMNAME=""
QUIT
Begin DoDot:2
+17 SET ABMINS=0
+18 FOR
SET ABMINS=$ORDER(ABMICNT(ABMSU,ABMNAME,ABMINS))
IF +ABMINS=0
QUIT
Begin DoDot:3
+19 IF ABMSUOLD=""!(ABMSUOLD'=ABMSU)
IF ABMPG'=1
DO HDR
DO SUHDR
SET ABMSUOLD=ABMSU
+20 WRITE !?2,ABMNAME
+21 SET IT=$GET(ABMILIST(ABMINS))
+22 WRITE ?40,$SELECT(IT="P":"PRIVATE",IT="MD":"MCR PART D",1:IT)
+23 WRITE ?63,+$GET(ABMICNT(ABMSU,ABMNAME,ABMINS))
+24 IF $GET(ABMDTAIL)=1
DO DETAIL
End DoDot:3
End DoDot:2
+25 WRITE !!,?10,"TOTAL PART D FOR "_ABMSU_" SERVICE UNIT:",?63,+$GET(ABMITOT(ABMSU,"TOTAL"))
+26 WRITE !,?10,"TOTAL NUMBER OF MEDICARE/RAILROAD ELIG ENROLLEES:",?63,+$GET(^TMP($JOB,"ABM-MCRAB",ABMSU,"TOTAL"))
End DoDot:1
+27 ;total
+28 WRITE !!,?2,"TOTAL NUMBER OF ACTIVE MEDICARE PART D ENROLLEES: "
+29 WRITE ?63,+$GET(ABMITOT("TOTAL")),!
+30 WRITE !,"(REPORT COMPLETE)",!
+31 IF (IOST[("C-"))
IF ESCAPE
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
+32 ;cleanup
+33 KILL ABMICNT,ABMINAME,ABMILIST
+34 KILL ABMLINE,IT,ABMIEN,ABMEIEN,ABMPIEN,ABMNAME,ABMINAME
+35 KILL ABMIDUP
+36 KILL ABMITOT
+37 KILL ^TMP($JOB,"ABM-MCRD")
+38 KILL ^TMP($JOB,"ABM-MCRAB")
+39 QUIT
+40 ;
HDR ;
+1 WRITE @IOF
+2 SET ABMPG=ABMPG+1
+3 SET Y=DT
XECUTE ^DD("DD")
+4 WRITE !,Y,?68,"Page ",ABMPG
+5 WRITE !
+6 DO CENTER("REGISTERED PATIENTS - ACTIVE MEDICARE PART D ENROLLEES")
+7 WRITE !
+8 SET Y=ABMODT
XECUTE ^DD("DD")
+9 DO CENTER("Actively enrolled as of "_Y)
+10 QUIT
SUHDR WRITE !!?2,"Service Unit: ",ABMSU," "_$GET(ABMISU(ABMSU)),!
+1 WRITE !?2,"PLAN NAME",?40,"INS TYPE",?60,"COUNT"
+2 IF $GET(ABMDTAIL)=1
Begin DoDot:1
+3 WRITE !,?3,"HRN",?15,"SUBSCRIBER NAME",?45,"EFF.DT",?57,"END.DT",?69,"SUBSCR.ID"
End DoDot:1
+4 WRITE !,ABMLINE,!
+5 QUIT
CENTER(X) ;EP -
+1 SET CENTER=IOM/2
+2 WRITE ?CENTER-($LENGTH(X)/2),X
+3 QUIT
DETAIL ;
+1 SET ABMPT=0
+2 FOR
SET ABMPT=$ORDER(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPT))
IF +ABMPT=0
QUIT
Begin DoDot:1
+3 WRITE !?3,$PIECE($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U)
+4 WRITE ?15,$PIECE($GET(^DPT(ABMPT,0)),U)
+5 WRITE ?45,$$SDT^ABMDUTL($PIECE($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,2))
+6 WRITE ?57,$$SDT^ABMDUTL($PIECE($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,3))
+7 WRITE ?69,$PIECE($GET(^TMP($JOB,"ABM-MCRD",ABMSU,ABMINS,ABMPT)),U,4)
+8 IF (IOST[("C-"))
IF (($Y>IOSL)!($Y=IOSL))
IF ESCAPE
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
DO HDR
DO SUHDR
End DoDot:1
+9 QUIT
