source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAACIE.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1FBAACIE ;AISC/GRR-COMPLETE PHARMACY INVOICE ;4/21/2004
2 ;;3.5;FEE BASIS;**38,61,91**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 D DT^DICRW,HOME^%ZIS I '$D(^FBAA(162.1,"AC",2)) W !!,*7,"There are no Invoices Pending completion!",!! Q
5 D SITEP^FBAAUTL I FBPOP W !,*7,"Fee Site Parameters must be Initialized!" K FBPOP Q
6 S FBAAOUT=1,FBMDF=$P(FBSITE(0),"^",10),UL="",$P(UL,"=",79)="="
7RINV 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)
8 I '$D(^FBAA(162.1,FBIN,"RX","AC",2)) G RINV
9 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
10 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
11 I $D(^FBAA(162.1,"AC",3,FBIN)) W !!,"Invoice is Complete",?30,"Totals: $ "_$J(FBINTOT,1,2)
12 G RINV
13END 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
14 K FBADJ,FBFPPSC,FBFPPSL,FBRRMK,DTOUT
15 Q
16GOT S FBDRUG=$P(Y(0),"^",2)
17 S FBGENSUB=$$GET1^DIQ(162.11,J_","_FBIN_",",8.5)
18 S FBGEN=$$GET1^DIQ(162.11,J_","_FBIN_",",9)
19 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)
20 S FBSTR=$P(Y(0),"^",12),FBQTY=$P(Y(0),"^",13),FBAAPR=$P(Y(0),"^",22)
21 S Y=$S($D(^FBAA(162.1,FBIN,0)):^(0),1:"")
22 S FBFPPSC=$P(Y,U,13)
23 S FBFPPSL=$P($G(^FBAA(162.1,FBIN,"RX",J,3)),U)
24 S FBVEN=+$P(Y,"^",4),FBVNAME=$$VEN^FBUCUTL(FBVEN),FBVID=$P($G(^FBAAV(FBVEN,0)),"^",2)
25 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
26 S Y(2)=$G(^FBAA(162.1,FBIN,"RX",J,2))
27 S FB1725=$S($P(Y(2),U,6)["FB583":+$P($G(^FB583(+$P(Y(2),U,6),0)),U,28),1:0)
28 W @IOF,"Vendor: ",FBVNAME," Vendor ID: ",FBVID
29 W !!,"Patient: ",FBPATN," Patient ID: ",FBPID
30 W !,"FPPS Claim ID: ",$S(FBFPPSC="":"N/A",1:FBFPPSC)
31 W ?28,"FPPS Line Item: ",$S(FBFPPSL="":"N/A",1:FBFPPSL)
32 W !!,"Drug Name",?32," RX # "," Strength "," Qty"," Amt Claimed ",!,UL
33 W !,FBDRUG,?34,FBRX,?43,FBSTR,?54,FBQTY,?63,FBAC
34 I FBGENSUB]"" W !!,?4,"Generic Drug Issued: ",FBGENSUB,?30,"Generic Drug Name: ",$E(FBGEN,1,30)
35 W:FBAAPR]"" !!,?5,"Pharmacy Remarks: ",FBAAPR
36FEE 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)
37 W:FB1725 !?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
38 W !! S FBMDF=+Y K FBAP
39 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"
40 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"
41 ;S DR(1,162.11,2)="S:(FBAC-FBAP)'>0 Y=8;6///^S X=FBAC-FBAP;Q;6R;7R;S:X'=4 Y=8;20;8////^S X=3"
42 S DR(1,162.11,2)="S FBX=$$ADJ^FBUTL2(FBAC-FBAP,.FBADJ,2,,,1)"
43 S DR(1,162.11,3)="S FBX=$$RR^FBUTL4(.FBRRMK,2);8////^S X=3"
44 D ^DIE K DIE Q:$D(Y)'=0
45 S:$D(FBAP) FBINTOT=FBINTOT+FBAP
46 S $P(^FBAA(162.1,FBIN,0),"^",7)=FBINTOT
47 G:$D(DTOUT) H^XUS
48 ; file adjustments
49 D FILEADJ^FBRXFA(DA_","_FBIN_",",.FBADJ)
50 ; file remittance remarks
51 D FILERR^FBRXFR(DA_","_FBIN_",",.FBRRMK)
52 Q
Note: See TracBrowser for help on using the repository browser.