source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAACP.m@ 1704

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

initial load of WorldVistAEHR
File size: 5.3 KB
RevLine 
[613]1FBAACP ;AISC/CMR-C&P PAYMENT DRIVER ;7/13/2003
2 ;;3.5;FEE BASIS;**4,38,55,61,77**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 K FBAAOUT,FBPOP S FBCNP=1 ;C&P flag
5 D SITE^FBAACO G Q:$G(FBPOP) D BT^FBAACO G Q:$G(FBAAOUT)
61 K FBAR,FBAAOUT,FBDL,FBAAMM D GETVEN1^FBAACO1:$D(FB583),GETVEN^FBAACO1:'$D(FB583) G CLN:$G(FBAAOUT)
7 D GETINV^FBAACO1 G CLN:$G(FBAAOUT)
8 D GETINDT^FBAACO1 G CLN:$G(FBAAOUT)
9 D MMPPT^FBAACP G CLN:$G(FBAAOUT)
10SVDT W !! S %DT="AEXP",%DT("A")="Date of Service: " D ^%DT I X="^" G CLN
11 I Y<0!(Y>FBAAID) W *7,!!,"Enter the date the Vendor provided the service to the Patient.",!,"The date must be prior to the date the invoice is received.",! G SVDT
12 S FBAADT=Y D SETO^FBAACO3,CPTM^FBAALU(FBAADT) I 'FBGOT G CLN
13 ; prompt revenue code
14 S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 G CLN
15 ; prompt units paid
16 S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT=1 G CLN
17 D ASKZIP^FBAAFS($G(FBV),$G(FBAADT)) I $G(FBAAOUT)!($G(FBZIP)']"") G CLN
18 I $$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) D ASKTIME^FBAAFS I $G(FBAAOUT)!('$G(FBTIME)) G CLN
19 D HCFA G CLN:$G(FBAAOUT)
20 S FBAAAMT=0 D AMTPD I $G(FBAAOUT)!('$G(FBAAAMT)) G CLN
21 ; prompt for remittance remarks
22 I $$RR^FBUTL4(.FBRRMK,2)=0 S FBAAOUT=1 G CLN
23MULT ;begin unique patient entry
24 W:FBINTOT>0 !,"Invoice: "_FBAAIN_" Totals: $ "_FBINTOT
25 K FBAAOUT,FBDL S (DFN,FTP)="" D SITE^FBAACO G Q:$G(FBPOP) W !!
26 I '$D(FB583) K FBDL D GETVET^FBAAUTL1 G CLN:'DFN K FBDMRA D GETAUTH^FBAAUTL1 G MULT:FTP']""
27 K FBAAOUT D G Q:$G(FBAAOUT)
28 . N ICDVDT S ICDVDT=$G(FBAADT)
29 . F D Q:$G(FBAAOUT) Q:($$INPICD9^FBCSV1(+$G(Y),"",$G(FBAADT))=0)
30 . . S I=28,DIR(0)="PO^80:EMQZ",DIR("A")="PRIMARY DIAGNOSIS" D DIR
31 D PAT^FBAACO W !! D FILEV^FBAACO5(DFN,FBV) I $G(FBAAOUT) G Q:$D(FB583),CLN
32 ;check for payments against all linked vendors
33 S DA=+Y D CHK^FBAACO4 K FBAACK1,FBAAOUT,DA,X,Y
34 W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,0,FBAADT) I $G(FBAAOUT) D AUTHQ^FBAACO G MULT
35 D SETO^FBAACO3,CHK2^FBAACO4 I FBJ']"" G SVPR
36CHKE ;determines what action to take on duplicate services entered
37 K FBAAOUT W !!,*7,"Service selected for that date already in system."
38 S DIR(0)="Y",DIR("A")="Do you want to add another service for the SAME DATE",DIR("B")="No" D ^DIR K DIR G SVPR:Y I $D(DIRUT) D DEL^FBAACO3 G Q
39 W !!,*7,"You must use the 'EDIT PAYMENT' option to edit the service previously",!,"entered for that date." D DEL^FBAACO3
40 G MULT
41SVPR K FBAAOUT D SVCPR^FBAACO1 G CHKE:$G(FBAAOUT)
42 D FILE^FBAACP1 I Z1>(FBAAMPI-1) W !!,*7,"You have reached the maximum number of payments for a batch!",!,"You must select another Batch for entering Payments!" G CLN
43 G MULT
44Q ;kill variables and exit
45 D Q^FBAACO
46 Q
47AMTPD ;get amount paid
48 N FBX
49 S FBFY=FY-1
50 S (FBAMTPD,FBFSAMT,FBFSUSD)=""
51 S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBAADT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME))
52 ;
53 I '$G(FBAAMM1) D
54 . S FBFSAMT=$P(FBX,U),FBFSUSD=$P(FBX,U,2)
55 E D
56 . W !,?2,"Payment is for a contracted service so fee schedule does not apply."
57 ;
58 I $P($G(FBX),U)]"" D
59 . W !?2,$S($G(FBAAMM1):"However, f",1:"F")
60 . W "ee schedule amount is $",$P(FBX,U)," from the "
61 . W:$P(FBX,U,3)]"" $P(FBX,U,3)," " ; year if returned
62 . W:$P(FBX,U,2)]"" $$EXTERNAL^DILFD(162.03,45,"",$P(FBX,U,2))
63 E W !?2,"Unable to determine a FEE schedule amount."
64 ;
65 I $G(FBUNITS)>1 D
66 . W !!?2,"Units Paid = ",FBUNITS
67 . Q:FBFSAMT'>0
68 . N FBFSUNIT
69 . ; determine if fee schedule can be multipled by units
70 . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>3040930):1,1:0)
71 . I FBFSUNIT D
72 . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2)
73 . . W !?2," Therefore, fee schedule amount increased to $",FBFSAMT
74 . E D
75 . . W !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
76 ;
77 I '$G(FBAAMM1) S FBAMTPD=FBFSAMT
78 ;
79 I FBAMTPD=0 D Q:$G(FBAAOUT)
80 . ;if fee schedule = 0 write message and quit
81 . W !,"You must use the Enter Payment option for CPT codes that have a",!,"Fee Schedule set equal to zero."
82 . S FBAAOUT=1
83 W !
84 S DIR(0)="162.03,1",DIR("A")="Enter Amount Paid: $",DIR("?")="Enter a dollar amount that does not exceed the FEE Schedule" S:FBAMTPD'="" DIR("B")=FBAMTPD D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
85 I $G(FBAMTPD),+Y>FBAMTPD&('$D(^XUSEC("FBAASUPERVISOR",DUZ))) W !!,*7,"You must be a holder of the 'FBAASUPERVISOR' security key to",!,"exceed the FEE Schedule. Enter an '^' to quit or accept the default.",! G AMTPD
86 S FBAAAMT=+Y
87 Q
88HCFA ;get HCFA fields
89 F I=28,30,31 S FBHCFA(I)=""
90 W ! F I=30,31 S DIR(0)="P"_$S(I=30:"^353.1",I=31:"O^353.2")_":EMQZ" D DIR Q:$G(FBAAOUT)
91 K DIR Q
92DIR ;generic DIR call for HCFA
93 D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S FBAAOUT=1 Q
94 S:Y'=-1 FBHCFA(I)=$P(Y,"^")
95 Q
96CLN G Q:$D(FB583)
97 D Q G FBAACP
98 Q
99MMPPT ;money management/prompt pay type for multiple payment entry
100 ; input
101 ; FBAAPTC
102 ; output
103 ; FBAAMM
104 ; FBAAMM1
105 ; FBAAOUT
106 ;
107 S (FBAAMM,FBAAMM1)=""
108 I $G(FBAAPTC)'="R" D
109 . W !,"The answer to the following will apply to all payments entered via this option."
110 . S DIR(0)="Y"
111 . S DIR("A")="Are payments for contracted services"
112 . S DIR("B")="No"
113 . S DIR("?",1)="Answering no indicates interest will not be paid for any line items."
114 . S DIR("?",2)="Answering yes indicates interest will be paid."
115 . S DIR("?",3)="A fee schedule is not used for contracted services."
116 . S DIR("?")="Enter either 'Y' or 'N'."
117 . D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
118 . S (FBAAMM,FBAAMM1)=$S(Y:1,1:"")
119 Q
Note: See TracBrowser for help on using the repository browser.