APCLPYR5 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Railroad ;
;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
;
Q
;
RRALOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Railroad Retirement Part A"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNRRE(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
.;
.I Y<1 Q
.S APCLCTR=0
.S APCLIEN=0
.S APCLFLAG=0
.F S APCLIEN=$O(^AUPNRRE(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg dates before begin 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 APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
..S APCLRRNO=$$GETRRE^AGUTL(APCLDFN) ;IHS/CMI/LAB - PATCH 21 NMCI
..S APCLRRPR=""
..S X=$P(^AUPNRRE(APCLDFN,0),U,3)
..I X S APCLRRPR=$G(^AUTTRRP(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 APCLRRPR=$P(X,U,4)
.S APCLRRNO=$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
;
RRBLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Railroad Retirement Part B"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNRRE(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(^AUPNRRE(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg dates before begin 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 APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
..S APCLRRNO=$$GETRRE^AGUTL(APCLDFN) ;IHS/CMI/LAB - NMCI PATCH 21
..S APCLRRPR=""
..S X=$P(^AUPNRRE(APCLDFN,0),U,3)
..I X S APCLRRPR=$G(^AUTTRRP(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 APCLRRPR=$P(X,U,4)
.S APCLRRNO=$P(X,U,5)
.D WRT
.S APCLCTR=APCLCTR+1
.I $Y>(IOSL-5) D D HEADING
..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR
;
I '$D(DUOUT) W !!,"Total: ",APCLCTR
Q
;
RRDLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Railroad Retirement Part D"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNRRE(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(^AUPNRRE(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="D" Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg dates before begin 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 APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
..S APCLRRNO=$$GETRRE^AGUTL(APCLDFN) ;IHS/CMI/LAB - NMCI PATCH 21
..S APCLRRPR=""
..S X=$P(^AUPNRRE(APCLDFN,0),U,3)
..I X S APCLRRPR=$G(^AUTTRRP(X,0))
..I APCLOTH,APCLCTR=1 D STORE
..I APCLOTH=0 D STORE
;
S APCLCTR=0
S APCLSRT=""
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 APCLRRPR=$P(X,U,4)
.S APCLRRNO=$P(X,U,5)
.D WRT
.S APCLCTR=APCLCTR+1
.I $Y>(IOSL-5) D 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_APCLRRPR_U_APCLRRNO
Q
;
WRT ;
W $P(^DPT(APCLDFN,0),U)
W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
W ?41,APCLRRPR
W ?45,APCLRRNO
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(^AUPNRRE(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
.S APCLBEG=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
.I APCLACT=2,APCLBEG<APCLBDAT Q
.S APCLEND=$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
.I APCLTYP="RRA",$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="A" Q
.I APCLTYP="RRB",$P(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="B" Q
.I APCLTYP="RRD",$P(^AUPNRRE(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)
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 from "
.S X=X_$E(APCLBDAT,4,5)_"/"_$E(APCLBDAT,6,7)_"/"_$E(APCLBDAT,2,3)
.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",?40,"PRE",?47,"RR #",?59,"Begin",?69,"End"
W !
;
W "------------",?32,"------",?40,"---",?45,"---------",?57,"--------",?67,"--------"
W !
Q
APCLPYR5 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Railroad ;
+1 ;;2.0;IHS PCC SUITE;**21**;MAY 14, 2009;Build 34
+2 ;
+3 QUIT
+4 ;
RRALOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Railroad Retirement 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(^AUPNRRE(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 IF Y<1
QUIT
+28 SET APCLCTR=0
+29 SET APCLIEN=0
+30 SET APCLFLAG=0
+31 FOR
SET APCLIEN=$ORDER(^AUPNRRE(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+32 SET APCLCTR=APCLCTR+1
+33 IF $PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="A"
QUIT
+34 SET APCLFLAG=APCLIEN
+35 SET APCLBEG=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
+36 SET APCLEND=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
+37 ;--> There is no Beg Date
+38 IF APCLACT
IF APCLBEG=""
SET APCLFLAG=0
+39 ;--> User wants to restrict to beg dates before begin date
+40 IF APCLACT=2
IF APCLBEG<APCLBDAT
SET APCLFLAG=0
+41 ;--> Beg Date is earlier than selected end date
+42 IF APCLACT
IF APCLEDAT>0
IF APCLBEG>APCLEDAT
SET APCLFLAG=0
+43 ;--> End date is before selected begin date
+44 IF APCLACT
IF APCLEND>0
IF APCLEND<APCLBDAT
SET APCLFLAG=0
End DoDot:2
+45 IF APCLFLAG
Begin DoDot:2
+46 ;S APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
+47 ;IHS/CMI/LAB - PATCH 21 NMCI
SET APCLRRNO=$$GETRRE^AGUTL(APCLDFN)
+48 SET APCLRRPR=""
+49 SET X=$PIECE(^AUPNRRE(APCLDFN,0),U,3)
+50 IF X
SET APCLRRPR=$GET(^AUTTRRP(X,0))
+51 IF APCLOTH
IF APCLCTR=1
DO STORE
+52 IF APCLOTH=0
DO STORE
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+53 ;
+54 SET APCLCTR=0
+55 SET APCLSRT=""
+56 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+57 SET X=^TMP($JOB,"APCLPYR",APCLSRT)
+58 SET APCLDFN=$PIECE(X,U)
+59 SET APCLBEG=$PIECE(X,U,2)
+60 SET APCLEND=$PIECE(X,U,3)
+61 SET APCLRRPR=$PIECE(X,U,4)
+62 SET APCLRRNO=$PIECE(X,U,5)
+63 DO WRT
+64 SET APCLCTR=APCLCTR+1
+65 IF $Y>(IOSL-5)
Begin DoDot:2
+66 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
+67 ;
+68 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+69 QUIT
+70 ;
RRBLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Railroad Retirement 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(^AUPNRRE(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(^AUPNRRE(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="B"
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
+35 SET APCLEND=$PIECE(^AUPNRRE(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 dates before begin 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 APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
+46 ;IHS/CMI/LAB - NMCI PATCH 21
SET APCLRRNO=$$GETRRE^AGUTL(APCLDFN)
+47 SET APCLRRPR=""
+48 SET X=$PIECE(^AUPNRRE(APCLDFN,0),U,3)
+49 IF X
SET APCLRRPR=$GET(^AUTTRRP(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 APCLRRPR=$PIECE(X,U,4)
+61 SET APCLRRNO=$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
DO HEADING
End DoDot:1
IF $DATA(DUOUT)
QUIT
+66 ;
+67 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+68 QUIT
+69 ;
RRDLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Railroad Retirement 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(^AUPNRRE(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(^AUPNRRE(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="D"
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
+35 SET APCLEND=$PIECE(^AUPNRRE(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 dates before begin 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 APCLRRNO=$P(^AUPNRRE(APCLDFN,0),U,4)
+46 ;IHS/CMI/LAB - NMCI PATCH 21
SET APCLRRNO=$$GETRRE^AGUTL(APCLDFN)
+47 SET APCLRRPR=""
+48 SET X=$PIECE(^AUPNRRE(APCLDFN,0),U,3)
+49 IF X
SET APCLRRPR=$GET(^AUTTRRP(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 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 APCLRRPR=$PIECE(X,U,4)
+61 SET APCLRRNO=$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
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_APCLRRPR_U_APCLRRNO
+2 QUIT
+3 ;
WRT ;
+1 WRITE $PIECE(^DPT(APCLDFN,0),U)
+2 WRITE ?32,$JUSTIFY($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
+3 WRITE ?41,APCLRRPR
+4 WRITE ?45,APCLRRNO
+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(^AUPNRRE(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:1
+11 SET APCLBEG=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U)
+12 IF APCLACT=2
IF APCLBEG<APCLBDAT
QUIT
+13 SET APCLEND=$PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,2)
+14 IF APCLTYP="RRA"
IF $PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="A"
QUIT
+15 IF APCLTYP="RRB"
IF $PIECE(^AUPNRRE(APCLDFN,11,APCLIEN,0),U,3)'="B"
QUIT
+16 IF APCLTYP="RRD"
IF $PIECE(^AUPNRRE(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)
End DoDot:1
+19 QUIT
+20 ;
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 from "
+22 SET X=X_$EXTRACT(APCLBDAT,4,5)_"/"_$EXTRACT(APCLBDAT,6,7)_"/"_$EXTRACT(APCLBDAT,2,3)
+23 IF $GET(APCLEDAT)=""
QUIT
+24 SET X=X_" to "
+25 SET X=X_$EXTRACT(APCLEDAT,4,5)_"/"_$EXTRACT(APCLEDAT,6,7)_"/"_$EXTRACT(APCLEDAT,2,3)
End DoDot:1
+26 IF X]""
WRITE ?((IOM-$LENGTH(X))/2),X,!
+27 ;
+28 WRITE !
+29 ;
+30 WRITE "Patient Name",?33,"HRNO",?40,"PRE",?47,"RR #",?59,"Begin",?69,"End"
+31 WRITE !
+32 ;
+33 WRITE "------------",?32,"------",?40,"---",?45,"---------",?57,"--------",?67,"--------"
+34 WRITE !
+35 QUIT
