- FBAAEPI ;AISC/GRR - EDIT PREVIOUSLY ENTERED PHARMACY INVOICE ;11/20/2014
- ;;3.5;FEE BASIS;**38,61,124,132,123,154,158**;JAN 30, 1995;Build 94
- ;;Per VA Directive 6402, this routine should not be modified.
- RD W ! S DIC="^FBAA(162.1,",DIC(0)="AEQM",DIC("A")="Select Invoice #: ",DIC("S")="I $P(^(0),U,5)'=4!($P(^(0),U,5)=4&$D(^XUSEC(""FBAA LEVEL 2"",DUZ)))" D ^DIC K DIC("S") G END:X=""!(X="^"),RD:Y<0
- S (DA,FBDA)=+Y,DIE=DIC
- ;
- ; loop thru Rx and enforce separation of duty
- I $$SODPINV(FBDA) D G RD
- . W !!,"You cannot process this payment due to separation of duties."
- . W !,"You previously entered/edited an associated authorization."
- ;
- ; save FPPS data prior to edit session
- S (FBFPPSC,FBFPPSC(0))=$P($G(^FBAA(162.1,FBDA,0)),U,13)
- D LASTRXDT ;Look up last RX FILL DATE in selected invoice, for use in validating Invoice Received Date if it is edited.
- S DR="@1;1;I $$BADDATE^FBAAEPI(LASTRXDT,X) S Y=""@1"";Q;12;S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:FBX=-1 Y=0;S:FBX="""" Y=""@10"";13///^S X=FBX;S FBFPPSC=X;S Y=""@15"";@10;13///@;S FBFPPSC="""";@15;3;5"
- D ^DIE K DIC
- ; if FPPS CLAIM ID changed, then update Rx's
- I FBFPPSC'=FBFPPSC(0) D CKINVEDI^FBAAEPI1(FBFPPSC(0),FBFPPSC,FBDA)
- S DIC="^FBAA(162.1,DA,""RX"",",DIC(0)="AEQM",DIC("W")="W ?30,""DATE RX FILLED: "",$E($P(^(0),U,3),4,5)_""/""_$E($P(^(0),U,3),6,7)_""/""_$E($P(^(0),U,3),2,3)" D ^DIC K DIC("W")
- I Y<0 D END G RD ; a prescription was not selected
- W !
- S (FBJ,FBK)=0
- ;check status of batch rx is in.
- S DA=+Y,DA(1)=FBDA S FBSTAT=$P($G(^FBAA(161.7,+$P($G(^FBAA(162.1,+FBDA,"RX",+DA,0)),U,17),"ST")),U) I FBSTAT]"" D
- .I '$D(^XUSEC("FBAA LEVEL 2",DUZ)) D
- .. I $S(FBSTAT="O":0,FBSTAT="C":0,1:1) D
- ... W !,*7,"You cannot edit a payment once released by a supervisor.",! S FBOUT=1 Q
- .I $S(FBSTAT="T":1,FBSTAT="F":1,FBSTAT="V":1,1:0) D
- .. W !,*7,"You cannot edit an invoice when the batch has been sent to Austin",! S FBOUT=1
- I $G(FBOUT) D END G FBAAEPI
- ;
- ; FB*3.5*123 - Edit pharmacy IPAC data for Federal Vendors
- I '$$IPACEDIT^FBAAPET1(162.1,.DA) D END G FBAAEPI
- ;
- S DIE="^FBAA(162.1,FBDA,""RX"","
- ; get current value of FPPS LINE ITEM to use as default
- S FBFPPSL=$P($G(^FBAA(162.1,FBDA,"RX",DA,3)),U)
- ; load current adjustment data
- D LOADADJ^FBRXFA(DA_","_FBDA_",",.FBADJ)
- ; save adjustment data prior to edit session in sorted list
- S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
- ; load current remittance remark data
- D LOADRR^FBRXFR(DA_","_FBDA_",",.FBRRMK)
- ; save remittance remarks prior to edit session in sorted list
- S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
- S DR=".01;S:FBFPPSC="""" Y=1;S FBX=$$FPPSL^FBUTL5(FBFPPSL);S:FBX=-1 Y=0;36///^S X=FBX;S FBFPPSL=X;1;1.5;1.6;3;S FBJ=X;I $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,9)=1 S Y="""";I 1;5"
- S DR(1,162.11,1)="S FBA=$P($G(^FBAA(162.1,DA(1),""RX"",DA,2)),U,6);S FB1725=$S(FBA[""FB583"":+$P($G(^FB583(+FBA,0)),U,28),1:0);W:FB1725 !?2,""**Payment is for emergency treatment under 38 U.S.C. 1725."""
- S DR(1,162.11,2)="@12;S FBHAP=$P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16);6.5;S FBK=X;S:FBK]"""" Y=""@20"";K FBADJ,FBRRMK;S Y=8"
- S DR(1,162.11,3)="@20;I FBK>FBJ S $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16)=FBHAP W !,*7,""Amount Paid cannot be greater than the Amount Claimed"" S Y=""@12"""
- S DR(1,162.11,4)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,5,,.FBADJD,1,.FBRRMK,1);K FBADJD;S:FBX=-1 Y=0;8"
- D ^DIE
- I '$D(DA) D END G RD ; prescription was deleted
- ; if adjustment data changed then file
- I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBRXFA(DA_","_FBDA_",",.FBADJ)
- ; if remit remark data changed then file
- I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBRXFR(DA_","_FBDA_",",.FBRRMK)
- ; clean up and return to invoice selection
- D END G RD
- ;
- LASTRXDT ;Look up last RX FILL DATE in selected invoice, for use in validating Invoice Received Date if it is edited.
- ;DA contains the selected INV#
- N I
- S LASTRXDT=0
- F I=1:1 Q:'$D(^FBAA(162.1,DA,"RX",I)) D
- .N RXDT S RXDT=$P(^FBAA(162.1,DA,"RX",I,0),"^",3)
- .I RXDT>LASTRXDT S LASTRXDT=RXDT,RXNUM=$P(^FBAA(162.1,DA,"RX",I,0),"^",1)
- Q
- ;
- BADDATE(LASTRXDT,INVRCVDT) ;Reject entry if InvRcvDt is Prior to the last Rx Fill Date on the Invoice
- I INVRCVDT<LASTRXDT D Q 1 ;Reject entry
- .N SHOWRXDT S SHOWRXDT=$E(LASTRXDT,4,5)_"/"_$E(LASTRXDT,6,7)_"/"_$E(LASTRXDT,2,3) ;Convert RXDT into display format for error message
- .W *7,!!?5,"*** Invoice Received Date cannot be prior to the last",!?8," Prescription Filled Date on the Invoice ("_SHOWRXDT_" for RX# "_RXNUM_") !!!"
- Q 0 ;Accept entry
- ;
- END K D,DA,DIC,DIE,DR,FBJ,FBK,FBDA,FBOUT,FBSTAT,FBHAP,X,Y,FBA,FB1725
- K FBADJ,FBADJD,FBADJL,FBFPPSC,FBFPPSL,FBRRMK,FBRRMKD,FBRRMKL,LASTRXDT,RXNUM
- Q
- ;
- GETIPAC(FBDA,FBVEN,FBIA,FBDODINV) ; Get vendor/IPAC data for Pharmacy (FB*3.5*123)
- ; All parameters required and assumed to exist
- ; Called by $$IPACEDIT^FBAAPET1
- S FBVEN=+$P($G(^FBAA(162.1,FBDA(1),0)),U,4) ; vendor ien
- S FBIA=+$P($G(^FBAA(162.1,FBDA(1),0)),U,23) ; IPAC agreement ien
- S FBDODINV=$P($G(^FBAA(162.1,FBDA(1),"RX",FBDA,6)),U,1) ; DoD invoice#
- Q
- ;
- DELIPAC(FBDA) ; Delete all IPAC data on file for Pharmacy (FB*3.5*123)
- ; Called by $$IPACEDIT^FBAAPET1
- N FBIENS,FBIAFDA,DIE,DA,DR,DIC
- S FBIENS=FBDA_","_FBDA(1)_","
- S FBIAFDA(162.11,FBIENS,39)="" ; remove DoD invoice# from subfile 162.11
- D FILE^DIE("","FBIAFDA")
- S DIE=162.1,DA=FBDA(1),DR="14///@" D ^DIE ; remove IPAC ptr from file top level 162.1
- Q
- ;
- SAVEIPAC(FBDA,FBIA,FBDODINV,WHICH) ; Store IPAC data into the database for Pharmacy (FB*3.5*123)
- ; Called by $$IPACEDIT^FBAAPET1
- N FBIENS,FBIAFDA,DIE,DA,DR,DIC
- S:'$D(WHICH) WHICH=""
- S FBIENS=FBDA_","_FBDA(1)_","
- I WHICH'=1 D
- . S FBIAFDA(162.11,FBIENS,39)=FBDODINV ; store DoD invoice# in subfile 162.11
- . D FILE^DIE("","FBIAFDA")
- I WHICH'=2 D
- . S DIE=162.1,DA=FBDA(1),DR="14////^S X=FBIA" D ^DIE ; store IPAC pointer ien in file top level 162.1
- Q
- ;
- SODPINV(FBDA) ; check separation of duty for pharmacy invoice
- ; checks all prescriptions on invoice for separation of duty issue
- ; input
- ; FBDA (required) IEN of pharmacy invoice in file 162.1
- ; DUZ (current user)
- ; result
- ; = 0 if user did not enter or edit any associated authorization
- ; = 1 if user did enter or edit at least one associated authorization
- ; and thus should be prevented from processing the payment
- N FBDFN,FBFTP,FBI,FBRET
- S FBRET=0
- ; loop thru all Rx on invoice
- S FBI=0 F S FBI=$O(^FBAA(162.1,FBDA,"RX",FBI)) Q:'FBI D Q:FBRET
- . S FBDFN=$P($G(^FBAA(162.1,FBDA,"RX",FBI,0)),U,5)
- . Q:'FBDFN
- . S FBFTP=$P($G(^FBAA(162.1,FBDA,"RX",FBI,2)),U,7)
- . Q:'FBFTP
- . I '$$UOKPAY^FBUTL9(FBDFN,FBFTP) S FBRET=1
- Q FBRET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAEPI 6778 printed Jan 18, 2025@02:56:35 Page 2
- FBAAEPI ;AISC/GRR - EDIT PREVIOUSLY ENTERED PHARMACY INVOICE ;11/20/2014
- +1 ;;3.5;FEE BASIS;**38,61,124,132,123,154,158**;JAN 30, 1995;Build 94
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- RD WRITE !
- SET DIC="^FBAA(162.1,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select Invoice #: "
- SET DIC("S")="I $P(^(0),U,5)'=4!($P(^(0),U,5)=4&$D(^XUSEC(""FBAA LEVEL 2"",DUZ)))"
- DO ^DIC
- KILL DIC("S")
- if X=""!(X="^")
- GOTO END
- if Y<0
- GOTO RD
- +1 SET (DA,FBDA)=+Y
- SET DIE=DIC
- +2 ;
- +3 ; loop thru Rx and enforce separation of duty
- +4 IF $$SODPINV(FBDA)
- Begin DoDot:1
- +5 WRITE !!,"You cannot process this payment due to separation of duties."
- +6 WRITE !,"You previously entered/edited an associated authorization."
- End DoDot:1
- GOTO RD
- +7 ;
- +8 ; save FPPS data prior to edit session
- +9 SET (FBFPPSC,FBFPPSC(0))=$PIECE($GET(^FBAA(162.1,FBDA,0)),U,13)
- +10 ;Look up last RX FILL DATE in selected invoice, for use in validating Invoice Received Date if it is edited.
- DO LASTRXDT
- +11 SET DR="@1;1;I $$BADDATE^FBAAEPI(LASTRXDT,X) S Y=""@1"";Q;12;S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:FBX=-1 Y=0;S:FBX="""" Y=""@10"";13///^S X=FBX;S FBFPPSC=X;S Y=""@15"";@10;13///@;S FBFPPSC="""";@15;3;5"
- +12 DO ^DIE
- KILL DIC
- +13 ; if FPPS CLAIM ID changed, then update Rx's
- +14 IF FBFPPSC'=FBFPPSC(0)
- DO CKINVEDI^FBAAEPI1(FBFPPSC(0),FBFPPSC,FBDA)
- +15 SET DIC="^FBAA(162.1,DA,""RX"","
- SET DIC(0)="AEQM"
- SET DIC("W")="W ?30,""DATE RX FILLED: "",$E($P(^(0),U,3),4,5)_""/""_$E($P(^(0),U,3),6,7)_""/""_$E($P(^(0),U,3),2,3)"
- DO ^DIC
- KILL DIC("W")
- +16 ; a prescription was not selected
- IF Y<0
- DO END
- GOTO RD
- +17 WRITE !
- +18 SET (FBJ,FBK)=0
- +19 ;check status of batch rx is in.
- +20 SET DA=+Y
- SET DA(1)=FBDA
- SET FBSTAT=$PIECE($GET(^FBAA(161.7,+$PIECE($GET(^FBAA(162.1,+FBDA,"RX",+DA,0)),U,17),"ST")),U)
- IF FBSTAT]""
- Begin DoDot:1
- +21 IF '$DATA(^XUSEC("FBAA LEVEL 2",DUZ))
- Begin DoDot:2
- +22 IF $SELECT(FBSTAT="O":0,FBSTAT="C":0,1:1)
- Begin DoDot:3
- +23 WRITE !,*7,"You cannot edit a payment once released by a supervisor.",!
- SET FBOUT=1
- QUIT
- End DoDot:3
- End DoDot:2
- +24 IF $SELECT(FBSTAT="T":1,FBSTAT="F":1,FBSTAT="V":1,1:0)
- Begin DoDot:2
- +25 WRITE !,*7,"You cannot edit an invoice when the batch has been sent to Austin",!
- SET FBOUT=1
- End DoDot:2
- End DoDot:1
- +26 IF $GET(FBOUT)
- DO END
- GOTO FBAAEPI
- +27 ;
- +28 ; FB*3.5*123 - Edit pharmacy IPAC data for Federal Vendors
- +29 IF '$$IPACEDIT^FBAAPET1(162.1,.DA)
- DO END
- GOTO FBAAEPI
- +30 ;
- +31 SET DIE="^FBAA(162.1,FBDA,""RX"","
- +32 ; get current value of FPPS LINE ITEM to use as default
- +33 SET FBFPPSL=$PIECE($GET(^FBAA(162.1,FBDA,"RX",DA,3)),U)
- +34 ; load current adjustment data
- +35 DO LOADADJ^FBRXFA(DA_","_FBDA_",",.FBADJ)
- +36 ; save adjustment data prior to edit session in sorted list
- +37 ; sorted list of original adjustments
- SET FBADJL(0)=$$ADJL^FBUTL2(.FBADJ)
- +38 ; load current remittance remark data
- +39 DO LOADRR^FBRXFR(DA_","_FBDA_",",.FBRRMK)
- +40 ; save remittance remarks prior to edit session in sorted list
- +41 SET FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
- +42 SET DR=".01;S:FBFPPSC="""" Y=1;S FBX=$$FPPSL^FBUTL5(FBFPPSL);S:FBX=-1 Y=0;36///^S X=FBX;S FBFPPSL=X;1;1.5;1.6;3;S FBJ=X;I $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,9)=1 S Y="""";I 1;5"
- +43 SET DR(1,162.11,1)="S FBA=$P($G(^FBAA(162.1,DA(1),""RX"",DA,2)),U,6);S FB1725=$S(FBA[""FB583"":+$P($G(^FB583(+FBA,0)),U,28),1:0);W:FB1725 !?2,""**Payment is for emergency treatment under 38 U.S.C. 1725."""
- +44 SET DR(1,162.11,2)="@12;S FBHAP=$P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16);6.5;S FBK=X;S:FBK]"""" Y=""@20"";K FBADJ,FBRRMK;S Y=8"
- +45 SET DR(1,162.11,3)="@20;I FBK>FBJ S $P(^FBAA(162.1,DA(1),""RX"",DA,0),U,16)=FBHAP W !,*7,""Amount Paid cannot be greater than the Amount Claimed"" S Y=""@12"""
- +46 SET DR(1,162.11,4)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,5,,.FBADJD,1,.FBRRMK,1);K FBADJD;S:FBX=-1 Y=0;8"
- +47 DO ^DIE
- +48 ; prescription was deleted
- IF '$DATA(DA)
- DO END
- GOTO RD
- +49 ; if adjustment data changed then file
- +50 IF $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0)
- DO FILEADJ^FBRXFA(DA_","_FBDA_",",.FBADJ)
- +51 ; if remit remark data changed then file
- +52 IF $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0)
- DO FILERR^FBRXFR(DA_","_FBDA_",",.FBRRMK)
- +53 ; clean up and return to invoice selection
- +54 DO END
- GOTO RD
- +55 ;
- LASTRXDT ;Look up last RX FILL DATE in selected invoice, for use in validating Invoice Received Date if it is edited.
- +1 ;DA contains the selected INV#
- +2 NEW I
- +3 SET LASTRXDT=0
- +4 FOR I=1:1
- if '$DATA(^FBAA(162.1,DA,"RX",I))
- QUIT
- Begin DoDot:1
- +5 NEW RXDT
- SET RXDT=$PIECE(^FBAA(162.1,DA,"RX",I,0),"^",3)
- +6 IF RXDT>LASTRXDT
- SET LASTRXDT=RXDT
- SET RXNUM=$PIECE(^FBAA(162.1,DA,"RX",I,0),"^",1)
- End DoDot:1
- +7 QUIT
- +8 ;
- BADDATE(LASTRXDT,INVRCVDT) ;Reject entry if InvRcvDt is Prior to the last Rx Fill Date on the Invoice
- +1 ;Reject entry
- IF INVRCVDT<LASTRXDT
- Begin DoDot:1
- +2 ;Convert RXDT into display format for error message
- NEW SHOWRXDT
- SET SHOWRXDT=$EXTRACT(LASTRXDT,4,5)_"/"_$EXTRACT(LASTRXDT,6,7)_"/"_$EXTRACT(LASTRXDT,2,3)
- +3 WRITE *7,!!?5,"*** Invoice Received Date cannot be prior to the last",!?8," Prescription Filled Date on the Invoice ("_SHOWRXDT_" for RX# "_RXNUM_") !!!"
- End DoDot:1
- QUIT 1
- +4 ;Accept entry
- QUIT 0
- +5 ;
- END KILL D,DA,DIC,DIE,DR,FBJ,FBK,FBDA,FBOUT,FBSTAT,FBHAP,X,Y,FBA,FB1725
- +1 KILL FBADJ,FBADJD,FBADJL,FBFPPSC,FBFPPSL,FBRRMK,FBRRMKD,FBRRMKL,LASTRXDT,RXNUM
- +2 QUIT
- +3 ;
- GETIPAC(FBDA,FBVEN,FBIA,FBDODINV) ; Get vendor/IPAC data for Pharmacy (FB*3.5*123)
- +1 ; All parameters required and assumed to exist
- +2 ; Called by $$IPACEDIT^FBAAPET1
- +3 ; vendor ien
- SET FBVEN=+$PIECE($GET(^FBAA(162.1,FBDA(1),0)),U,4)
- +4 ; IPAC agreement ien
- SET FBIA=+$PIECE($GET(^FBAA(162.1,FBDA(1),0)),U,23)
- +5 ; DoD invoice#
- SET FBDODINV=$PIECE($GET(^FBAA(162.1,FBDA(1),"RX",FBDA,6)),U,1)
- +6 QUIT
- +7 ;
- DELIPAC(FBDA) ; Delete all IPAC data on file for Pharmacy (FB*3.5*123)
- +1 ; Called by $$IPACEDIT^FBAAPET1
- +2 NEW FBIENS,FBIAFDA,DIE,DA,DR,DIC
- +3 SET FBIENS=FBDA_","_FBDA(1)_","
- +4 ; remove DoD invoice# from subfile 162.11
- SET FBIAFDA(162.11,FBIENS,39)=""
- +5 DO FILE^DIE("","FBIAFDA")
- +6 ; remove IPAC ptr from file top level 162.1
- SET DIE=162.1
- SET DA=FBDA(1)
- SET DR="14///@"
- DO ^DIE
- +7 QUIT
- +8 ;
- SAVEIPAC(FBDA,FBIA,FBDODINV,WHICH) ; Store IPAC data into the database for Pharmacy (FB*3.5*123)
- +1 ; Called by $$IPACEDIT^FBAAPET1
- +2 NEW FBIENS,FBIAFDA,DIE,DA,DR,DIC
- +3 if '$DATA(WHICH)
- SET WHICH=""
- +4 SET FBIENS=FBDA_","_FBDA(1)_","
- +5 IF WHICH'=1
- Begin DoDot:1
- +6 ; store DoD invoice# in subfile 162.11
- SET FBIAFDA(162.11,FBIENS,39)=FBDODINV
- +7 DO FILE^DIE("","FBIAFDA")
- End DoDot:1
- +8 IF WHICH'=2
- Begin DoDot:1
- +9 ; store IPAC pointer ien in file top level 162.1
- SET DIE=162.1
- SET DA=FBDA(1)
- SET DR="14////^S X=FBIA"
- DO ^DIE
- End DoDot:1
- +10 QUIT
- +11 ;
- SODPINV(FBDA) ; check separation of duty for pharmacy invoice
- +1 ; checks all prescriptions on invoice for separation of duty issue
- +2 ; input
- +3 ; FBDA (required) IEN of pharmacy invoice in file 162.1
- +4 ; DUZ (current user)
- +5 ; result
- +6 ; = 0 if user did not enter or edit any associated authorization
- +7 ; = 1 if user did enter or edit at least one associated authorization
- +8 ; and thus should be prevented from processing the payment
- +9 NEW FBDFN,FBFTP,FBI,FBRET
- +10 SET FBRET=0
- +11 ; loop thru all Rx on invoice
- +12 SET FBI=0
- FOR
- SET FBI=$ORDER(^FBAA(162.1,FBDA,"RX",FBI))
- if 'FBI
- QUIT
- Begin DoDot:1
- +13 SET FBDFN=$PIECE($GET(^FBAA(162.1,FBDA,"RX",FBI,0)),U,5)
- +14 if 'FBDFN
- QUIT
- +15 SET FBFTP=$PIECE($GET(^FBAA(162.1,FBDA,"RX",FBI,2)),U,7)
- +16 if 'FBFTP
- QUIT
- +17 IF '$$UOKPAY^FBUTL9(FBDFN,FBFTP)
- SET FBRET=1
- End DoDot:1
- if FBRET
- QUIT
- +18 QUIT FBRET