APCLPYR2 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Medicare ;
;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
Q
;
MRALOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Medicare Part A"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN D Q:$D(DUOUT)
.;Check if Patient is registered here
.S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
.I Y="" Q
.I Y<1 Q
.;
.I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
.I APCLSORT="HRNO" S APCLSRT=Y
.;
.;--> Check for Other Insurance if user picked this option
.I APCLOTH=1 D Q:APCLICTR>1
..S APCLICTR=0
..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..S X=0
..F S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X S APCLICTR=APCLICTR+1
.;
.S APCLCTR=0
.S APCLIEN=0
.S APCLFLAG=0
.F S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg elig dates after beg date
..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
..;--> Beg Date is earlier than selected end date
..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
..;--> End date is before selected begin date
..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
.I APCLFLAG D
..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN) ;IHS/CMI/LAB NMCI PATCH 21
..S APCLMRSF=""
..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
..I X S APCLMRSF=$G(^AUTTMCS(X,0))
..I APCLOTH,APCLCTR=1 D STORE
..I APCLOTH=0 D STORE
;
S APCLCTR=0
S APCLSRT=""
F S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT="" D Q:$D(DUOUT)
.S X=^TMP($J,"APCLPYR",APCLSRT)
.S APCLDFN=$P(X,U)
.S APCLBEG=$P(X,U,2)
.S APCLEND=$P(X,U,3)
.S APCLMRNO=$P(X,U,4)
.S APCLMRSF=$P(X,U,5)
.D WRT
.S APCLCTR=APCLCTR+1
.I $Y>(IOSL-5) D I '$D(DUOUT) D HEADING
..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
;
I '$D(DUOUT) W !!,"Total: ",APCLCTR
Q
;
MRBLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Medicare Part B"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN D Q:$D(DUOUT)
.;Check if Patient is registered here
.S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
.I Y="" Q
.I Y<1 Q
.;
.I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
.I APCLSORT="HRNO" S APCLSRT=Y
.;
.;--> Check for Other Insurance if user picked this option
.I APCLOTH=1 D Q:APCLICTR>1
..S APCLICTR=0
..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..S X=0
..F S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X S APCLICTR=APCLICTR+1
.;
.S APCLCTR=0
.S APCLIEN=0
.S APCLFLAG=0
.F S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg elig dates after beg date
..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
..;--> Beg Date is earlier than selected end date
..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
..;--> End date is before selected begin date
..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
.I APCLFLAG D
..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN) ;IHS/CMI/LAB NMCI PATCH 21
..S APCLMRSF=""
..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
..I X S APCLMRSF=$G(^AUTTMCS(X,0))
..I APCLOTH,APCLCTR=1 D STORE
..I APCLOTH=0 D STORE
;
S APCLCTR=0
S APCLSRT=""
F S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT="" D Q:$D(DUOUT)
.S X=^TMP($J,"APCLPYR",APCLSRT)
.S APCLDFN=$P(X,U)
.S APCLBEG=$P(X,U,2)
.S APCLEND=$P(X,U,3)
.S APCLMRNO=$P(X,U,4)
.S APCLMRSF=$P(X,U,5)
.D WRT
.S APCLCTR=APCLCTR+1
.I $Y>(IOSL-5) D I '$D(DUOUT) D HEADING
..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
;
I '$D(DUOUT) W !!,"Total: ",APCLCTR
Q
;
MRDLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Medicare Part D"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNMCR(APCLDFN)) Q:'APCLDFN D Q:$D(DUOUT)
.;Check if Patient is registered here
.S Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
.I Y="" Q
.I Y<1 Q
.;
.I APCLSORT="NAME" S APCLSRT=$P(^DPT(APCLDFN,0),U)_U_APCLDFN
.I APCLSORT="HRNO" S APCLSRT=Y
.;
.;--> Check for Other Insurance if user picked this option
.I APCLOTH=1 D Q:APCLICTR>1
..S APCLICTR=0
..I +$O(^AUPNMCR("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..I +$O(^AUPNRRE("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
..S X=0
..F S X=$O(^AUPNPRVT("B",APCLDFN,11,X)) Q:'X S APCLICTR=APCLICTR+1
.;
.S APCLCTR=0
.S APCLIEN=0
.S APCLFLAG=0
.F S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg elig dates after beg date
..I APCLACT=2,APCLBEG<APCLBDAT S APCLFLAG=0
..;--> Beg Date is earlier than selected end date
..I APCLACT,APCLEDAT>0,APCLBEG>APCLEDAT S APCLFLAG=0
..;--> End date is before selected begin date
..I APCLACT,APCLEND>0,APCLEND<APCLBDAT S APCLFLAG=0
.I APCLFLAG D
..;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
..S APCLMRNO=$$GETMCR^AGUTL(APCLDFN) ;IHS/CMI/LAB NMCI PATCH 21
..S APCLMRSF=""
..S X=$P(^AUPNMCR(APCLDFN,0),U,4)
..I X S APCLMRSF=$G(^AUTTMCS(X,0))
..I APCLOTH,APCLCTR=1 D STORE
..I APCLOTH=0 D STORE
;
S APCLCTR=0
S APCLSRT=""
F S APCLSRT=$O(^TMP($J,"APCLPYR",APCLSRT)) Q:APCLSRT="" D Q:$D(DUOUT)
.S X=^TMP($J,"APCLPYR",APCLSRT)
.S APCLDFN=$P(X,U)
.S APCLBEG=$P(X,U,2)
.S APCLEND=$P(X,U,3)
.S APCLMRNO=$P(X,U,4)
.S APCLMRSF=$P(X,U,5)
.D WRT
.S APCLCTR=APCLCTR+1
.I $Y>(IOSL-5) D I '$D(DUOUT) D HEADING
..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
;
I '$D(DUOUT) W !!,"Total: ",APCLCTR
Q
;
STORE ;
S ^TMP($J,"APCLPYR",APCLSRT)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLMRNO_U_APCLMRSF
Q
;
WRT ;
W $P(^DPT(APCLDFN,0),U)
W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
W ?41,APCLMRNO
W ?53,APCLMRSF
I APCLALL=0 D Q
.W ?57,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
.I APCLEND W ?67,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
.W !
S APCLIEN=0
F S APCLIEN=$O(^AUPNMCR(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
.S APCLBEG=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
.I APCLACT=2,APCLBEG<APCLBDAT Q
.S APCLEND=$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
.I APCLTYP="MRA",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
.I APCLTYP="MRB",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
.I APCLTYP="MRD",$P(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D" Q
.W ?57,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
.I APCLEND W ?67,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
.W !
Q
;
HEADING ;
D ^XBCLS
W !
S X=DT
W $E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
S X=$P($G(^DIC(4,APCLFAC,0)),U)
W ?((IOM-$L(X))/2),X
S APCLPAGE=APCLPAGE+1
W ?70,"Page ",APCLPAGE
W !
;
S X="Patient List for "_APCLINAM
W ?((IOM-$L(X))/2),X,!
;
S X=""
I APCLOTH=1 S X=X_"Having only this insurance"
I X]"" W ?((IOM-$L(X))/2),X,!
;
S X=""
I APCLACT=0 S X=X_"With any eligibility dates"
I APCLACT D
.S X=X_"With eligibility "
.I $G(APCLEDAT)=$G(APCLBDAT) S X=X_"as of "
.I $G(APCLEDAT)'=$G(APCLBDAT) S X=X_"from "
.S X=X_$E(APCLBDAT,4,5)_"/"_$E(APCLBDAT,6,7)_"/"_$E(APCLBDAT,2,3)
.I $G(APCLEDAT)=$G(APCLBDAT) Q
.I $G(APCLEDAT)="" Q
.S X=X_" to "
.S X=X_$E(APCLEDAT,4,5)_"/"_$E(APCLEDAT,6,7)_"/"_$E(APCLEDAT,2,3)
I X]"" W ?((IOM-$L(X))/2),X,!
;
W !
;
W "Patient Name",?33,"HRNO",?43,"MCR #",?52,"SUF",?59,"Begin",?69,"End"
W !
;
W "------------",?32,"------",?41,"---------",?52,"---",?57,"--------",?67,"--------"
W !
Q
APCLPYR2 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Medicare ;
+1 ;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
+2 QUIT
+3 ;
MRALOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Medicare Part A"
+3 KILL ^TMP($JOB,"APCLPYR")
+4 SET APCLPAGE=0
+5 ;
+6 DO HEADING
+7 ;
+8 SET APCLDFN=0
+9 FOR
SET APCLDFN=$ORDER(^AUPNMCR(APCLDFN))
IF 'APCLDFN
QUIT
Begin DoDot:1
+10 ;Check if Patient is registered here
+11 SET Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
+12 IF Y=""
QUIT
+13 IF Y<1
QUIT
+14 ;
+15 IF APCLSORT="NAME"
SET APCLSRT=$PIECE(^DPT(APCLDFN,0),U)_U_APCLDFN
+16 IF APCLSORT="HRNO"
SET APCLSRT=Y
+17 ;
+18 ;--> Check for Other Insurance if user picked this option
+19 IF APCLOTH=1
Begin DoDot:2
+20 SET APCLICTR=0
+21 IF +$ORDER(^AUPNMCR("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+22 IF +$ORDER(^AUPNMCD("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+23 IF +$ORDER(^AUPNRRE("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+24 SET X=0
+25 FOR
SET X=$ORDER(^AUPNPRVT("B",APCLDFN,11,X))
IF 'X
QUIT
SET APCLICTR=APCLICTR+1
End DoDot:2
IF APCLICTR>1
QUIT
+26 ;
+27 SET APCLCTR=0
+28 SET APCLIEN=0
+29 SET APCLFLAG=0
+30 FOR
SET APCLIEN=$ORDER(^AUPNMCR(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A"
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
+35 SET APCLEND=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
+36 ;--> There is no Beg Date
+37 IF APCLACT
IF APCLBEG=""
SET APCLFLAG=0
+38 ;--> User wants to restrict to beg elig dates after beg date
+39 IF APCLACT=2
IF APCLBEG<APCLBDAT
SET APCLFLAG=0
+40 ;--> Beg Date is earlier than selected end date
+41 IF APCLACT
IF APCLEDAT>0
IF APCLBEG>APCLEDAT
SET APCLFLAG=0
+42 ;--> End date is before selected begin date
+43 IF APCLACT
IF APCLEND>0
IF APCLEND<APCLBDAT
SET APCLFLAG=0
End DoDot:2
+44 IF APCLFLAG
Begin DoDot:2
+45 ;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
+46 ;IHS/CMI/LAB NMCI PATCH 21
SET APCLMRNO=$$GETMCR^AGUTL(APCLDFN)
+47 SET APCLMRSF=""
+48 SET X=$PIECE(^AUPNMCR(APCLDFN,0),U,4)
+49 IF X
SET APCLMRSF=$GET(^AUTTMCS(X,0))
+50 IF APCLOTH
IF APCLCTR=1
DO STORE
+51 IF APCLOTH=0
DO STORE
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+52 ;
+53 SET APCLCTR=0
+54 SET APCLSRT=""
+55 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+56 SET X=^TMP($JOB,"APCLPYR",APCLSRT)
+57 SET APCLDFN=$PIECE(X,U)
+58 SET APCLBEG=$PIECE(X,U,2)
+59 SET APCLEND=$PIECE(X,U,3)
+60 SET APCLMRNO=$PIECE(X,U,4)
+61 SET APCLMRSF=$PIECE(X,U,5)
+62 DO WRT
+63 SET APCLCTR=APCLCTR+1
+64 IF $Y>(IOSL-5)
Begin DoDot:2
+65 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:2
IF '$DATA(DUOUT)
DO HEADING
End DoDot:1
IF $DATA(DUOUT)
QUIT
+66 ;
+67 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+68 QUIT
+69 ;
MRBLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Medicare Part B"
+3 KILL ^TMP($JOB,"APCLPYR")
+4 SET APCLPAGE=0
+5 ;
+6 DO HEADING
+7 ;
+8 SET APCLDFN=0
+9 FOR
SET APCLDFN=$ORDER(^AUPNMCR(APCLDFN))
IF 'APCLDFN
QUIT
Begin DoDot:1
+10 ;Check if Patient is registered here
+11 SET Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
+12 IF Y=""
QUIT
+13 IF Y<1
QUIT
+14 ;
+15 IF APCLSORT="NAME"
SET APCLSRT=$PIECE(^DPT(APCLDFN,0),U)_U_APCLDFN
+16 IF APCLSORT="HRNO"
SET APCLSRT=Y
+17 ;
+18 ;--> Check for Other Insurance if user picked this option
+19 IF APCLOTH=1
Begin DoDot:2
+20 SET APCLICTR=0
+21 IF +$ORDER(^AUPNMCR("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+22 IF +$ORDER(^AUPNMCD("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+23 IF +$ORDER(^AUPNRRE("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+24 SET X=0
+25 FOR
SET X=$ORDER(^AUPNPRVT("B",APCLDFN,11,X))
IF 'X
QUIT
SET APCLICTR=APCLICTR+1
End DoDot:2
IF APCLICTR>1
QUIT
+26 ;
+27 SET APCLCTR=0
+28 SET APCLIEN=0
+29 SET APCLFLAG=0
+30 FOR
SET APCLIEN=$ORDER(^AUPNMCR(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B"
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
+35 SET APCLEND=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
+36 ;--> There is no Beg Date
+37 IF APCLACT
IF APCLBEG=""
SET APCLFLAG=0
+38 ;--> User wants to restrict to beg elig dates after beg date
+39 IF APCLACT=2
IF APCLBEG<APCLBDAT
SET APCLFLAG=0
+40 ;--> Beg Date is earlier than selected end date
+41 IF APCLACT
IF APCLEDAT>0
IF APCLBEG>APCLEDAT
SET APCLFLAG=0
+42 ;--> End date is before selected begin date
+43 IF APCLACT
IF APCLEND>0
IF APCLEND<APCLBDAT
SET APCLFLAG=0
End DoDot:2
+44 IF APCLFLAG
Begin DoDot:2
+45 ;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
+46 ;IHS/CMI/LAB NMCI PATCH 21
SET APCLMRNO=$$GETMCR^AGUTL(APCLDFN)
+47 SET APCLMRSF=""
+48 SET X=$PIECE(^AUPNMCR(APCLDFN,0),U,4)
+49 IF X
SET APCLMRSF=$GET(^AUTTMCS(X,0))
+50 IF APCLOTH
IF APCLCTR=1
DO STORE
+51 IF APCLOTH=0
DO STORE
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+52 ;
+53 SET APCLCTR=0
+54 SET APCLSRT=""
+55 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+56 SET X=^TMP($JOB,"APCLPYR",APCLSRT)
+57 SET APCLDFN=$PIECE(X,U)
+58 SET APCLBEG=$PIECE(X,U,2)
+59 SET APCLEND=$PIECE(X,U,3)
+60 SET APCLMRNO=$PIECE(X,U,4)
+61 SET APCLMRSF=$PIECE(X,U,5)
+62 DO WRT
+63 SET APCLCTR=APCLCTR+1
+64 IF $Y>(IOSL-5)
Begin DoDot:2
+65 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:2
IF '$DATA(DUOUT)
DO HEADING
End DoDot:1
IF $DATA(DUOUT)
QUIT
+66 ;
+67 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+68 QUIT
+69 ;
MRDLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Medicare Part D"
+3 KILL ^TMP($JOB,"APCLPYR")
+4 SET APCLPAGE=0
+5 ;
+6 DO HEADING
+7 ;
+8 SET APCLDFN=0
+9 FOR
SET APCLDFN=$ORDER(^AUPNMCR(APCLDFN))
IF 'APCLDFN
QUIT
Begin DoDot:1
+10 ;Check if Patient is registered here
+11 SET Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
+12 IF Y=""
QUIT
+13 IF Y<1
QUIT
+14 ;
+15 IF APCLSORT="NAME"
SET APCLSRT=$PIECE(^DPT(APCLDFN,0),U)_U_APCLDFN
+16 IF APCLSORT="HRNO"
SET APCLSRT=Y
+17 ;
+18 ;--> Check for Other Insurance if user picked this option
+19 IF APCLOTH=1
Begin DoDot:2
+20 SET APCLICTR=0
+21 IF +$ORDER(^AUPNMCR("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+22 IF +$ORDER(^AUPNMCD("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+23 IF +$ORDER(^AUPNRRE("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+24 SET X=0
+25 FOR
SET X=$ORDER(^AUPNPRVT("B",APCLDFN,11,X))
IF 'X
QUIT
SET APCLICTR=APCLICTR+1
End DoDot:2
IF APCLICTR>1
QUIT
+26 ;
+27 SET APCLCTR=0
+28 SET APCLIEN=0
+29 SET APCLFLAG=0
+30 FOR
SET APCLIEN=$ORDER(^AUPNMCR(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D"
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
+35 SET APCLEND=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
+36 ;--> There is no Beg Date
+37 IF APCLACT
IF APCLBEG=""
SET APCLFLAG=0
+38 ;--> User wants to restrict to beg elig dates after beg date
+39 IF APCLACT=2
IF APCLBEG<APCLBDAT
SET APCLFLAG=0
+40 ;--> Beg Date is earlier than selected end date
+41 IF APCLACT
IF APCLEDAT>0
IF APCLBEG>APCLEDAT
SET APCLFLAG=0
+42 ;--> End date is before selected begin date
+43 IF APCLACT
IF APCLEND>0
IF APCLEND<APCLBDAT
SET APCLFLAG=0
End DoDot:2
+44 IF APCLFLAG
Begin DoDot:2
+45 ;S APCLMRNO=$P(^AUPNMCR(APCLDFN,0),U,3)
+46 ;IHS/CMI/LAB NMCI PATCH 21
SET APCLMRNO=$$GETMCR^AGUTL(APCLDFN)
+47 SET APCLMRSF=""
+48 SET X=$PIECE(^AUPNMCR(APCLDFN,0),U,4)
+49 IF X
SET APCLMRSF=$GET(^AUTTMCS(X,0))
+50 IF APCLOTH
IF APCLCTR=1
DO STORE
+51 IF APCLOTH=0
DO STORE
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+52 ;
+53 SET APCLCTR=0
+54 SET APCLSRT=""
+55 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+56 SET X=^TMP($JOB,"APCLPYR",APCLSRT)
+57 SET APCLDFN=$PIECE(X,U)
+58 SET APCLBEG=$PIECE(X,U,2)
+59 SET APCLEND=$PIECE(X,U,3)
+60 SET APCLMRNO=$PIECE(X,U,4)
+61 SET APCLMRSF=$PIECE(X,U,5)
+62 DO WRT
+63 SET APCLCTR=APCLCTR+1
+64 IF $Y>(IOSL-5)
Begin DoDot:2
+65 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:2
IF '$DATA(DUOUT)
DO HEADING
End DoDot:1
IF $DATA(DUOUT)
QUIT
+66 ;
+67 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+68 QUIT
+69 ;
STORE ;
+1 SET ^TMP($JOB,"APCLPYR",APCLSRT)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLMRNO_U_APCLMRSF
+2 QUIT
+3 ;
WRT ;
+1 WRITE $PIECE(^DPT(APCLDFN,0),U)
+2 WRITE ?32,$JUSTIFY($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
+3 WRITE ?41,APCLMRNO
+4 WRITE ?53,APCLMRSF
+5 IF APCLALL=0
Begin DoDot:1
+6 WRITE ?57,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+7 IF APCLEND
WRITE ?67,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
+8 WRITE !
End DoDot:1
QUIT
+9 SET APCLIEN=0
+10 FOR
SET APCLIEN=$ORDER(^AUPNMCR(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:1
+11 SET APCLBEG=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U)
+12 IF APCLACT=2
IF APCLBEG<APCLBDAT
QUIT
+13 SET APCLEND=$PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,2)
+14 IF APCLTYP="MRA"
IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="A"
QUIT
+15 IF APCLTYP="MRB"
IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="B"
QUIT
+16 IF APCLTYP="MRD"
IF $PIECE(^AUPNMCR(APCLDFN,11,APCLIEN,0),U,3)'="D"
QUIT
+17 WRITE ?57,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+18 IF APCLEND
WRITE ?67,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
+19 WRITE !
End DoDot:1
+20 QUIT
+21 ;
HEADING ;
+1 DO ^XBCLS
+2 WRITE !
+3 SET X=DT
+4 WRITE $EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
+5 SET X=$PIECE($GET(^DIC(4,APCLFAC,0)),U)
+6 WRITE ?((IOM-$LENGTH(X))/2),X
+7 SET APCLPAGE=APCLPAGE+1
+8 WRITE ?70,"Page ",APCLPAGE
+9 WRITE !
+10 ;
+11 SET X="Patient List for "_APCLINAM
+12 WRITE ?((IOM-$LENGTH(X))/2),X,!
+13 ;
+14 SET X=""
+15 IF APCLOTH=1
SET X=X_"Having only this insurance"
+16 IF X]""
WRITE ?((IOM-$LENGTH(X))/2),X,!
+17 ;
+18 SET X=""
+19 IF APCLACT=0
SET X=X_"With any eligibility dates"
+20 IF APCLACT
Begin DoDot:1
+21 SET X=X_"With eligibility "
+22 IF $GET(APCLEDAT)=$GET(APCLBDAT)
SET X=X_"as of "
+23 IF $GET(APCLEDAT)'=$GET(APCLBDAT)
SET X=X_"from "
+24 SET X=X_$EXTRACT(APCLBDAT,4,5)_"/"_$EXTRACT(APCLBDAT,6,7)_"/"_$EXTRACT(APCLBDAT,2,3)
+25 IF $GET(APCLEDAT)=$GET(APCLBDAT)
QUIT
+26 IF $GET(APCLEDAT)=""
QUIT
+27 SET X=X_" to "
+28 SET X=X_$EXTRACT(APCLEDAT,4,5)_"/"_$EXTRACT(APCLEDAT,6,7)_"/"_$EXTRACT(APCLEDAT,2,3)
End DoDot:1
+29 IF X]""
WRITE ?((IOM-$LENGTH(X))/2),X,!
+30 ;
+31 WRITE !
+32 ;
+33 WRITE "Patient Name",?33,"HRNO",?43,"MCR #",?52,"SUF",?59,"Begin",?69,"End"
+34 WRITE !
+35 ;
+36 WRITE "------------",?32,"------",?41,"---------",?52,"---",?57,"--------",?67,"--------"
+37 WRITE !
+38 QUIT
