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