APCLPYR4 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Pvt Insurance ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
Q
;
PVTLOOP ;EP
I $E(IOST)="C" W !!,"Please be patient. This may take a few minutes.",!! H 6
S APCLINAM=$P(^AUTNINS(APCLPYR,0),U)
K ^TMP($J,"APCLPYR")
S APCLPAGE=0
;
D HEADING
;
S APCLDFN=0
F S APCLDFN=$O(^AUPNPRVT(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(^AUPNPRVT(APCLDFN,11,APCLIEN)) Q:'APCLIEN D
..S APCLCTR=APCLCTR+1
..I $P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U)'=APCLPYR Q
..S APCLFLAG=APCLIEN
..S APCLBEG=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
..S APCLEND=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
..S APCLPVNO=$S($P($G(^AUPNPRVT(APCLDFN,11,APCLIEN,2)),U)]"":$P(^AUPNPRVT(APCLDFN,11,APCLIEN,2),U),$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8):$P(^AUPN3PPH($P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8),0),U,4),1:$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,2))
..;--> 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 APCLIEN=0
.F S APCLIEN=$O(^TMP($J,"APCLPYR",APCLSRT,APCLIEN)) Q:'APCLIEN D Q:$D(DUOUT)
..S X=^TMP($J,"APCLPYR",APCLSRT,APCLIEN)
..S APCLDFN=$P(X,U)
..S APCLBEG=$P(X,U,2)
..S APCLEND=$P(X,U,3)
..S APCLPVNO=$P(X,U,4)
..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,APCLIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLPVNO
Q
;
WRT ;
W $P(^DPT(APCLDFN,0),U)
W ?32,$J($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
W ?40,APCLPVNO
I APCLALL=0 D Q
.W ?58,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
.I APCLEND W ?68,$E(APCLEND,4,5),"/",$E(APCLEND,6,7),"/",$E(APCLEND,2,3)
.W !
S APCLBEG=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
S APCLEND=$P(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
W ?58,$E(APCLBEG,4,5),"/",$E(APCLBEG,6,7),"/",$E(APCLBEG,2,3)
I APCLEND W ?68,$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 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",?42,"Policy #",?60,"Begin",?70,"End"
W !
;
W "------------",?32,"------",?40,"----------------",?58,"--------",?68,"--------"
W !
Q
APCLPYR4 ; IHS/CMI/LAB - Patients by Payer (Insurer) - Pvt Insurance ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 QUIT
+3 ;
PVTLOOP ;EP
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Please be patient. This may take a few minutes.",!!
HANG 6
+2 SET APCLINAM=$PIECE(^AUTNINS(APCLPYR,0),U)
+3 KILL ^TMP($JOB,"APCLPYR")
+4 SET APCLPAGE=0
+5 ;
+6 DO HEADING
+7 ;
+8 SET APCLDFN=0
+9 FOR
SET APCLDFN=$ORDER(^AUPNPRVT(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(^AUPNPRVT(APCLDFN,11,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+31 SET APCLCTR=APCLCTR+1
+32 IF $PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U)'=APCLPYR
QUIT
+33 SET APCLFLAG=APCLIEN
+34 SET APCLBEG=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
+35 SET APCLEND=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
+36 SET APCLPVNO=$SELECT($PIECE(...
... $GET(^AUPNPRVT(APCLDFN,11,APCLIEN,2)),U)]"":$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,2),U),$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8):$PIECE(^AUPN3PPH($PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,8),0),U,4),1:$PIECE(^AUPNPRVT(APCLDF
N,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 after 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
+45 IF APCLFLAG
Begin DoDot:3
+46 IF APCLOTH
IF APCLCTR=1
DO STORE
+47 IF APCLOTH=0
DO STORE
End DoDot:3
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+48 ;
+49 SET APCLCTR=0
+50 SET APCLSRT=""
+51 FOR
SET APCLSRT=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT))
IF APCLSRT=""
QUIT
Begin DoDot:1
+52 SET APCLIEN=0
+53 FOR
SET APCLIEN=$ORDER(^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN))
IF 'APCLIEN
QUIT
Begin DoDot:2
+54 SET X=^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN)
+55 SET APCLDFN=$PIECE(X,U)
+56 SET APCLBEG=$PIECE(X,U,2)
+57 SET APCLEND=$PIECE(X,U,3)
+58 SET APCLPVNO=$PIECE(X,U,4)
+59 DO WRT
+60 SET APCLCTR=APCLCTR+1
+61 IF $Y>(IOSL-5)
Begin DoDot:3
+62 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
+63 ;
+64 IF '$DATA(DUOUT)
WRITE !!,"Total: ",APCLCTR
+65 QUIT
+66 ;
STORE ;
+1 SET ^TMP($JOB,"APCLPYR",APCLSRT,APCLIEN)=APCLDFN_U_APCLBEG_U_APCLEND_U_APCLPVNO
+2 QUIT
+3 ;
WRT ;
+1 WRITE $PIECE(^DPT(APCLDFN,0),U)
+2 WRITE ?32,$JUSTIFY($$HRN^AUPNPAT(APCLDFN,APCLFAC),6)
+3 WRITE ?40,APCLPVNO
+4 IF APCLALL=0
Begin DoDot:1
+5 WRITE ?58,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+6 IF APCLEND
WRITE ?68,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
+7 WRITE !
End DoDot:1
QUIT
+8 SET APCLBEG=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,6)
+9 SET APCLEND=$PIECE(^AUPNPRVT(APCLDFN,11,APCLIEN,0),U,7)
+10 WRITE ?58,$EXTRACT(APCLBEG,4,5),"/",$EXTRACT(APCLBEG,6,7),"/",$EXTRACT(APCLBEG,2,3)
+11 IF APCLEND
WRITE ?68,$EXTRACT(APCLEND,4,5),"/",$EXTRACT(APCLEND,6,7),"/",$EXTRACT(APCLEND,2,3)
+12 WRITE !
+13 QUIT
+14 ;
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",?42,"Policy #",?60,"Begin",?70,"End"
+31 WRITE !
+32 ;
+33 WRITE "------------",?32,"------",?40,"----------------",?58,"--------",?68,"--------"
+34 WRITE !
+35 QUIT
