Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBAACO0

FBAACO0.m

Go to the documentation of this file.
  1. FBAACO0 ;AISC/GRR - DISPLAY PATIENT ADDRESS DATA AND EDIT ;10/16/14 15:39
  1. ;;3.5;FEE BASIS;**4,38,52,57,61,75,70,143,154**;JAN 30, 1995;Build 12
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. S FBMST=$S(FBTT=1:"Y",1:""),FBTTYPE="A",FBFDC=""
  1. N FBEDPTAD S (FBEDPTAD(1),FBEDPTAD(2))=0
  1. W @IOF,"Patient: ",$P(^DPT(DFN,0),"^") S (Y(0),HY(0))=$G(^DPT(DFN,.11)) I Y(0)="" W !,*7,"No Address information for this patient!" G EDIT
  1. S VAPA("P")="" D ADD^VADPT
  1. S FBEDPTAD(1)=$$ISCCADR()
  1. S FBEDPTAD(2)="N"
  1. I $$CCADR(2)
  1. W !!,"Patient's Permanent address:"
  1. F Z=1:1:3 I VAPA(Z)]"" W !?2,"Address Line ",Z,":",?18,VAPA(Z)
  1. W !?2,"City:",?18,VAPA(4),!?2,"State:",?18,$P(VAPA(5),U,2)
  1. W !?2,"Zip:",?18,$S(+$G(VAPA(11)):$P(VAPA(11),U,2),1:VAPA(6)),!?2,"County",?18,$P(VAPA(7),U,2)
  1. K VAPA,VAERR
  1. RD W ! S DIR("A")="Want to edit Permanent Address data",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR S:Y&('$D(DIRUT)) FBEDPTAD(2)="Y" G EDIT
  1. Q
  1. EDIT I $G(FBEDPTAD(2))'="N" W !! S HY(0)=$G(^DPT(DFN,.11)) D EN^DGREGAED(DFN)
  1. I $$EDTCCADR()=0 I FBTT'=1 I FBEDPTAD(2)="N" Q
  1. MRA I FBTT=1!($G(^DPT(DFN,.11))'=$G(HY(0))) S FBD1=FTP D ENT^FBAAAUT K FBD1
  1. Q
  1. FEE ;calculates amount paid based on fee schedule
  1. N FB1725
  1. ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
  1. S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
  1. S FBFY=FY-1
  1. S (FBFSAMT,FBFSUSD)="",FBAMTPD=$S($G(FBAMTPD)>0:FBAMTPD,1:"")
  1. ; if amount not passed then use fee schedule
  1. I '$G(FBAMTPD) D
  1. . N FBX
  1. .; FB*3.5*143 Adding FB1725 as a parameter to prevent incorrect
  1. .; reductions in local fee schedule pricing.
  1. . S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBAADT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME),$G(FB1725))
  1. . ;
  1. . I '$G(FBAAMM1) D
  1. . . S FBFSAMT=$P(FBX,U),FBFSUSD=$P(FBX,U,2)
  1. . E W !?2,"Payment is for a contracted service so fee schedule does not apply."
  1. . ;
  1. . I $P($G(FBX),U)]"" D
  1. . . W !?2,$S($G(FBAAMM1):"However, f",1:"F")
  1. . . W "ee schedule amount is $",$P(FBX,U)," from the "
  1. . . W:$P(FBX,U,3)]"" $P(FBX,U,3)," " ; year if returned
  1. . . W:$P(FBX,U,2)]"" $$EXTERNAL^DILFD(162.03,45,"",$P(FBX,U,2))
  1. . E W !?2,"Unable to determine a FEE schedule amount."
  1. . ;
  1. . ; FB*3.5*143 - Preventing 70% reduction of 75th percentile rates
  1. . I FB1725,FBFSUSD'="F" D
  1. . . W !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
  1. . . I FBFSAMT D
  1. . . . S FBFSAMT=$J(FBFSAMT*.7,0,2)
  1. . . . W !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
  1. . ;
  1. . I $G(FBUNITS)>1 D
  1. . . W !!?2,"Units Paid = ",FBUNITS
  1. . . Q:FBFSAMT'>0
  1. . . N FBFSUNIT
  1. . . ; determine if fee schedule can be multiplied by units
  1. . . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>3040930):1,1:0)
  1. . . I FBFSUNIT D
  1. . . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2)
  1. . . . W !?2," Therefore, fee schedule amount increased to $",FBFSAMT
  1. . . E D
  1. . . . W !?2," Fee schedule not complied on per unit basis so amount not adjusted for units."
  1. . ;
  1. . I '$G(FBAAMM1) D
  1. . . ; set default amount paid to lesser of amt claimed (J) or fee sched.
  1. . . S FBAMTPD=$S(FBFSAMT>J:J,FBFSAMT>0:FBFSAMT,1:"")
  1. . ;
  1. . W !
  1. ;
  1. AMTPD W !,"AMOUNT PAID: "_$S(FBAMTPD]"":FBAMTPD_"//",1:"") R X:DTIME S:X="" X=FBAMTPD G KILL:$E(X)="^",HELPPD:$E(X,1,2)="??",HELP1:$E(X)="?" S X=$TR(X,"$") I +X'=X&(X'?.N.1".".2N)!(X>999999)!(X<0) G HELP1
  1. S FBAMTPD=X Q
  1. KILL W !!,*7,"Entering an '^' will delete this payment!" R !,?5,"Do you want to delete? No//",X:DTIME S:X="" X="N" D VALCK^FBAAUTL1 G KILL:'VAL,AMTPD:"Nn"[$E(X)
  1. S DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1," D WAIT^DICD,^DIK W !,?3,"<DELETED>" K DA,J,K,DIC,DIK,FBAACP,FBAADT,FBX S Y=0,FBDL=1 Q
  1. HELP1 W !!,"Enter the amount to pay in dollars and cents between 0 and 999999.",!,"Entering an '^' will delete the payment.",!
  1. G AMTPD
  1. HELPPD W !!,"The amount that the VA is going to pay for this service provided.",! G AMTPD
  1. Q
  1. ;print Confidential Communication address
  1. ;ADD^VADPT must be invoked before this call
  1. ;FBDFN -patient's DFN
  1. ;FBSTPOS - position to start print
  1. ;returns 0 if there is no active CC address
  1. ;returns 1 if active
  1. CCADR(FBSTPOS) ;
  1. N FBACT
  1. S FBACT=0
  1. I '$D(VAPA(12)) Q 0 ;if D ADD^VADPT was not invoked before
  1. I 'VAERR D
  1. . S FBACT=$$ACTIVECC()
  1. . Q:'FBACT
  1. . W !!,"Confidential Communication address until: "_$P($G(VAPA(21)),U,2)
  1. . I $G(VAPA(13))]"" W !?FBSTPOS,"Line 1: ",$G(VAPA(13))
  1. . I $G(VAPA(14))]"" W " Line 2: ",$G(VAPA(14))
  1. . I $G(VAPA(15))]"" W !?FBSTPOS,"Line 3: ",$G(VAPA(15))
  1. . W !?FBSTPOS,"City:",?9,$S($G(VAPA(16))]"":$G(VAPA(16)),1:" ")
  1. . W ?40,"State:",?47,$S($P($G(VAPA(17)),U,2)]"":$P($G(VAPA(17)),U,2),1:" ")
  1. . W !?FBSTPOS,"Zip:",?9,$P($G(VAPA(18)),U,2)
  1. . W ?20,"County:",?28,$P($G(VAPA(19)),U,2)
  1. Q $G(FBACT)
  1. ;
  1. ;is called after ADD^VADPT to verify whether confidential address is
  1. ;active or not to encapsulate the logic related to status of CC address
  1. ;input: VAPA
  1. ACTIVECC() ;
  1. Q (+$G(VAPA(12))=1)&($P($G(VAPA(22,3)),"^",3)="Y")
  1. ;
  1. ;edit confidential address
  1. ;returns 1 if CC address has been edited
  1. ;otherwise - 0
  1. EDTCCADR() ;
  1. Q:'$G(DFN) 0
  1. I FBEDPTAD(1)=0 D
  1. . N VAPA S VAPA("P")="" D ADD^VADPT S FBEDPTAD(1)=$$ISCCADR()
  1. I FBEDPTAD(1)'="N" D
  1. . W:FBEDPTAD(1)'="B" !!,"WARNING: The Confidential address is NOT active for the Billing Category."
  1. . S DIR("A")="Want to edit Confidential Address data"
  1. E S DIR("A")="Want to add Confidential Address data"
  1. W ! S DIR("B")="No",DIR(0)="Y"
  1. D ^DIR K DIR
  1. Q:($D(DIRUT)) 0
  1. ;Registration API
  1. I Y D QUES^DGRPU1(+DFN,"ADD4") Q 1
  1. Q 0
  1. ;
  1. ;returns "B" if patient has any (active or inactive) CC address and billing category
  1. ;returns "Y" if patient has any (active or inactive) CC address with another category
  1. ;otherwise returns "N"
  1. ISCCADR() ;
  1. Q:($P($G(VAPA(22,3)),"^",3)="Y") "B"
  1. Q:'$O(VAPA(22,0)) "N"
  1. Q "Y"
  1. ;
  1. ;FBAACO0