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