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