FBAAPIE ;AISC/GRR - ENTER FEE PHARMACY INVOICE ;9/25/2014
;;3.5;FEE BASIS;**61,124,123,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
D SITEP^FBAAUTL W:FBPOP !!,*7,"Fee site parameters must be initialized!!" Q:FBPOP S FBMDF=$P(FBSITE(0),"^",10),FBAAPTC=$S($D(FBAAPTC):FBAAPTC,1:"V")
N FBIA,FBDODINV
RD1 W ! S DIR("A")="Are you sure you want to enter a new invoice",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G Q^FBAAPIE1:$D(DIRUT),RDM^FBAAPIE1:'Y
ENTER S (LCNT,TAC,FBINTOT)=0,STAT(0)="",FBAAOUT=1 K FBTOUT
D GETNXI^FBAAUTL S X=FBAAIN
S DLAYGO=162.1,DIC="^FBAA(162.1,",DIC(0)="LQ" D ^DIC K DLAYGO G:Y<0 PROB^FBAAPIE1 W !!,"Invoice # assigned is: ",X S IN=X,DA(1)=IN
RDV I '$D(FB583) W !! S DLAYGO=161.2,(DIE,DIC)="^FBAAV(",DIC(0)="AEQLM" D ^DIC K DLAYGO G CHK:Y<0 S DA=+Y D NEW^FBAAVD:$P(Y,"^",3)=1
I $D(FB583) S DA=FBVEN
I $D(^FBAAV(DA,0)),$P($G(^("ADEL")),"^")="Y" W !!,"Vendor is flagged for Austin deletion!" G RDV:'$D(FB583),Q^FBAAPIE1
D EN1^FBAAVD:$P(FBSITE(0),"^",12)="Y" S VIN=DA
RDV1 I $D(^XUSEC("FBAA ESTABLISH VENDOR",DUZ)) W ! S DIR("A")="Want to edit Vendor data",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G CHK:$D(DIRUT) D:Y EDITV^FBAAVD S VIN=DA
S FBAR(DA)="" D ^FBAACO4
;
; FB*3.5*123 - check for IPAC agreement for Federal Vendor
S FBIA=$$IPAC^FBAAMP($G(VIN)) I FBIA=-1 G CHK
;
W !! S %DT="AEQXP",%DT(0)=-DT,%DT("A")="Date Correct Invoice Received: " D ^%DT K %DT(0),%DT("A") G CHK:Y<0 S INVDATE=Y
W !! S %DT="AEQXP",%DT(0)=-INVDATE,%DT("A")="Vendor Invoice Date: " D ^%DT K %DT(0),%DT("A") G CHK:Y<0 S FBVINVDT=Y
; if U/C then get FPPS Claim ID else ask user
I $D(FB583) S FBFPPSC=$P($G(^FB583(FB583,5)),U) W !,"FPPS CLAIM ID: ",$S(FBFPPSC="":"N/A",1:FBFPPSC)
E S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 K FBFPPSC G CHK
S (DIE,DIC)="^FBAA(162.1,",DA=IN
S DR="1////^S X=INVDATE;1.5////^S X=DT;2////^S X=DUZ;3////^S X=VIN;5////^S X=1;12////^S X=FBVINVDT;13///^S X=FBFPPSC"
I $G(FBIA) S DR=DR_";14////^S X=FBIA" ; FB*3.5*123 file IPAC agreement ptr if it exists
D ^DIE
I '$D(^FBAA(162.1,IN,"RX",0)) S ^FBAA(162.1,IN,"RX",0)="^162.11A^^"
RDP S FBPHARM=1 W:FBINTOT>0 !,?15,"Pharmacy Invoice #: "_IN_" Totals: $ "_$J(FBINTOT,1,2)
; if EDI then ask FPPS Line Item
I FBFPPSC]"" W !!! S FBFPPSL=$$FPPSL^FBUTL5() I FBFPPSL=-1 K FBFPPSL G CHK
D ^FBAASAP K FBPHARM I 'DFN K DFN G CHK
;
I '$D(FB583),'$$UOKPAY^FBUTL9(DFN,FTP) D G RDP
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
;
I FBTT=1 S FBMST="Y",FBTTYPE="A",FBFDC="",FBD1=FTP D ENT^FBAAAUT
D HOME^%ZIS,FBPH^FBAAUTL2 I $D(DIRUT),$D(FB583) G CHK
RDD W !! S %DT(0)=-DT,%DT="AEXP",%DT("A")="DATE PRESCRIPTION FILLED: " D ^%DT K %DT G:X["^"!(X="") RDP G RDD:Y<0 S DATEF=Y
I DATEF<FBAABDT!(DATEF>FBAAEDT) W !!,*7,"Date Prescription Filled is ",$S(DATEF<FBAABDT:" prior to ",1:"later than "),"authorization period!!" G RDD
I INVDATE]"",DATEF>INVDATE D G RDD
.N SHOINVDT S SHOINVDT=$E(INVDATE,4,5)_"/"_$E(INVDATE,6,7)_"/"_$E(INVDATE,2,3)
.W !!,*7,?5,"*** Date Prescription Filled cannot be later than",!?8," Invoice Received Date (",SHOINVDT,") !!!"
;
; FB*3.5*123 - for IPAC capture the DoD Invoice number
I $G(FBIA),'$$IPACINV^FBAAMP(.FBDODINV) G RDD
I '$G(FBIA) S FBDODINV=""
;
I '$D(^FBAA(162.1,IN,"RX",0)) S ^FBAA(162.1,IN,"RX",0)="^162.11A^^"
RDRX S DIR(0)="162.11,.01",DIR("A")="Select PRESCRIPTION NUMBER" D ^DIR K DIR G CHK:Y="^"!(Y="") S PSRX=Y,AC=0
I $D(^FBAA(162.1,IN,"RX","B",PSRX)) G RX2^FBAAPIE1
D CHK2^FBAAPIE1 I FBJ]"" K FBJ G CHKK^FBAAPIE1
RXADD K DA S DLAYGO=162.1,DA(1)=IN,DIC="^FBAA(162.1,"_IN_",""RX"",",DIC(0)="EQL",X=""""_PSRX_"""" D ^DIC K DLAYGO G:Y<0 RDRX S FBDA=+Y
S DIE="^FBAA(162.1,",DA=IN,DR="[FB ADD RX]" D ^DIE I $D(DTOUT)!('$G(FBUP)) G DELRX
S LCNT=LCNT+1,TAC=TAC+AC K FBUP
RDDER W !!,*7,"Prescription referred to Pharmacy Service for determination.",! S X="Y"
S STAT(1)="" G RDP:'$D(FB583),Q^FBAAPIE1
S $P(^FBAA(162.1,IN,"RX",DA,2),"^")="P",^FBAA(162.1,"AH","P",IN,DA)="",$P(^FBAA(162.1,IN,0),"^",10)="P"
S DA(1)=IN,DIE=DIC
HERE S:$D(FBAP) FBINTOT=FBINTOT+FBAP S:$D(DTOUT) FBTOUT="" G OVR:$D(DTOUT),RDD
CHK I LCNT'>0 W !!,"Since you didn't enter any line items",!,"Invoice # ",IN," has been Deleted!!",*7 D KILL G Q^FBAAPIE1:$D(FBTOUT),MORE:'$D(FB583),Q^FBAAPIE1
OVR K DTOUT,DR,DQ,DG
K STAT(2)
S (DIE,DIC)="^FBAA(162.1,",DA=IN,STAT=$O(STAT(0)),DR="5////^S X=STAT;6///^S X=TAC;7///^S X=FBINTOT;8///^S X=LCNT" D ^DIE G:$D(FBTOUT) Q^FBAAPIE1 W !!,"Invoice No.: ",IN," Completed!" W:FBINTOT>0 ?45,"Invoice Total: $ ",$J(FBINTOT,1,2)
MORE K STAT,FBHX W ! S DIR("A")="Want to enter another Invoice",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G Q^FBAAPIE1:$D(DIRUT)!('Y),ENTER
Q
KILL S DIK="^FBAA(162.1,",DA=IN D ^DIK K DIK Q
DELRX S DIK="^FBAA(162.1,"_DA(1)_",""RX"",",DA=FBDA D ^DIK K DTOUT,DQ,DR,DG S FBTOUT="" W !,"Incomplete prescription entry. Deleted.",! G CHK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPIE 4983 printed Oct 16, 2024@17:56:54 Page 2
FBAAPIE ;AISC/GRR - ENTER FEE PHARMACY INVOICE ;9/25/2014
+1 ;;3.5;FEE BASIS;**61,124,123,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 DO SITEP^FBAAUTL
if FBPOP
WRITE !!,*7,"Fee site parameters must be initialized!!"
if FBPOP
QUIT
SET FBMDF=$PIECE(FBSITE(0),"^",10)
SET FBAAPTC=$SELECT($DATA(FBAAPTC):FBAAPTC,1:"V")
+4 NEW FBIA,FBDODINV
RD1 WRITE !
SET DIR("A")="Are you sure you want to enter a new invoice"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q^FBAAPIE1
if 'Y
GOTO RDM^FBAAPIE1
ENTER SET (LCNT,TAC,FBINTOT)=0
SET STAT(0)=""
SET FBAAOUT=1
KILL FBTOUT
+1 DO GETNXI^FBAAUTL
SET X=FBAAIN
+2 SET DLAYGO=162.1
SET DIC="^FBAA(162.1,"
SET DIC(0)="LQ"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO PROB^FBAAPIE1
WRITE !!,"Invoice # assigned is: ",X
SET IN=X
SET DA(1)=IN
RDV IF '$DATA(FB583)
WRITE !!
SET DLAYGO=161.2
SET (DIE,DIC)="^FBAAV("
SET DIC(0)="AEQLM"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO CHK
SET DA=+Y
if $PIECE(Y,"^",3)=1
DO NEW^FBAAVD
+1 IF $DATA(FB583)
SET DA=FBVEN
+2 IF $DATA(^FBAAV(DA,0))
IF $PIECE($GET(^("ADEL")),"^")="Y"
WRITE !!,"Vendor is flagged for Austin deletion!"
if '$DATA(FB583)
GOTO RDV
GOTO Q^FBAAPIE1
+3 if $PIECE(FBSITE(0),"^",12)="Y"
DO EN1^FBAAVD
SET VIN=DA
RDV1 IF $DATA(^XUSEC("FBAA ESTABLISH VENDOR",DUZ))
WRITE !
SET DIR("A")="Want to edit Vendor data"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO CHK
if Y
DO EDITV^FBAAVD
SET VIN=DA
+1 SET FBAR(DA)=""
DO ^FBAACO4
+2 ;
+3 ; FB*3.5*123 - check for IPAC agreement for Federal Vendor
+4 SET FBIA=$$IPAC^FBAAMP($GET(VIN))
IF FBIA=-1
GOTO CHK
+5 ;
+6 WRITE !!
SET %DT="AEQXP"
SET %DT(0)=-DT
SET %DT("A")="Date Correct Invoice Received: "
DO ^%DT
KILL %DT(0),%DT("A")
if Y<0
GOTO CHK
SET INVDATE=Y
+7 WRITE !!
SET %DT="AEQXP"
SET %DT(0)=-INVDATE
SET %DT("A")="Vendor Invoice Date: "
DO ^%DT
KILL %DT(0),%DT("A")
if Y<0
GOTO CHK
SET FBVINVDT=Y
+8 ; if U/C then get FPPS Claim ID else ask user
+9 IF $DATA(FB583)
SET FBFPPSC=$PIECE($GET(^FB583(FB583,5)),U)
WRITE !,"FPPS CLAIM ID: ",$SELECT(FBFPPSC="":"N/A",1:FBFPPSC)
+10 IF '$TEST
SET FBFPPSC=$$FPPSC^FBUTL5()
IF FBFPPSC=-1
KILL FBFPPSC
GOTO CHK
+11 SET (DIE,DIC)="^FBAA(162.1,"
SET DA=IN
+12 SET DR="1////^S X=INVDATE;1.5////^S X=DT;2////^S X=DUZ;3////^S X=VIN;5////^S X=1;12////^S X=FBVINVDT;13///^S X=FBFPPSC"
+13 ; FB*3.5*123 file IPAC agreement ptr if it exists
IF $GET(FBIA)
SET DR=DR_";14////^S X=FBIA"
+14 DO ^DIE
+15 IF '$DATA(^FBAA(162.1,IN,"RX",0))
SET ^FBAA(162.1,IN,"RX",0)="^162.11A^^"
RDP SET FBPHARM=1
if FBINTOT>0
WRITE !,?15,"Pharmacy Invoice #: "_IN_" Totals: $ "_$JUSTIFY(FBINTOT,1,2)
+1 ; if EDI then ask FPPS Line Item
+2 IF FBFPPSC]""
WRITE !!!
SET FBFPPSL=$$FPPSL^FBUTL5()
IF FBFPPSL=-1
KILL FBFPPSL
GOTO CHK
+3 DO ^FBAASAP
KILL FBPHARM
IF 'DFN
KILL DFN
GOTO CHK
+4 ;
+5 IF '$DATA(FB583)
IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+6 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+7 WRITE !,"due to separation of duties."
End DoDot:1
GOTO RDP
+8 ;
+9 IF FBTT=1
SET FBMST="Y"
SET FBTTYPE="A"
SET FBFDC=""
SET FBD1=FTP
DO ENT^FBAAAUT
+10 DO HOME^%ZIS
DO FBPH^FBAAUTL2
IF $DATA(DIRUT)
IF $DATA(FB583)
GOTO CHK
RDD WRITE !!
SET %DT(0)=-DT
SET %DT="AEXP"
SET %DT("A")="DATE PRESCRIPTION FILLED: "
DO ^%DT
KILL %DT
if X["^"!(X="")
GOTO RDP
if Y<0
GOTO RDD
SET DATEF=Y
+1 IF DATEF<FBAABDT!(DATEF>FBAAEDT)
WRITE !!,*7,"Date Prescription Filled is ",$SELECT(DATEF<FBAABDT:" prior to ",1:"later than "),"authorization period!!"
GOTO RDD
+2 IF INVDATE]""
IF DATEF>INVDATE
Begin DoDot:1
+3 NEW SHOINVDT
SET SHOINVDT=$EXTRACT(INVDATE,4,5)_"/"_$EXTRACT(INVDATE,6,7)_"/"_$EXTRACT(INVDATE,2,3)
+4 WRITE !!,*7,?5,"*** Date Prescription Filled cannot be later than",!?8," Invoice Received Date (",SHOINVDT,") !!!"
End DoDot:1
GOTO RDD
+5 ;
+6 ; FB*3.5*123 - for IPAC capture the DoD Invoice number
+7 IF $GET(FBIA)
IF '$$IPACINV^FBAAMP(.FBDODINV)
GOTO RDD
+8 IF '$GET(FBIA)
SET FBDODINV=""
+9 ;
+10 IF '$DATA(^FBAA(162.1,IN,"RX",0))
SET ^FBAA(162.1,IN,"RX",0)="^162.11A^^"
RDRX SET DIR(0)="162.11,.01"
SET DIR("A")="Select PRESCRIPTION NUMBER"
DO ^DIR
KILL DIR
if Y="^"!(Y="")
GOTO CHK
SET PSRX=Y
SET AC=0
+1 IF $DATA(^FBAA(162.1,IN,"RX","B",PSRX))
GOTO RX2^FBAAPIE1
+2 DO CHK2^FBAAPIE1
IF FBJ]""
KILL FBJ
GOTO CHKK^FBAAPIE1
RXADD KILL DA
SET DLAYGO=162.1
SET DA(1)=IN
SET DIC="^FBAA(162.1,"_IN_",""RX"","
SET DIC(0)="EQL"
SET X=""""_PSRX_""""
DO ^DIC
KILL DLAYGO
if Y<0
GOTO RDRX
SET FBDA=+Y
+1 SET DIE="^FBAA(162.1,"
SET DA=IN
SET DR="[FB ADD RX]"
DO ^DIE
IF $DATA(DTOUT)!('$GET(FBUP))
GOTO DELRX
+2 SET LCNT=LCNT+1
SET TAC=TAC+AC
KILL FBUP
RDDER WRITE !!,*7,"Prescription referred to Pharmacy Service for determination.",!
SET X="Y"
+1 SET STAT(1)=""
if '$DATA(FB583)
GOTO RDP
GOTO Q^FBAAPIE1
+2 SET $PIECE(^FBAA(162.1,IN,"RX",DA,2),"^")="P"
SET ^FBAA(162.1,"AH","P",IN,DA)=""
SET $PIECE(^FBAA(162.1,IN,0),"^",10)="P"
+3 SET DA(1)=IN
SET DIE=DIC
HERE if $DATA(FBAP)
SET FBINTOT=FBINTOT+FBAP
if $DATA(DTOUT)
SET FBTOUT=""
if $DATA(DTOUT)
GOTO OVR
GOTO RDD
CHK IF LCNT'>0
WRITE !!,"Since you didn't enter any line items",!,"Invoice # ",IN," has been Deleted!!",*7
DO KILL
if $DATA(FBTOUT)
GOTO Q^FBAAPIE1
if '$DATA(FB583)
GOTO MORE
GOTO Q^FBAAPIE1
OVR KILL DTOUT,DR,DQ,DG
+1 KILL STAT(2)
+2 SET (DIE,DIC)="^FBAA(162.1,"
SET DA=IN
SET STAT=$ORDER(STAT(0))
SET DR="5////^S X=STAT;6///^S X=TAC;7///^S X=FBINTOT;8///^S X=LCNT"
DO ^DIE
if $DATA(FBTOUT)
GOTO Q^FBAAPIE1
WRITE !!,"Invoice No.: ",IN," Completed!"
if FBINTOT>0
WRITE ?45,"Invoice Total: $ ",$JUSTIFY(FBINTOT,1,2)
MORE KILL STAT,FBHX
WRITE !
SET DIR("A")="Want to enter another Invoice"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO Q^FBAAPIE1
GOTO ENTER
+1 QUIT
KILL SET DIK="^FBAA(162.1,"
SET DA=IN
DO ^DIK
KILL DIK
QUIT
DELRX SET DIK="^FBAA(162.1,"_DA(1)_",""RX"","
SET DA=FBDA
DO ^DIK
KILL DTOUT,DQ,DR,DG
SET FBTOUT=""
WRITE !,"Incomplete prescription entry. Deleted.",!
GOTO CHK
