| [613] | 1 | FBAAMP ;AISC/CMR-MULTIPLE PAYMENT ENTRY ;9/29/2003
|
|---|
| 2 | ;;3.5;FEE BASIS;**4,21,38,55,61,67**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S FBMP=1 ;multiple payment flag
|
|---|
| 5 | G ^FBAACO
|
|---|
| 6 | 1 ;return from FBAACO
|
|---|
| 7 | D MMPPT^FBAACP G:$G(FBAAOUT) Q1
|
|---|
| 8 | D MPDT I 'FBMPDT G Q1
|
|---|
| 9 | K FBAAOUT W ! D CPTM^FBAALU(FBMPDT,DFN) I 'FBGOT G Q1
|
|---|
| 10 | ; prompt revenue code
|
|---|
| 11 | S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 G Q1
|
|---|
| 12 | ; prompt units paid
|
|---|
| 13 | S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT=1 G Q1
|
|---|
| 14 | S FY=$E(DT,1,3)+1700+$S($E(DT,4,5)>9:1,1:0)
|
|---|
| 15 | D ASKZIP^FBAAFS($G(FBV)) I $G(FBAAOUT)!($G(FBZIP)']"") G Q1
|
|---|
| 16 | I $$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) D ASKTIME^FBAAFS I $G(FBAAOUT)!('$G(FBTIME)) G Q1
|
|---|
| 17 | D HCFA^FBAAMP1 G Q1:$G(FBAAOUT)
|
|---|
| 18 | AMTCL S DIR(0)="162.03,1",DIR("A")="Amount Claimed: $",DIR("?")="Enter the amount being claimed by the vendor" D ^DIR K DIR G Q:$D(DIRUT) S FBJ=+Y
|
|---|
| 19 | W ! S DIR("A")="Is $"_FBJ_" correct for Amount Claimed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT),AMTCL:'Y
|
|---|
| 20 | RDAP D FEE G Q:$G(FBAAOUT) S FBK=FBAMTPD
|
|---|
| 21 | W ! S DIR("A")="Is $"_FBK_" correct for Amount Paid",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT),RDAP:'Y
|
|---|
| 22 | S FBAAAS=0 K FBADJ I FBJ-FBK D SUSP^FBAAMP1 I $G(FBAAOUT) G Q:$D(DUOUT),Q1
|
|---|
| 23 | S FBJ=+FBJ,FBK=+FBK,FBAAAS=+FBAAAS
|
|---|
| 24 | ; prompt for remittance remarks
|
|---|
| 25 | I $$RR^FBUTL4(.FBRRMK,2)=0 S FBAAOUT=1 G Q1
|
|---|
| 26 | MULT W:FBINTOT>0 !,"Invoice: "_FBAAIN_" Totals: $ "_FBINTOT
|
|---|
| 27 | W !! S %DT("A")="Date of Service: ",%DT="AEPX" D ^%DT G Q1:X=""!(X="^")
|
|---|
| 28 | D DATCK^FBAAUTL G MULT:'$D(X)!(Y<0)
|
|---|
| 29 | S FBDT=Y
|
|---|
| 30 | I '$$CHKCPT() W !,$C(7),"Invalid Date of Service." G MULT
|
|---|
| 31 | I $$CHKICD9^FBCSV1(+$G(FBHCFA(28)),$G(FBDT))="" G MULT
|
|---|
| 32 | I '$G(FBAAMM1),'$$CHKFS() W !,$C(7),"Invalid Date of Service." G MULT
|
|---|
| 33 | S DIR(0)="Y",DIR("A")="Is "_($$DATX^FBAAUTL(FBDT))_" correct",DIR("B")="Yes" D ^DIR K DIR G MULT:$D(DIRUT)!('Y)
|
|---|
| 34 | S FBAADT=FBDT
|
|---|
| 35 | S FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
|
|---|
| 36 | I $D(^FBAAC("AE",DFN,FBV,FBAADT,FBAACP_$S($G(FBMODL)]"":"-"_FBMODL,1:""))) S DIR(0)="Y",DIR("A")="Code already exists for that date! Want to add another service for the SAME DATE",DIR("B")="No" D ^DIR K DIR G MULT:$D(DIRUT)!('Y)
|
|---|
| 37 | I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5() I FBFPPSL=-1 G Q1
|
|---|
| 38 | W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,0,FBAADT) G Q:$G(FBAAOUT)
|
|---|
| 39 | D SETO^FBAACO3,SVCPR^FBAACO1 G Q:$G(FBAAOUT)
|
|---|
| 40 | FILE S TP="",DR="1///^S X=FBJ;Q;2///^S X=FBK;47///^S X=FBUNITS"
|
|---|
| 41 | I FBCSID]"" S DR=DR_";49///^S X=FBCSID"
|
|---|
| 42 | I FBFPPSC]"" S DR=DR_";50///^S X=FBFPPSC;51///^S X=FBFPPSL"
|
|---|
| 43 | I FBAARC]"" S DR=DR_";48////^S X=FBAARC"
|
|---|
| 44 | ;S DR=DR_$S(FBJ-FBK:";3///^S X=FBAAAS;3.5////^S X=DT;4////^S X=FBAASC;D DESC^FBAAMP1",1:"")
|
|---|
| 45 | S DR(1,162.03,1)="6////^S X=DUZ;7////^S X=FBAABE;8////^S X=BO;13///^S X=FBAAID;14///^S X=FBAAIN;15///^S X=FBPT;16////^S X=FBPOV;17///^S X=FBTT;18///^S X=FBAAPTC;23////^S X=2;26////^S X=FBPSA"
|
|---|
| 46 | S DR(1,162.03,2)="34///^S X=$G(FBAAMM1);28////^S X=FBHCFA(28);30////^S X=FBHCFA(30);31////^S X=FBHCFA(31);32////^S X=FBHCFA(32);33///^S X=FBAAVID;44///^S X=FBFSAMT;45////^S X=FBFSUSD"
|
|---|
| 47 | S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
|
|---|
| 48 | S DA=FBAACPI,DA(1)=FBSDI,DA(2)=FBV,DA(3)=DFN
|
|---|
| 49 | D LOCK^FBUCUTL(DIE,FBAACPI,1)
|
|---|
| 50 | D ^DIE
|
|---|
| 51 | D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
|
|---|
| 52 | D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
|
|---|
| 53 | L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
|
|---|
| 54 | S FBINTOT=FBINTOT+FBK
|
|---|
| 55 | W " ....OK, DONE...."
|
|---|
| 56 | I FBK>0 S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1
|
|---|
| 57 | W:Z1>(FBAAMPI-20) !,*7,"Warning, you can only enter ",(FBAAMPI-Z1)," more line items!" I Z1>(FBAAMPI-1) D S FBMAX=1 G Q1
|
|---|
| 58 | .W !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
|
|---|
| 59 | G MULT
|
|---|
| 60 | Q1 K FBADJ,FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTOUT,FBOUT,FBSI,FBMPDT G ^FBAACO:$D(FBMAX),1^FBAACO
|
|---|
| 61 | ;
|
|---|
| 62 | Q ;kill variables and exit
|
|---|
| 63 | D Q^FBAACO
|
|---|
| 64 | Q
|
|---|
| 65 | ;
|
|---|
| 66 | MPDT ;
|
|---|
| 67 | S FBMPDT=""
|
|---|
| 68 | S DIR(0)="D^::EX"
|
|---|
| 69 | S DIR("A")="Enter date to use for CPT/ICD checks and fee schedule calc"
|
|---|
| 70 | S DIR("B")="TODAY"
|
|---|
| 71 | S DIR("?",1)="Enter a date. This date will be used when checking for"
|
|---|
| 72 | S DIR("?",2)="an active CPT/Modifier/ICD code. Also, the fee schedule"
|
|---|
| 73 | S DIR("?",3)="amount will be computed based on this date."
|
|---|
| 74 | S DIR("?")="Enter '^' to exit."
|
|---|
| 75 | W !
|
|---|
| 76 | D ^DIR K DIR S:'$D(DIRUT) FBMPDT=Y
|
|---|
| 77 | Q
|
|---|
| 78 | ;
|
|---|
| 79 | FEE N FBX,FB1725
|
|---|
| 80 | ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
|
|---|
| 81 | S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
|
|---|
| 82 | S FBFY=FY-1
|
|---|
| 83 | S (FBFSAMT,FBFSUSD,FBAMFS)=""
|
|---|
| 84 | S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBMPDT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME))
|
|---|
| 85 | ;
|
|---|
| 86 | I '$G(FBAAMM1) D
|
|---|
| 87 | . S FBFSAMT=$P(FBX,U),FBFSUSD=$P(FBX,U,2)
|
|---|
| 88 | E D
|
|---|
| 89 | . W !,?2,"Payment is for a contracted service so fee schedule does not apply."
|
|---|
| 90 | ;
|
|---|
| 91 | I $P($G(FBX),U)]"" D
|
|---|
| 92 | . W !?2,$S($G(FBAAMM1):"However, f",1:"F")
|
|---|
| 93 | . W "ee schedule amount is $",$P(FBX,U)," from the "
|
|---|
| 94 | . W:$P(FBX,U,3)]"" $P(FBX,U,3)," " ; year if returned
|
|---|
| 95 | . W:$P(FBX,U,2)]"" $$EXTERNAL^DILFD(162.03,45,"",$P(FBX,U,2))
|
|---|
| 96 | E W !?2,"Unable to determine a FEE schedule amount."
|
|---|
| 97 | ;
|
|---|
| 98 | I FB1725 D
|
|---|
| 99 | . W !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
|
|---|
| 100 | . I FBFSAMT D
|
|---|
| 101 | . . S FBFSAMT=$J(FBFSAMT*.7,0,2)
|
|---|
| 102 | . . W !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
|
|---|
| 103 | ;
|
|---|
| 104 | I $G(FBUNITS)>1 D
|
|---|
| 105 | . W !!?2,"Units Paid = ",FBUNITS
|
|---|
| 106 | . Q:FBFSAMT'>0
|
|---|
| 107 | . N FBFSUNIT
|
|---|
| 108 | . ; determine if fee schedule can be multipled by units
|
|---|
| 109 | . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBMPDT>3040930):1,1:0)
|
|---|
| 110 | . I FBFSUNIT D
|
|---|
| 111 | . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2)
|
|---|
| 112 | . . W !?2," Therefore, fee schedule amount increased to $",FBFSAMT
|
|---|
| 113 | . E D
|
|---|
| 114 | . . W !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
|
|---|
| 115 | ;
|
|---|
| 116 | I '$G(FBAAMM1) D
|
|---|
| 117 | . ; set default amount paid to lesser of amt claimed (J) or fee sched.
|
|---|
| 118 | . S FBAMFS=$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT)
|
|---|
| 119 | ;
|
|---|
| 120 | W !
|
|---|
| 121 | ;
|
|---|
| 122 | AMTPD S DIR(0)="162.5,9",DIR("A")="Amount Paid: $",DIR("B")=$G(FBAMFS),DIR("?")="^D HELP1^FBAAMP" K:$G(FBAMFS)="" DIR("B") D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
|
|---|
| 123 | I +Y>FBJ W !!,*7,"Amount paid cannot be greater than the amount claimed." G AMTPD
|
|---|
| 124 | I FBAMFS]"" I +Y>FBAMFS&('$D(^XUSEC("FBAASUPERVISOR",DUZ))) W !!,*7,"You must be a holder of the 'FBAASUPERVISOR' key in order to",!,"exceed the Fee Schedule.",! G AMTPD
|
|---|
| 125 | S FBAMTPD=+Y K FBAMFS Q
|
|---|
| 126 | HELP1 W !!,"Enter a dollar amount that does not exceed the amount claimed.",!
|
|---|
| 127 | I FBAMFS>0 W "Only the holder of the 'FBAASUPERVISOR' key may exceed the",!,"Fee Schedule.",!
|
|---|
| 128 | Q
|
|---|
| 129 | ;
|
|---|
| 130 | CHKCPT() ; check if CPT/Modifer active on date of service
|
|---|
| 131 | N FBCPTX,FBI,FBMOD,FBMODX,FBRET
|
|---|
| 132 | S FBRET=1
|
|---|
| 133 | S FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDT,1)
|
|---|
| 134 | I '$P(FBCPTX,U,7) S FBRET=0 W !," CPT Code ",$P(FBCPTX,U,2)," inactive on date of service."
|
|---|
| 135 | I $O(FBMODA(0)) D
|
|---|
| 136 | . S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
|
|---|
| 137 | . . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDT,1)
|
|---|
| 138 | . . I '$P(FBMODX,U,7) S FBRET=0 W !," CPT Modifier ",$P(FBMODX,U,2)," inactive on date of service."
|
|---|
| 139 | Q FBRET
|
|---|
| 140 | ;
|
|---|
| 141 | CHKFS() ; check if fee schedule amount is different on date of service
|
|---|
| 142 | N FBX,FBRET,FB1725
|
|---|
| 143 | S FBRET=1 ; return value - true if date of service allowed
|
|---|
| 144 | ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
|
|---|
| 145 | S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
|
|---|
| 146 | S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBDT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME))
|
|---|
| 147 | ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
|
|---|
| 148 | S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
|
|---|
| 149 | ; adjust amount if mill bill
|
|---|
| 150 | I FB1725 S $P(FBX,U)=$J($P(FBX,U)*.7,0,2)
|
|---|
| 151 | ; adjust amount if units > 1
|
|---|
| 152 | I $G(FBUNITS) D
|
|---|
| 153 | . N FBFSUNIT
|
|---|
| 154 | . ; determine if fee schedule can be multipled by units
|
|---|
| 155 | . S FBFSUNIT=$S($P(FBX,U,2)="R":1,$P(FBX,U,2)="F"&(FBDT>3040930):1,1:0)
|
|---|
| 156 | . I FBFSUNIT S $P(FBX,U)=$J($P(FBX,U)*FBUNITS,0,2)
|
|---|
| 157 | ; issue warning if lesser of claim and fee schedule amount different
|
|---|
| 158 | I +$S($P(FBX,U)>$G(FBJ):$G(FBJ),1:$P(FBX,U))'=+$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT) D
|
|---|
| 159 | . W !," Warning: The fee schedule amount (",$P(FBX,U),") for this date of service "
|
|---|
| 160 | . W !," differs from the initial fee schedule amount (",FBFSAMT,")."
|
|---|
| 161 | . I $P(FBX,U)>0,FBK>$P(FBX,U) D
|
|---|
| 162 | . . W !," Amount paid (",FBK,") exceeds the fee schedule amount."
|
|---|
| 163 | . . I '$D(^XUSEC("FBAASUPERVISOR",DUZ)) D
|
|---|
| 164 | . . . W !," You must be a holder of the 'FBAASUPERVISOR' key in order"
|
|---|
| 165 | . . . W !," to exceed the Fee Schedule."
|
|---|
| 166 | . . . S FBRET=0
|
|---|
| 167 | . W:FBRET !," You may want to separately process this date of service."
|
|---|
| 168 | Q FBRET
|
|---|
| 169 | ;
|
|---|
| 170 | ANCIL ;ENTRY POINT FOR mutiple ancillary payment option
|
|---|
| 171 | S FBCHCO=1 D ^FBAAMP
|
|---|
| 172 | K FBCHCO Q
|
|---|
