- 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 Feb 18, 2025@23:22:41 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