FBAACIE ;AISC/GRR - COMPLETE PHARMACY INVOICE ;1/22/2015
;;3.5;FEE BASIS;**38,61,91,154,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
D DT^DICRW,HOME^%ZIS I '$D(^FBAA(162.1,"AC",2)) W !!,*7,"There are no Invoices Pending completion!",!! Q
D SITEP^FBAAUTL I FBPOP W !,*7,"Fee Site Parameters must be Initialized!" K FBPOP Q
S FBAAOUT=1,FBMDF=$P(FBSITE(0),"^",10),UL="",$P(UL,"=",79)="="
RINV W ! S FBINTOT=0,DIC="^FBAA(162.1,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,5)=2&($D(^(""RX"",""AC"",2)))" D ^DIC K DIC("S") G END:X="^"!(X=""),RINV:Y<0 S FBIN=+Y,FBINTOT=+$P(^(0),"^",7)
I '$D(^FBAA(162.1,FBIN,"RX","AC",2)) G RINV
S J=0 F S J=$O(^FBAA(162.1,FBIN,"RX","AC",2,J)) Q:'J I $D(^FBAA(162.1,FBIN,"RX",J,0)) S Y(0)=^(0) D GOT
I '$D(^FBAA(162.1,FBIN,"RX","AC",2)) K ^FBAA(162.1,"AC",2,FBIN) S ^FBAA(162.1,"AC",3,FBIN)="",$P(^FBAA(162.1,FBIN,0),"^",5)=3
I $D(^FBAA(162.1,"AC",3,FBIN)) W !!,"Invoice is Complete",?30,"Totals: $ "_$J(FBINTOT,1,2)
G RINV
END K FBAAOUT,FBIN,FBRX,FBSITE,FBDATEF,FBDRUG,FBPATN,FBPID,FBVNAME,FBVID,FBAC,FBAAPR,DA,X,Y,D0,D1,DI,DIC,DIE,DIRUT,DIV,DQ,DR,FBAP,FBGEN,FBGENSUB,FBINTOT,FBMDF,FBQTY,FBRBC,FBSTR,FBVEN,S,UL,ULL,POP,J,DFN,Z,ZZ,FBSW,FBPOP,FB1725
K FBADJ,FBFPPSC,FBFPPSL,FBRRMK,DTOUT,FBX,FTP
Q
GOT S FBDRUG=$P(Y(0),"^",2)
S FBGENSUB=$$GET1^DIQ(162.11,J_","_FBIN_",",8.5)
S FBGEN=$$GET1^DIQ(162.11,J_","_FBIN_",",9)
S FBRX=$P(Y(0),"^"),FBDATEF=$P(Y(0),"^",3),FBAC=$P(Y(0),"^",4),DFN=+$P(Y(0),"^",5),FBPATN=$$VET^FBUCUTL(DFN),FBPID=$$SSN^FBAAUTL(DFN)
S FBSTR=$P(Y(0),"^",12),FBQTY=$P(Y(0),"^",13),FBAAPR=$P(Y(0),"^",22)
S Y=$S($D(^FBAA(162.1,FBIN,0)):^(0),1:"")
S FBFPPSC=$P(Y,U,13)
S FBFPPSL=$P($G(^FBAA(162.1,FBIN,"RX",J,3)),U)
S FBVEN=+$P(Y,"^",4),FBVNAME=$$VEN^FBUCUTL(FBVEN),FBVID=$P($G(^FBAAV(FBVEN,0)),"^",2)
; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
S Y(2)=$G(^FBAA(162.1,FBIN,"RX",J,2))
S FB1725=$S($P(Y(2),U,6)["FB583":+$P($G(^FB583(+$P(Y(2),U,6),0)),U,28),1:0)
S FTP=$P(Y(2),U,7)
W @IOF,"Vendor: ",FBVNAME," Vendor ID: ",FBVID
W !!,"Patient: ",FBPATN," Patient ID: ",FBPID
W !,"FPPS Claim ID: ",$S(FBFPPSC="":"N/A",1:FBFPPSC)
W ?28,"FPPS Line Item: ",$S(FBFPPSL="":"N/A",1:FBFPPSL)
W !!,"Drug Name",?32," RX # "," Strength "," Qty"," Amt Claimed ",!,UL
W !,FBDRUG,?34,FBRX,?43,FBSTR,?54,FBQTY,?63,FBAC
I FBGENSUB]"" W !!,?4,"Generic Drug Issued: ",FBGENSUB,?30,"Generic Drug Name: ",$E(FBGEN,1,30)
W:FBAAPR]"" !!,?5,"Pharmacy Remarks: ",FBAAPR
I '$$UOKPAY^FBUTL9(DFN,FTP) D Q
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
. S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
FEE S DIR(0)="161.4,9",DIR("B")=FBMDF,DIR("?")="Hit Return to accept default dispensing fee or enter a dollar amount between .01 and 20" D ^DIR K DIR Q:$D(DIRUT)
W:FB1725 !?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
W !! S FBMDF=+Y K FBAP
S DA(1)=FBIN,DIE="^FBAA(162.1,"_FBIN_",""RX"",",DA=J,DIC=DIE,DR="5;S FBRBC=X;6.5//^S X=$S(FBRBC+FBMDF>FBAC:FBAC,1:FBRBC+FBMDF);S FBAP=X"
S DR(1,162.11,1)="I FBAP>FBAC S $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16)="""" W !,*7,""Amount Paid cannot be greater than the Amount Claimed"" S Y=6.5"
;FB*3.5*158
K FBRRMK S DR(1,162.11,2)="S FBX=$$ADJ^FBUTL2(FBAC-FBAP,.FBADJ,5,,,1,.FBRRMK,1)"
S DR(1,162.11,3)="8////^S X=3"
D ^DIE K DIE Q:$D(Y)'=0
S:$D(FBAP) FBINTOT=FBINTOT+FBAP
S $P(^FBAA(162.1,FBIN,0),"^",7)=FBINTOT
G:$D(DTOUT) H^XUS
; file adjustments
D FILEADJ^FBRXFA(DA_","_FBIN_",",.FBADJ)
; file remittance remarks
D FILERR^FBRXFR(DA_","_FBIN_",",.FBRRMK)
Q
;
BLDRR(FBA1,FBA2) ; build array FILERR^FBRXFR understands
;
N I1,I2,CNTR K FBA2
S I1=0,CNTR=0
F S I1=$O(FBA1(I1)) Q:'I1 D
. S I2=0
. F S I2=$O(FBA1(I1,I2)) Q:'I2 D
. . S CNTR=CNTR+1
. . S FBA2(CNTR)=FBA1(I1,I2)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACIE 3937 printed Nov 22, 2024@17:05:16 Page 2
FBAACIE ;AISC/GRR - COMPLETE PHARMACY INVOICE ;1/22/2015
+1 ;;3.5;FEE BASIS;**38,61,91,154,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 DO DT^DICRW
DO HOME^%ZIS
IF '$DATA(^FBAA(162.1,"AC",2))
WRITE !!,*7,"There are no Invoices Pending completion!",!!
QUIT
+4 DO SITEP^FBAAUTL
IF FBPOP
WRITE !,*7,"Fee Site Parameters must be Initialized!"
KILL FBPOP
QUIT
+5 SET FBAAOUT=1
SET FBMDF=$PIECE(FBSITE(0),"^",10)
SET UL=""
SET $PIECE(UL,"=",79)="="
RINV WRITE !
SET FBINTOT=0
SET DIC="^FBAA(162.1,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,5)=2&($D(^(""RX"",""AC"",2)))"
DO ^DIC
KILL DIC("S")
if X="^"!(X="")
GOTO END
if Y<0
GOTO RINV
SET FBIN=+Y
SET FBINTOT=+$PIECE(^(0),"^",7)
+1 IF '$DATA(^FBAA(162.1,FBIN,"RX","AC",2))
GOTO RINV
+2 SET J=0
FOR
SET J=$ORDER(^FBAA(162.1,FBIN,"RX","AC",2,J))
if 'J
QUIT
IF $DATA(^FBAA(162.1,FBIN,"RX",J,0))
SET Y(0)=^(0)
DO GOT
+3 IF '$DATA(^FBAA(162.1,FBIN,"RX","AC",2))
KILL ^FBAA(162.1,"AC",2,FBIN)
SET ^FBAA(162.1,"AC",3,FBIN)=""
SET $PIECE(^FBAA(162.1,FBIN,0),"^",5)=3
+4 IF $DATA(^FBAA(162.1,"AC",3,FBIN))
WRITE !!,"Invoice is Complete",?30,"Totals: $ "_$JUSTIFY(FBINTOT,1,2)
+5 GOTO RINV
END KILL FBAAOUT,FBIN,FBRX,FBSITE,FBDATEF,FBDRUG,FBPATN,FBPID,FBVNAME,FBVID,FBAC,FBAAPR,DA,X,Y,D0,D1,DI,DIC,DIE,DIRUT,DIV,DQ,DR,FBAP,FBGEN,FBGENSUB,FBINTOT,FBMDF,FBQTY,FBRBC,FBSTR,FBVEN,S,UL,ULL,POP,J,DFN,Z,ZZ,FBSW,FBPOP,FB1725
+1 KILL FBADJ,FBFPPSC,FBFPPSL,FBRRMK,DTOUT,FBX,FTP
+2 QUIT
GOT SET FBDRUG=$PIECE(Y(0),"^",2)
+1 SET FBGENSUB=$$GET1^DIQ(162.11,J_","_FBIN_",",8.5)
+2 SET FBGEN=$$GET1^DIQ(162.11,J_","_FBIN_",",9)
+3 SET FBRX=$PIECE(Y(0),"^")
SET FBDATEF=$PIECE(Y(0),"^",3)
SET FBAC=$PIECE(Y(0),"^",4)
SET DFN=+$PIECE(Y(0),"^",5)
SET FBPATN=$$VET^FBUCUTL(DFN)
SET FBPID=$$SSN^FBAAUTL(DFN)
+4 SET FBSTR=$PIECE(Y(0),"^",12)
SET FBQTY=$PIECE(Y(0),"^",13)
SET FBAAPR=$PIECE(Y(0),"^",22)
+5 SET Y=$SELECT($DATA(^FBAA(162.1,FBIN,0)):^(0),1:"")
+6 SET FBFPPSC=$PIECE(Y,U,13)
+7 SET FBFPPSL=$PIECE($GET(^FBAA(162.1,FBIN,"RX",J,3)),U)
+8 SET FBVEN=+$PIECE(Y,"^",4)
SET FBVNAME=$$VEN^FBUCUTL(FBVEN)
SET FBVID=$PIECE($GET(^FBAAV(FBVEN,0)),"^",2)
+9 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
+10 SET Y(2)=$GET(^FBAA(162.1,FBIN,"RX",J,2))
+11 SET FB1725=$SELECT($PIECE(Y(2),U,6)["FB583":+$PIECE($GET(^FB583(+$PIECE(Y(2),U,6),0)),U,28),1:0)
+12 SET FTP=$PIECE(Y(2),U,7)
+13 WRITE @IOF,"Vendor: ",FBVNAME," Vendor ID: ",FBVID
+14 WRITE !!,"Patient: ",FBPATN," Patient ID: ",FBPID
+15 WRITE !,"FPPS Claim ID: ",$SELECT(FBFPPSC="":"N/A",1:FBFPPSC)
+16 WRITE ?28,"FPPS Line Item: ",$SELECT(FBFPPSL="":"N/A",1:FBFPPSL)
+17 WRITE !!,"Drug Name",?32," RX # "," Strength "," Qty"," Amt Claimed ",!,UL
+18 WRITE !,FBDRUG,?34,FBRX,?43,FBSTR,?54,FBQTY,?63,FBAC
+19 IF FBGENSUB]""
WRITE !!,?4,"Generic Drug Issued: ",FBGENSUB,?30,"Generic Drug Name: ",$EXTRACT(FBGEN,1,30)
+20 if FBAAPR]""
WRITE !!,?5,"Pharmacy Remarks: ",FBAAPR
+21 IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+22 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+23 WRITE !,"due to separation of duties."
+24 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
FEE SET DIR(0)="161.4,9"
SET DIR("B")=FBMDF
SET DIR("?")="Hit Return to accept default dispensing fee or enter a dollar amount between .01 and 20"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+1 if FB1725
WRITE !?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
+2 WRITE !!
SET FBMDF=+Y
KILL FBAP
+3 SET DA(1)=FBIN
SET DIE="^FBAA(162.1,"_FBIN_",""RX"","
SET DA=J
SET DIC=DIE
SET DR="5;S FBRBC=X;6.5//^S X=$S(FBRBC+FBMDF>FBAC:FBAC,1:FBRBC+FBMDF);S FBAP=X"
+4 SET DR(1,162.11,1)="I FBAP>FBAC S $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16)="""" W !,*7,""Amount Paid cannot be greater than the Amount Claimed"" S Y=6.5"
+5 ;FB*3.5*158
+6 KILL FBRRMK
SET DR(1,162.11,2)="S FBX=$$ADJ^FBUTL2(FBAC-FBAP,.FBADJ,5,,,1,.FBRRMK,1)"
+7 SET DR(1,162.11,3)="8////^S X=3"
+8 DO ^DIE
KILL DIE
if $DATA(Y)'=0
QUIT
+9 if $DATA(FBAP)
SET FBINTOT=FBINTOT+FBAP
+10 SET $PIECE(^FBAA(162.1,FBIN,0),"^",7)=FBINTOT
+11 if $DATA(DTOUT)
GOTO H^XUS
+12 ; file adjustments
+13 DO FILEADJ^FBRXFA(DA_","_FBIN_",",.FBADJ)
+14 ; file remittance remarks
+15 DO FILERR^FBRXFR(DA_","_FBIN_",",.FBRRMK)
+16 QUIT
+17 ;
BLDRR(FBA1,FBA2) ; build array FILERR^FBRXFR understands
+1 ;
+2 NEW I1,I2,CNTR
KILL FBA2
+3 SET I1=0
SET CNTR=0
+4 FOR
SET I1=$ORDER(FBA1(I1))
if 'I1
QUIT
Begin DoDot:1
+5 SET I2=0
+6 FOR
SET I2=$ORDER(FBA1(I1,I2))
if 'I2
QUIT
Begin DoDot:2
+7 SET CNTR=CNTR+1
+8 SET FBA2(CNTR)=FBA1(I1,I2)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
