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

FBAAMP.m

Go to the documentation of this file.
  1. FBAAMP ;AISC/CMR - MULTIPLE PAYMENT ENTRY ;10/23/14 12:47
  1. ;;3.5;FEE BASIS;**4,21,38,55,61,67,116,108,143,123,154,158**;JAN 30, 1995;Build 94
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. S FBMP=1 ;multiple payment flag
  1. G ^FBAACO
  1. 1 ;return from FBAACO
  1. D MMPPT^FBAACO G:$G(FBAAOUT) Q1
  1. D MPDT I 'FBMPDT G Q1
  1. K FBAAOUT W ! D CPTM^FBAALU(FBMPDT,DFN) I 'FBGOT G Q1
  1. ; prompt revenue code
  1. S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 G Q1
  1. ; prompt units paid
  1. S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT=1 G Q1
  1. S FY=$E(DT,1,3)+1700+$S($E(DT,4,5)>9:1,1:0)
  1. D ASKZIP^FBAAFS($G(FBV)) I $G(FBAAOUT)!($G(FBZIP)']"") G Q1
  1. I $$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) D ASKTIME^FBAAFS I $G(FBAAOUT)!('$G(FBTIME)) G Q1
  1. D HCFA^FBAAMP1 G Q1:$G(FBAAOUT)
  1. 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
  1. 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
  1. RDAP D FEE G Q:$G(FBAAOUT) S FBK=FBAMTPD 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
  1. S FBAAAS=0 K FBADJ I FBJ-FBK D SUSP^FBAAMP1 I $G(FBAAOUT) G Q:$D(DUOUT),Q1
  1. S FBJ=+FBJ,FBK=+FBK,FBAAAS=+FBAAAS
  1. MULT W:FBINTOT>0 !,"Invoice: "_FBAAIN_" Totals: $ "_FBINTOT
  1. W !! S %DT("A")="Date of Service: ",%DT="AEPX" D ^%DT G Q1:X=""!(X="^")
  1. D DATCK^FBAAUTL G MULT:'$D(X)!(Y<0)
  1. S FBDT=Y
  1. I '$$CHKCPT() W !,$C(7),"Invalid Date of Service." G MULT
  1. I $$CHKICD9^FBCSV1(+$G(FBHCFA(28)),$G(FBDT))="" G MULT
  1. I '$G(FBAAMM1),'$$CHKFS() W !,$C(7),"Invalid Date of Service." G MULT
  1. S DIR(0)="Y",DIR("A")="Is "_($$DATX^FBAAUTL(FBDT))_" correct",DIR("B")="Yes" D ^DIR K DIR G MULT:$D(DIRUT)!('Y)
  1. S FBAADT=FBDT
  1. S FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
  1. 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)
  1. I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5() I FBFPPSL=-1 G Q1
  1. W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,0,FBAADT) G Q:$G(FBAAOUT)
  1. D SETO^FBAACO3,SVCPR^FBAACO1 G Q:$G(FBAAOUT)
  1. FILE S TP="",DR="1///^S X=FBJ;Q;2///^S X=FBK;47///^S X=FBUNITS"
  1. I FBCSID]"" S DR=DR_";49///^S X=FBCSID"
  1. I FBFPPSC]"" S DR=DR_";50///^S X=FBFPPSC;51///^S X=FBFPPSL"
  1. I FBAARC]"" S DR=DR_";48////^S X=FBAARC"
  1. 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=FBTYPE;26////^S X=FBPSA"
  1. S DR(1,162.03,2)="34///^S X=$G(FBAAMM1);54////^S X=$G(FBCNTRP);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"
  1. S DR(1,162.03,3)=".05////^S X=$G(FBIA);.055///^S X=$G(FBDODINV)" ; FB*3.5*123
  1. S DR(1,162.03,4)="82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)" ;FB*3.5*158
  1. S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
  1. S DA=FBAACPI,DA(1)=FBSDI,DA(2)=FBV,DA(3)=DFN
  1. D LOCK^FBUCUTL(DIE,FBAACPI,1)
  1. D ^DIE
  1. D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
  1. D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
  1. L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
  1. S FBINTOT=FBINTOT+FBK
  1. W " ....OK, DONE...."
  1. ; HIPAA 5010 - count line items that have 0.00 amount paid
  1. S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1
  1. 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
  1. .W !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
  1. G MULT
  1. Q1 K FBADJ,FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTOUT,FBOUT,FBSI,FBMPDT,FBIA,FBDODINV G ^FBAACO:$D(FBMAX),1^FBAACO
  1. ;
  1. Q ;kill variables and exit
  1. D Q^FBAACO
  1. Q
  1. ;
  1. MPDT ;
  1. S FBMPDT=""
  1. S DIR(0)="D^::EX"
  1. S DIR("A")="Enter date to use for CPT/ICD checks and fee schedule calc"
  1. S DIR("B")="TODAY"
  1. S DIR("?",1)="Enter a date. This date will be used when checking for"
  1. S DIR("?",2)="an active CPT/Modifier/ICD code. Also, the fee schedule"
  1. S DIR("?",3)="amount will be computed based on this date."
  1. S DIR("?")="Enter '^' to exit."
  1. W !
  1. D ^DIR K DIR S:'$D(DIRUT) FBMPDT=Y
  1. Q
  1. ;
  1. FEE N FBX,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,FBAMFS)=""
  1. ; FB*3.5*143 Adding FB1725 as a parameter to prevent reduction
  1. ; of local fee schedule payments
  1. S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBMPDT,$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 D
  1. . 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"&(FBMPDT>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 by units."
  1. ;
  1. I '$G(FBAAMM1) D
  1. . ; set default amount paid to lesser of amt claimed (J) or fee sched.
  1. . S FBAMFS=$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT)
  1. ;
  1. W !
  1. ;
  1. AMTPD K DIR S DIR(0)="162.03,2",DIR("A")="AMOUNT PAID" S:$G(FBAMFS)'="" DIR("B")=FBAMFS D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
  1. S FBAMTPD=+Y K FBAMFS Q
  1. ;
  1. CHKCPT() ; check if CPT/Modifier active on date of service
  1. N FBCPTX,FBI,FBMOD,FBMODX,FBRET
  1. S FBRET=1
  1. S FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDT,1)
  1. I '$P(FBCPTX,U,7) S FBRET=0 W !," CPT Code ",$P(FBCPTX,U,2)," inactive on date of service."
  1. I $O(FBMODA(0)) D
  1. . S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
  1. . . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDT,1)
  1. . . I '$P(FBMODX,U,7) S FBRET=0 W !," CPT Modifier ",$P(FBMODX,U,2)," inactive on date of service."
  1. Q FBRET
  1. ;
  1. CHKFS() ; check if fee schedule amount is different on date of service
  1. N FBX,FBRET,FB1725
  1. S FBRET=1 ; return value - true if date of service allowed
  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 FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBDT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME),$G(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. ; adjust amount if mill bill
  1. I FB1725 S $P(FBX,U)=$J($P(FBX,U)*.7,0,2)
  1. ; adjust amount if units > 1
  1. I $G(FBUNITS) D
  1. . N FBFSUNIT
  1. . ; determine if fee schedule can be multiplied by units
  1. . S FBFSUNIT=$S($P(FBX,U,2)="R":1,$P(FBX,U,2)="F"&(FBDT>3040930):1,1:0)
  1. . I FBFSUNIT S $P(FBX,U)=$J($P(FBX,U)*FBUNITS,0,2)
  1. ; issue warning if lesser of claim and fee schedule amount different
  1. I +$S($P(FBX,U)>$G(FBJ):$G(FBJ),1:$P(FBX,U))'=+$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT) D
  1. . W !," Warning: The fee schedule amount (",$P(FBX,U),") for this date of service "
  1. . W !," differs from the initial fee schedule amount (",FBFSAMT,")."
  1. . I $P(FBX,U)>0,FBK>$P(FBX,U) D
  1. . . W !," Amount paid (",FBK,") exceeds the fee schedule amount."
  1. . W:FBRET !," You may want to separately process this date of service."
  1. Q FBRET
  1. ;
  1. IPACID(FBVEN,FBIPIEN) ; function to return IPAC agreement ID# if exactly 1 active IPAC on file for vendor (FB*3.5*123)
  1. ; No user interface allowed with this function. Called by background, Austin transmission process.
  1. ;
  1. ; Input:
  1. ; FBVEN - Vendor ien (ptr to file 161.2)
  1. ;
  1. ; Output:
  1. ; Function value = if exactly 1 active IPAC agreement is on file, then this returns the external agreement ID#
  1. ; otherwise, this returns ""
  1. ; FBIPIEN (pass by reference) - internal entry ien of the active IPAC agreement on file
  1. ;
  1. N X1,X2,RET
  1. S RET="" ; default value
  1. S FBIPIEN="" ; initialize
  1. S FBVEN=+$G(FBVEN)
  1. I '$$IPACREQD(FBVEN) G IPACIDX ; IPAC not required
  1. S X1=+$O(^FBAA(161.95,"AVA",FBVEN,"A","")) ; first active IPAC entry
  1. I 'X1 G IPACIDX ; no IPAC data found for vendor so get out
  1. S X2=+$O(^FBAA(161.95,"AVA",FBVEN,"A",""),-1) ; last active IPAC entry
  1. ;
  1. ; only 1 IPAC on file - retrieve the ID# in this case only
  1. I X1=X2 S RET=$P($G(^FBAA(161.95,X1,0)),U,1),FBIPIEN=X1 ; IPAC external agreement ID#
  1. ;
  1. IPACIDX ;
  1. Q RET
  1. ;
  1. IPAC(FBVEN) ; Determine if active IPAC agreement data exists for vendor (FB*3.5*123)
  1. ; Input:
  1. ; FBVEN - Vendor ien (ptr to file 161.2)
  1. ;
  1. ; Output:
  1. ; Function value = -1 if active IPAC records exist, but none were selected (this is an error condition)
  1. ; = ien of IPAC entry in file 161.95 (if only 1 exists, or user selected it)
  1. ; = "" if no IPAC data found or if IPAC not required
  1. ;
  1. N FBIA,X1,X2,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. S FBIA=""
  1. S FBVEN=+$G(FBVEN)
  1. I '$$IPACREQD(FBVEN) G IPACX ; IPAC not required
  1. S X1=+$O(^FBAA(161.95,"AVA",FBVEN,"A","")) ; first active IPAC entry
  1. I 'X1 G IPACX ; no IPAC data found for vendor, get out with FBIA=""
  1. W !!,"This is a Federal Vendor. IPAC payment information is required."
  1. S X2=+$O(^FBAA(161.95,"AVA",FBVEN,"A",""),-1) ; last active IPAC entry
  1. ;
  1. ; only 1 IPAC on file - select it automatically
  1. I X1=X2 S FBIA=X1 D
  1. . W !," - Required IPAC agreement information has been found."
  1. . Q
  1. ;
  1. I X1'=X2 S FBIA=$$MULTIPAC(FBVEN) ; multiple IPAC selection for vendor
  1. I FBIA'>0 G IPACX ; get out if user failed to select one
  1. ;
  1. S DIR(0)="Y",DIR("A")="Would you like to display the detailed IPAC agreement information"
  1. S DIR("B")="No"
  1. W ! D ^DIR K DIR
  1. I $D(DIRUT) W " Not displaying detail ... "
  1. I 'Y G IPACX ; exit without displaying the data by user choice
  1. ;
  1. ; Display the IPAC data
  1. W !
  1. D VADISP^FBAAIAU(FBIA,1)
  1. S DIR(0)="E" D ^DIR K DIR ; press return to continue
  1. IPACX ;
  1. Q FBIA
  1. ;
  1. MULTIPAC(FBVEN) ; multiple IPAC agreement display, lister, selection
  1. ; same input and output parameters as IPAC above
  1. ;
  1. N FBIA,Z,CNT,FBLN,FBG,ID,FY,DESC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,LN,T,W
  1. S FBVEN=+$G(FBVEN)
  1. S FBIA=""
  1. S Z=0,CNT=0 K FBLN
  1. F S Z=$O(^FBAA(161.95,"AVA",FBVEN,"A",Z)) Q:'Z D
  1. . S FBG=$G(^FBAA(161.95,Z,0)) I FBG="" Q
  1. . S ID=$P(FBG,U,1)
  1. . S FY=$P(FBG,U,3)
  1. . S DESC=$P(FBG,U,5)
  1. . S CNT=CNT+1,FBLN(CNT)=Z_U_ID_U_FY_U_DESC
  1. . Q
  1. ;
  1. I 'CNT G MULIPACX ; get out if nothing found (should not happen)
  1. I CNT=1 S FBIA=$P(FBLN(1),U,1) G MULIPACX ; only 1 found (also should not happen)
  1. ;
  1. ; Multiple found. Build list.
  1. S DIR(0)="N"_U_"1:"_CNT,LN=0
  1. S LN=LN+1,DIR("A",LN)=$$GET1^DIQ(161.2,FBVEN_",",.01)_" is a Federal Vendor with"
  1. S LN=LN+1,DIR("A",LN)=CNT_" active IPAC agreements on file:"
  1. S LN=LN+1,DIR("A",LN)=" "
  1. S LN=LN+1,DIR("A",LN)="# ID FY Description"
  1. S LN=LN+1,DIR("A",LN)="-- ---------- ---- -----------"
  1. S T=0 F S T=$O(FBLN(T)) Q:'T S W=FBLN(T) D
  1. . S LN=LN+1,DIR("A",LN)=$$LJ^XLFSTR(T,3)_$$LJ^XLFSTR($P(W,U,2),12)_$$LJ^XLFSTR($P(W,U,3),6)_$E($P(W,U,4),1,58)
  1. . Q
  1. S LN=LN+1,DIR("A",LN)=" "
  1. S LN=LN+1,DIR("A",LN)="Please select the IPAC agreement to be used with this invoice."
  1. S LN=LN+1,DIR("A",LN)="This information is required."
  1. S DIR("A")="Selection#"
  1. W ! D ^DIR K DIR
  1. I Y>0 S FBIA=$P($G(FBLN(Y)),U,1) G MULIPACX ; user selection is good so set FBIA and get out
  1. ;
  1. ; in all other cases, user failed to make a selection so set FBIA=-1
  1. S FBIA=-1
  1. W !!,$C(7),"IPAC Agreement Selection is required for this vendor."
  1. ;
  1. MULIPACX ;
  1. Q FBIA
  1. ;
  1. IPACINV(FBDODINV,FBDEF) ; function to get the DoD invoice number for IPAC (FB*3.5*123)
  1. ; Function value is 1 if the DoD invoice number was obtained.
  1. ; Function value is 0 if not.
  1. ; FBDODINV - pass by reference. This is set to the DoD invoice number.
  1. ; FBDEF is an optional default value
  1. ;
  1. N RET,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1. S FBDODINV="",RET=0 ; initialize
  1. S DIR(0)="Fr^3:22",DIR("A")="Enter the DoD Invoice Number"
  1. I $G(FBDEF)'="" S DIR("B")=FBDEF
  1. S DIR("?",1)="If invoice is a UB-04 look in block 3a."
  1. S DIR("?",2)="If invoice is a CMS-1500 look in block 26."
  1. S DIR("?")="You must enter between 3-22 characters."
  1. W ! D ^DIR K DIR
  1. I $D(DIRUT),$G(FBDEF)'="" S Y=FBDEF K DIRUT
  1. I '$D(DIRUT),Y'="" S FBDODINV=Y,RET=1 G IPINVX
  1. W !!,$C(7),"The DoD Invoice Number is required for IPAC processing."
  1. IPINVX ;
  1. W !
  1. Q RET
  1. ;
  1. IPACREQD(FBVEN) ; Is IPAC data required for vendor? (FB*3.5*123)
  1. I $G(FBAAPTC)="R" Q 0 ; IPAC is not applicable for Patient/Veteran reimbursements
  1. I +$O(^FBAA(161.95,"AVA",+$G(FBVEN),"A","")) Q 1
  1. Q 0
  1. ;
  1. IPACDISP(FBIA,FBDODINV) ; Quick display of IPAC data currently on file for this invoice (FB*3.5*123)
  1. N G
  1. S FBIA=+$G(FBIA)
  1. S G=$G(^FBAA(161.95,FBIA,0))
  1. I G="",$G(FBDODINV)="" G IDISPX
  1. W !!,"IPAC Agreement Information on file for this Invoice/Payment"
  1. W !,"-----------------------------------------------------------"
  1. W !,"IPAC Agreement ID: ",$P(G,U,1)," (",$$GET1^DIQ(161.95,FBIA,3),")"
  1. W !?11,"Vendor: ",$$GET1^DIQ(161.95,FBIA,1)
  1. W !?6,"Fiscal Year: ",$P(G,U,3)
  1. W !,"Short Description: ",$P(G,U,5)
  1. W !?5,"DoD Invoice#: ",$G(FBDODINV)
  1. IDISPX ;
  1. Q
  1. ;
  1. ANCIL ;ENTRY POINT FOR multiple ancillary payment option
  1. S FBCHCO=1 D ^FBAAMP
  1. K FBCHCO Q