APCLPYR3 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Medicaid ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
Q
;
MCDLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM="Medicaid"
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
I $G(APCLMCST) S APCLINAM=$P(^DIC(5,APCLMCST,0),U)_" MEDICAID"
I $G(APCLPYR) S APCLINAM=APCLINAM_" for Plan "_$P(^AUTNINS(APCLPYR,0),U)
;
D HEADING
;
S APCLMIEN=0
F S APCLMIEN=$O(^AUPNMCD(APCLMIEN)) Q:'APCLMIEN D Q:$D(DUOUT)
.I $G(APCLMCST) Q:$P(^AUPNMCD(APCLMIEN,0),U,4)'=APCLMCST
.I $G(APCLPYR) Q:$P(^AUPNMCD(APCLMIEN,0),U,10)'=APCLPYR
.;Check if Patient is registered here
.S APCLDFN=$P(^AUPNMCD(APCLMIEN,0),U)
.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>0
..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
.S APCLRATE="",APCLPLAN=""
.F S APCLIEN=$O(^AUPNMCD(APCLMIEN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U)
..S APCLEND=$P(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U,2)
..S APCLRATE=$P(^AUPNMCD(APCLMIEN,0),U,11)
..S APCLMCNO=$P(^AUPNMCD(APCLMIEN,0),U,3)
..S X=$P(^AUPNMCD(APCLMIEN,0),U,10)
..I X S X=$G(^AUTNINS(X,0),U)
..S APCLPLAN=X
..;--> There is no Beg Date
..I APCLACT,APCLBEG="" S APCLFLAG=0
..;--> User wants to restrict to beg dates after 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
...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 APCLMIEN=0
.F S APCLMIEN=$O(^TMP($J,"APCLPYR",APCLSRT,APCLMIEN)) Q:'APCLMIEN D Q:$D(DUOUT)
..S X=^TMP($J,"APCLPYR",APCLSRT,APCLMIEN)
..S APCLDFN=$P(X,U)
..S APCLBEG=$P(X,U,2)
..S APCLEND=$P(X,U,3)
..S APCLMCNO=$P(X,U,4)
..S APCLRATE=$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,APCLMIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLMCNO_U_$G(APCLRATE)
Q
;
WRT ;
W $P(^DPT(APCLDFN,0),U)
W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
W ?41,APCLMCNO
W ?52,APCLRATE
I APCLALL=0 D Q
.W ?60,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
.I APCLEND W ?70,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
.W !
S APCLIEN=0
F S APCLIEN=$O(^AUPNMCD(APCLMIEN,11,APCLIEN)) Q:'APCLIEN D
.S APCLBEG=$P(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U)
.I APCLACT=2,APCLBEG<APCLBDAT Q
.S APCLEND=$P(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U,2)
.W ?60,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
.I APCLEND W ?70,$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
W !
;
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",?43,"MCD #",?53,"Rate",?62,"Begin",?72,"End"
W !
;
W "------------",?32,"------",?41,"---------",?52,"------",?60,"--------",?70,"--------"
W !
Q
APCLPYR3 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Medicaid ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 QUIT
+3 ;
MCDLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM="Medicaid"
+3 KILL ^TMP($JOB,"APCLPYR")
+4 SET APCLPAGE=0
+5 ;
+6 IF $GET(APCLMCST)
SET APCLINAM=$PIECE(^DIC(5,APCLMCST,0),U)_" MEDICAID"
+7 IF $GET(APCLPYR)
SET APCLINAM=APCLINAM_" for Plan "_$PIECE(^AUTNINS(APCLPYR,0),U)
+8 ;
+9 DO HEADING
+10 ;
+11 SET APCLMIEN=0
+12 FOR
SET APCLMIEN=$ORDER(^AUPNMCD(APCLMIEN))
IF 'APCLMIEN
QUIT
Begin DoDot:1
+13 IF $GET(APCLMCST)
IF $PIECE(^AUPNMCD(APCLMIEN,0),U,4)'=APCLMCST
QUIT
+14 IF $GET(APCLPYR)
IF $PIECE(^AUPNMCD(APCLMIEN,0),U,10)'=APCLPYR
QUIT
+15 ;Check if Patient is registered here
+16 SET APCLDFN=$PIECE(^AUPNMCD(APCLMIEN,0),U)
+17 SET Y=$$HRN^AUPNPAT(APCLDFN,APCLFAC)
+18 IF Y=""
QUIT
+19 IF Y<1
QUIT
+20 ;
+21 IF APCLSORT="NAME"
SET APCLSRT=$PIECE(^DPT(APCLDFN,0),U)_U_APCLDFN
+22 IF APCLSORT="HRNO"
SET APCLSRT=Y
+23 ;
+24 ;--> Check for Other Insurance if user picked this option
+25 IF APCLOTH=1
Begin DoDot:2
+26 SET APCLICTR=0
+27 IF +$ORDER(^AUPNMCR("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+28 ;I +$O(^AUPNMCD("B",APCLDFN,0)) S APCLICTR=APCLICTR+1
+29 IF +$ORDER(^AUPNRRE("B",APCLDFN,0))
SET APCLICTR=APCLICTR+1
+30 SET X=0
+31 FOR
SET X=$ORDER(^AUPNPRVT("B",APCLDFN,11,X))
IF 'X
QUIT
SET APCLICTR=APCLICTR+1
End DoDot:2
IF APCLICTR>0
QUIT
+32 ;
+33 SET APCLCTR=0
+34 SET APCLIEN=0
+35 SET APCLFLAG=0
+36 SET APCLRATE=""
SET APCLPLAN=""
+37 FOR
SET APCLIEN=$ORDER(^AUPNMCD(APCLMIEN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+38 SET APCLCTR=APCLCTR+1
+39 SET APCLFLAG=APCLIEN
+40 SET APCLBEG=$PIECE(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U)
+41 SET APCLEND=$PIECE(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U,2)
+42 SET APCLRATE=$PIECE(^AUPNMCD(APCLMIEN,0),U,11)
+43 SET APCLMCNO=$PIECE(^AUPNMCD(APCLMIEN,0),U,3)
+44 SET X=$PIECE(^AUPNMCD(APCLMIEN,0),U,10)
+45 IF X
SET X=$GET(^AUTNINS(X,0),U)
+46 SET APCLPLAN=X
+47 ;--> There is no Beg Date
+48 IF APCLACT
IF APCLBEG=""
SET APCLFLAG=0
+49 ;--> User wants to restrict to beg dates after begin date
+50 IF APCLACT=2
IF APCLBEG<APCLBDAT
SET APCLFLAG=0
+51 ;--> Beg Date is earlier than selected end date
+52 IF APCLACT
IF APCLEDAT>0
IF APCLBEG>APCLEDAT
SET APCLFLAG=0
+53 ;--> End date is before selected begin date
+54 IF APCLACT
IF APCLEND>0
IF APCLEND<APCLBDAT
SET APCLFLAG=0
+55 IF APCLFLAG
Begin DoDot:3
+56 IF APCLOTH
IF APCLCTR=1
DO STORE
+57 IF APCLOTH=0
DO STORE
End DoDot:3
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+58 ;
+59 SET APCLCTR=0
+60 SET APCLSRT=""
+61 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+62 SET APCLMIEN=0
+63 FOR
SET APCLMIEN=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT,APCLMIEN))
IF 'APCLMIEN
QUIT
Begin DoDot:2
+64 SET X=^TMP($JOB,"APCLPYR",APCLSRT,APCLMIEN)
+65 SET APCLDFN=$PIECE(X,U)
+66 SET APCLBEG=$PIECE(X,U,2)
+67 SET APCLEND=$PIECE(X,U,3)
+68 SET APCLMCNO=$PIECE(X,U,4)
+69 SET APCLRATE=$PIECE(X,U,5)
+70 DO WRT
+71 SET APCLCTR=APCLCTR+1
+72 IF $Y>(IOSL-5)
Begin DoDot:3
+73 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:3
IF '$DATA(DUOUT)
DO HEADING
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
+74 ;
+75 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+76 QUIT
+77 ;
STORE ;
+1 SET ^TMP($JOB,"APCLPYR",APCLSRT,APCLMIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLMCNO_U_$GET(APCLRATE)
+2 QUIT
+3 ;
WRT ;
+1 WRITE $PIECE(^DPT(APCLDFN,0),U)
+2 WRITE ?32,$JUSTIFY($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
+3 WRITE ?41,APCLMCNO
+4 WRITE ?52,APCLRATE
+5 IF APCLALL=0
Begin DoDot:1
+6 WRITE ?60,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+7 IF APCLEND
WRITE ?70,$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(^AUPNMCD(APCLMIEN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:1
+11 SET APCLBEG=$PIECE(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U)
+12 IF APCLACT=2
IF APCLBEG<APCLBDAT
QUIT
+13 SET APCLEND=$PIECE(^AUPNMCD(APCLMIEN,11,APCLIEN,0),U,2)
+14 WRITE ?60,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+15 IF APCLEND
WRITE ?70,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
+16 WRITE !
End DoDot:1
+17 QUIT
+18 ;
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 WRITE !
+14 ;
+15 SET X=""
+16 IF APCLOTH=1
SET X=X_"Having only this insurance"
+17 IF X]""
WRITE ?((IOM-$LENGTH(X))/2),X,!
+18 ;
+19 SET X=""
+20 IF APCLACT=0
SET X=X_"With any eligibility dates"
+21 IF APCLACT
Begin DoDot:1
+22 SET X=X_"With eligibility from "
+23 SET X=X_$EXTRACT(APCLBDAT,4,5)_"/"_$EXTRACT(APCLBDAT,6,7)_"/"_$EXTRACT(APCLBDAT,2,3)
+24 IF $GET(APCLEDAT)=""
QUIT
+25 SET X=X_" to "
+26 SET X=X_$EXTRACT(APCLEDAT,4,5)_"/"_$EXTRACT(APCLEDAT,6,7)_"/"_$EXTRACT(APCLEDAT,2,3)
End DoDot:1
+27 IF X]""
WRITE ?((IOM-$LENGTH(X))/2),X,!
+28 ;
+29 WRITE !
+30 ;
+31 WRITE "Patient Name",?33,"HRNO",?43,"MCD #",?53,"Rate",?62,"Begin",?72,"End"
+32 WRITE !
+33 ;
+34 WRITE "------------",?32,"------",?41,"---------",?52,"------",?60,"--------",?70,"--------"
+35 WRITE !
+36 QUIT
