FBAAPPH ;AISC/GRR-PHARMACY HISTORY LIST FOR PATIENT ;7/17/2003
;;3.5;FEE BASIS;**12,61**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D DT^DICRW S FBAAOUT=0
RD K FBAANQ W !! S FBAAOUT=0,DIC="^FBAAA(",DIC(0)="AEQM" D ^DIC G Q:X=""!(X="^"),RD:Y<0 S DFN=+Y
I '$D(^FBAA(162.1,"AD",DFN)) W !!,*7,"No payments for this patient!" G RD
S VAR="DFN",VAL=DFN,PGM="LIST^FBAAPPH" D ZIS^FBAAUTL G:FBPOP Q S:IO=IO(0) FBAANQ=1
LIST ; list prescriptions for patient (DFN)
N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBRRMKL,FBSUSPA,FBX
S Q="" S $P(Q,"=",80)="="
S FSW=1 U IO I $E(IOST,1,2)="C-" W @IOF
S (FBAAOUT,J,K,L)=0
I '$O(^FBAA(162.1,"AD",DFN,0)) W !,"Patient has no Pharmacy payment history.",! Q
F S J=$O(^FBAA(162.1,"AD",DFN,J)) Q:J'>0!(FBAAOUT) F S K=$O(^FBAA(162.1,"AD",DFN,J,K)) Q:K'>0!(FBAAOUT) F S L=$O(^FBAA(162.1,"AD",DFN,J,K,L)) Q:L'>0!(FBAAOUT) D GOT Q:FBAAOUT
I FBAAOUT,$E(IOST,1,2)="C-" W @IOF
G:$D(FBAANQ) RD
Q K DIC,DOB,J,K,L,DFN,FBAANQ,FBRX,FBFD,FBAC,FBAP,A1,A2,FBPV,FBSUSP,FBSTR,FBQTY,FBAAOUT,FSW,FID,CHN,FBBATCH,FBDRUG,FBINVN,FBPD,FBREIM,N,NAME,Q,FBSSN,VAL,VAR,VID,PGM,VNAM,X,Y,I,FBSAR,FBI
W:$E(IOST,1,2)'="C-" @IOF D CLOSE^FBAAUTL Q
;
GOT S FBSSN=$$SSN^FBAAUTL(DFN),N=$G(^DPT(+DFN,0)),NAME=$P(N,"^"),DOB=$P(N,"^",3),DOB=$S(DOB]"":$$FMTE^XLFDT(DOB),1:"")
Q:'$D(^FBAA(162.1,K,0))&('$D(^FBAA(162.1,K,"RX",L,0)))
S Y(0)=$G(^FBAA(162.1,K,"RX",L,0))
S Y(2)=$G(^FBAA(162.1,+K,0))
I $D(^FBAA(162.1,K,"RX",L,2)) S Y(1)=^(2)
S FBFPPSL=$P($G(^FBAA(162.1,K,"RX",L,3)),U)
S FBX=$$ADJLRA^FBRXFA(L_","_K_",")
S FBADJLR=$P(FBX,U)
S FBADJLA=$P(FBX,U,2)
S FBRRMKL=$$RRL^FBRXFR(L_","_K_",")
S FBINVN=$P(Y(2),"^"),VID=$P(Y(2),"^",4),CHN=$G(^FBAAV(+VID,0)),VNAM=$P(CHN,"^"),FID=$P(CHN,"^",2),CHN=$P(CHN,"^",10)
S FBFPPSC=$P(Y(2),U,13)
S FBRX=$P(Y(0),"^",1),FBDRUG=$P(Y(0),"^",2),FBFD=$P(Y(0),"^",3),FBAC=$P(Y(0),"^",4),FBAP=$P(Y(0),"^",16),FBSUSP=$P(Y(0),"^",8),FBPD=$P(Y(0),"^",19),FBBATCH=$P(Y(0),"^",17),FBBATCH=$P($G(^FBAA(161.7,+FBBATCH,0)),"^")
S FBSUSPA=$FN($P(Y(0),U,7),"",2)
I FBSUSP=4,FBADJLR="" S FBI=0 F S FBI=$O(^FBAA(162.1,K,"RX",L,1,FBI)) Q:'FBI S FBSAR(FBI)=^(FBI,0)
I FBSUSP]"" S FBSUSP=$P($G(^FBAA(161.27,+FBSUSP,0)),"^")
S FBREIM=$S($P(Y(0),"^",20)="R":"*",1:""),FBSTR=$P(Y(0),"^",12),FBQTY=$P(Y(0),"^",13),A1=FBAC+.00001,A2=FBAP+.00001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBPV=""
I $D(Y(1)) S FBPV=$S($P(Y(1),"^",3)="V":"#",1:"")
D FBCKP^FBAACCB1(K,L)
WRT I FSW S FSW=0 D HED
I $E(IOST,1,2)="C-",$Y+7>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT W @IOF D HED
I $Y+6>IOSL W @IOF D HED
W !!,VNAM,?48,FID,?60,CHN
W !,FBREIM,FBPV,?3,$E(FBFD,4,5),"/",$E(FBFD,6,7),"/",$E(FBFD,2,3),?64,$S(FBPD="":"",1:$E(FBPD,4,5)_"/"_$E(FBPD,6,7)_"/"_$E(FBPD,2,3))
W !," Rx: "_FBRX,?15,FBDRUG,?45,FBSTR,?63,FBQTY
W !,?4,$J(A1,6),?13,$J(A2,6)
; write adjustment reasons, if null then write suspend code
W ?22,$S(FBADJLR]"":FBADJLR,1:FBSUSP)
; write adjustment amounts, if null then write amount suspended
W ?32,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)
W ?47,FBINVN,?58,FBBATCH,?67,FBRRMKL
I FBFPPSC]"" W !,?5,"FPPS Claim ID: ",FBFPPSC," FPPS Line Item: ",FBFPPSL
I $D(FBSAR) W !?5,"Suspension Description: " S FBI=0 F S FBI=$O(FBSAR(FBI)) Q:'FBI W " ",FBSAR(FBI)
D PMNT^FBAACCB2
K FBSAR Q
HED W:$E(IOST,1,2)'="C-" !?25,"PHARMACY PAYMENT HISTORY",!?24,$E(Q,1,26)
W !,"Patient: ",NAME,?41,"Pt ID: ",FBSSN,?60,"DOB: ",DOB
W !,"('*' Reimbursement to Patient '+' Cancellation Activity) '#' Voided Payment)"
W !,"Vendor Name",?48,"ID #",?60,"Chain #"
W !,?3,"Fill Date",?64,"Date Certified"
W !,?15,"Drug Name",?43,"Strength",?61,"Quantity"
W !,?3,"Claimed",?15,"Paid",?22,"Adj Code",?32,"Adj Amount",?47,"Invoice #",?58,"Batch #",?67,"Remit Remark"
W !,Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPPH 3849 printed Nov 22, 2024@17:06:26 Page 2
FBAAPPH ;AISC/GRR-PHARMACY HISTORY LIST FOR PATIENT ;7/17/2003
+1 ;;3.5;FEE BASIS;**12,61**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DT^DICRW
SET FBAAOUT=0
RD KILL FBAANQ
WRITE !!
SET FBAAOUT=0
SET DIC="^FBAAA("
SET DIC(0)="AEQM"
DO ^DIC
if X=""!(X="^")
GOTO Q
if Y<0
GOTO RD
SET DFN=+Y
+1 IF '$DATA(^FBAA(162.1,"AD",DFN))
WRITE !!,*7,"No payments for this patient!"
GOTO RD
+2 SET VAR="DFN"
SET VAL=DFN
SET PGM="LIST^FBAAPPH"
DO ZIS^FBAAUTL
if FBPOP
GOTO Q
if IO=IO(0)
SET FBAANQ=1
LIST ; list prescriptions for patient (DFN)
+1 NEW FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBRRMKL,FBSUSPA,FBX
+2 SET Q=""
SET $PIECE(Q,"=",80)="="
+3 SET FSW=1
USE IO
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+4 SET (FBAAOUT,J,K,L)=0
+5 IF '$ORDER(^FBAA(162.1,"AD",DFN,0))
WRITE !,"Patient has no Pharmacy payment history.",!
QUIT
+6 FOR
SET J=$ORDER(^FBAA(162.1,"AD",DFN,J))
if J'>0!(FBAAOUT)
QUIT
FOR
SET K=$ORDER(^FBAA(162.1,"AD",DFN,J,K))
if K'>0!(FBAAOUT)
QUIT
FOR
SET L=$ORDER(^FBAA(162.1,"AD",DFN,J,K,L))
if L'>0!(FBAAOUT)
QUIT
DO GOT
if FBAAOUT
QUIT
+7 IF FBAAOUT
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+8 if $DATA(FBAANQ)
GOTO RD
Q KILL DIC,DOB,J,K,L,DFN,FBAANQ,FBRX,FBFD,FBAC,FBAP,A1,A2,FBPV,FBSUSP,FBSTR,FBQTY,FBAAOUT,FSW,FID,CHN,FBBATCH,FBDRUG,FBINVN,FBPD,FBREIM,N,NAME,Q,FBSSN,VAL,VAR,VID,PGM,VNAM,X,Y,I,FBSAR,FBI
+1 if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
DO CLOSE^FBAAUTL
QUIT
+2 ;
GOT SET FBSSN=$$SSN^FBAAUTL(DFN)
SET N=$GET(^DPT(+DFN,0))
SET NAME=$PIECE(N,"^")
SET DOB=$PIECE(N,"^",3)
SET DOB=$SELECT(DOB]"":$$FMTE^XLFDT(DOB),1:"")
+1 if '$DATA(^FBAA(162.1,K,0))&('$DATA(^FBAA(162.1,K,"RX",L,0)))
QUIT
+2 SET Y(0)=$GET(^FBAA(162.1,K,"RX",L,0))
+3 SET Y(2)=$GET(^FBAA(162.1,+K,0))
+4 IF $DATA(^FBAA(162.1,K,"RX",L,2))
SET Y(1)=^(2)
+5 SET FBFPPSL=$PIECE($GET(^FBAA(162.1,K,"RX",L,3)),U)
+6 SET FBX=$$ADJLRA^FBRXFA(L_","_K_",")
+7 SET FBADJLR=$PIECE(FBX,U)
+8 SET FBADJLA=$PIECE(FBX,U,2)
+9 SET FBRRMKL=$$RRL^FBRXFR(L_","_K_",")
+10 SET FBINVN=$PIECE(Y(2),"^")
SET VID=$PIECE(Y(2),"^",4)
SET CHN=$GET(^FBAAV(+VID,0))
SET VNAM=$PIECE(CHN,"^")
SET FID=$PIECE(CHN,"^",2)
SET CHN=$PIECE(CHN,"^",10)
+11 SET FBFPPSC=$PIECE(Y(2),U,13)
+12 SET FBRX=$PIECE(Y(0),"^",1)
SET FBDRUG=$PIECE(Y(0),"^",2)
SET FBFD=$PIECE(Y(0),"^",3)
SET FBAC=$PIECE(Y(0),"^",4)
SET FBAP=$PIECE(Y(0),"^",16)
SET FBSUSP=$PIECE(Y(0),"^",8)
SET FBPD=$PIECE(Y(0),"^",19)
SET FBBATCH=$PIECE(Y(0),"^",17)
SET FBBATCH=$PIECE($GET(^FBAA(161.7,+FBBATCH,0)),"^")
+13 SET FBSUSPA=$FNUMBER($PIECE(Y(0),U,7),"",2)
+14 IF FBSUSP=4
IF FBADJLR=""
SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(162.1,K,"RX",L,1,FBI))
if 'FBI
QUIT
SET FBSAR(FBI)=^(FBI,0)
+15 IF FBSUSP]""
SET FBSUSP=$PIECE($GET(^FBAA(161.27,+FBSUSP,0)),"^")
+16 SET FBREIM=$SELECT($PIECE(Y(0),"^",20)="R":"*",1:"")
SET FBSTR=$PIECE(Y(0),"^",12)
SET FBQTY=$PIECE(Y(0),"^",13)
SET A1=FBAC+.00001
SET A2=FBAP+.00001
SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
SET FBPV=""
+17 IF $DATA(Y(1))
SET FBPV=$SELECT($PIECE(Y(1),"^",3)="V":"#",1:"")
+18 DO FBCKP^FBAACCB1(K,L)
WRT IF FSW
SET FSW=0
DO HED
+1 IF $EXTRACT(IOST,1,2)="C-"
IF $Y+7>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET FBAAOUT=1
if FBAAOUT
QUIT
WRITE @IOF
DO HED
+2 IF $Y+6>IOSL
WRITE @IOF
DO HED
+3 WRITE !!,VNAM,?48,FID,?60,CHN
+4 WRITE !,FBREIM,FBPV,?3,$EXTRACT(FBFD,4,5),"/",$EXTRACT(FBFD,6,7),"/",$EXTRACT(FBFD,2,3),?64,$SELECT(FBPD="":"",1:$EXTRACT(FBPD,4,5)_"/"_$EXTRACT(FBPD,6,7)_"/"_$EXTRACT(FBPD,2,3))
+5 WRITE !," Rx: "_FBRX,?15,FBDRUG,?45,FBSTR,?63,FBQTY
+6 WRITE !,?4,$JUSTIFY(A1,6),?13,$JUSTIFY(A2,6)
+7 ; write adjustment reasons, if null then write suspend code
+8 WRITE ?22,$SELECT(FBADJLR]"":FBADJLR,1:FBSUSP)
+9 ; write adjustment amounts, if null then write amount suspended
+10 WRITE ?32,$SELECT(FBADJLA]"":FBADJLA,1:FBSUSPA)
+11 WRITE ?47,FBINVN,?58,FBBATCH,?67,FBRRMKL
+12 IF FBFPPSC]""
WRITE !,?5,"FPPS Claim ID: ",FBFPPSC," FPPS Line Item: ",FBFPPSL
+13 IF $DATA(FBSAR)
WRITE !?5,"Suspension Description: "
SET FBI=0
FOR
SET FBI=$ORDER(FBSAR(FBI))
if 'FBI
QUIT
WRITE " ",FBSAR(FBI)
+14 DO PMNT^FBAACCB2
+15 KILL FBSAR
QUIT
HED if $EXTRACT(IOST,1,2)'="C-"
WRITE !?25,"PHARMACY PAYMENT HISTORY",!?24,$EXTRACT(Q,1,26)
+1 WRITE !,"Patient: ",NAME,?41,"Pt ID: ",FBSSN,?60,"DOB: ",DOB
+2 WRITE !,"('*' Reimbursement to Patient '+' Cancellation Activity) '#' Voided Payment)"
+3 WRITE !,"Vendor Name",?48,"ID #",?60,"Chain #"
+4 WRITE !,?3,"Fill Date",?64,"Date Certified"
+5 WRITE !,?15,"Drug Name",?43,"Strength",?61,"Quantity"
+6 WRITE !,?3,"Claimed",?15,"Paid",?22,"Adj Code",?32,"Adj Amount",?47,"Invoice #",?58,"Batch #",?67,"Remit Remark"
+7 WRITE !,Q
+8 QUIT
