FBAACO ;AISC/GRR - ENTER MEDICAL PAYMENT ;9/25/2014
;;3.5;FEE BASIS;**4,61,79,116,122,133,108,135,123,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
EN583 ;driver for opt payments (entry point for uc)
K FBAAOUT,FBPOP
D SITE G Q:$G(FBPOP) D BT G Q:$G(FBAAOUT)
1 K FBAAID,FBAAVID,FBAAOUT,FBDL,FBAAMM D SITE G Q:$G(FBPOP) S FBINTOT=0 W !!
I '$D(FB583) K FBDL,FBAR D GETVET^FBAAUTL1 G EN583:'DFN K FBAAOUT,FBDMRA D GETAUTH^FBAAUTL1 G 1:FTP']""
I '$$UOKPAY^FBUTL9(DFN,FTP) D G 1
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
K FBAAOUT
I $G(FBCHCO) S FB7078=$S($G(FB7078):FB7078_";FB7078(",$D(FB583):FB583_";FB583(",1:"")
D:FBAAPTC="R" ^FBAACO0
D PAT,GETVEN1^FBAACO1:$D(FB583),GETVEN^FBAACO1:'$D(FB583) I $G(FBAAOUT) G Q:$D(FB583),1
W !! D FILEV^FBAACO5(DFN,FBV) I $G(FBAAOUT) G Q:$D(FB583),1
;check for payments against all linked vendors
S DA=+Y D CHK^FBAACO4 K FBAACK1,FBAAOUT,DA,X,Y
K FBAAID,FBAAVID D GETINV^FBAACO1 I $G(FBAAOUT) Q:$D(FBCHCO) G Q:$D(FB583),1
I '$D(FBAAID)!('$D(FBAAVID)) D GETINDT^FBAACO1 I $G(FBAAOUT) D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q
;
; FB*3.5*123 - check for IPAC agreement for Federal vendor and capture DoD invoice number (both req'd if IPAC)
S FBDODINV=""
S FBIA=$$IPAC^FBAAMP(FBV) I FBIA=-1 S FBAAOUT=1 D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q
I FBIA,'$$IPACINV^FBAAMP(.FBDODINV) S FBAAOUT=1 D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q
;
; ask patient account number
S FBCSID=$$ASKPAN^FBUTL5() I FBCSID="^" K FBCSID S FBAAOUT=1 D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q
; if U/C then get FPPS Claim ID else ask user
I $D(FB583) S FBFPPSC=$P($G(^FB583(FB583,5)),U) W !,"FPPS CLAIM ID: ",$S(FBFPPSC="":"N/A",1:FBFPPSC)
E S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 K FBFPPSC S FBAAOUT=1 D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q
;
S FBUCI135=$$ENTROUTP^FBUTL136(DFN,FBV,FBAAVID,FBFPPSC) ; Enter UCID FB3.5*135
I FBUCI135<1 K FBFPPSC S FBAAOUT=1 D OUT G Q:$D(FB583),1:'$D(FBCHCO) Q ; Enter UCID FB3.5*135
;
G 1^FBAAMP:$G(FBMP) D MM G Q:$G(FBAAOUT)
SVDT K FBAAOUT,HOLDY W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,1) I $G(FBAAOUT) K FBAADT,FBX,FBAACP W:FBINTOT>0 !!,"Invoice: "_FBAAIN_" Totals $ "_$J(FBINTOT,1,2) G Q:$D(FB583)!($G(FBCHCO)),1
D SETO^FBAACO3,DISPINV^FBAACO1
W ! D ASKZIP^FBAAFS($G(FBV),$G(FBAADT))
I $G(FBAAOUT)!(FBZIP']"") D DEL^FBAACO3 G SVDT
CPT K FBAAOUT W !
D CPTM^FBAALU($G(FBAADT),$G(DFN)) I 'FBGOT D DEL^FBAACO3 G SVDT
D CHK2^FBAACO4 I FBJ']"" G SVPR
CHKE ;determines what action to take on duplicate services entered
K FBAAOUT W !!,*7,"Service selected for that date already in system."
S DIR(0)="Y",DIR("A")="Do you want to add another service for the SAME DATE",DIR("B")="No" D ^DIR K DIR G Q:$D(DIRUT),SVPR:Y
I FBJ]"",FBJ'=FBV W !!,*7,"You must use the 'EDIT PAYMENT' option to edit the service previously",!,"entered for that date." D DEL^FBAACO3 G SVDT
S DIR(0)="Y",DIR("A")="Want to edit it",DIR("B")="No" D ^DIR K DIR G Q:$D(DIRUT) I Y D DOEDIT^FBAACO3 G SVDT:'$D(FBDL)!($G(FBAAOUT)),Q:$D(FB583),1
D ^FBAACO2 G CPT:'$G(FBDEN)
SVPR K FBAAOUT
I $$ANES^FBAAFS($$CPT^FBAAUTL4($G(FBAACP))) D ASKTIME^FBAAFS I $G(FBAAOUT)!'$G(FBTIME) G CPT
D SVCPR^FBAACO1 G CPT:$G(FBAAOUT)
S FBAMTPD=0 D FILE^FBAACO2 I $D(FBAAOUT) G Q:$D(FB583),1:$D(FBDL),Q ;FB*3.5*133 removed provider field save
D OUT^FBAACO3 W:Z1>(FBAAMPI-20) !,*7,"Warning, you can only enter ",(FBAAMPI-Z1)," more line(s)!" G CPT:Z1'>(FBAAMPI-1) D WARN^FBAACO3 G EN583
G 1
;
Q ;exit point for outpatient payment routines
K FBAAPTC,DIC,Y,A,I,DFN,BO,DA,DI,DQ,DR,E,FBAABDT,FBAABE,FBFY,FBDL,FBAAID,FBAAIN,FBAAMPI,FBAAOPA,FBAAPN,FBCONT,FBDX,FBGOT,FBPOV,FBPT,DLAYGO,FBPSA,FBASSOC,FBZBN,FBZBS,FBDEN,FBV,FBSDI,FBAACPI,FBAACP,FBX,FBLOCK
K FBSP,FBTPD,FBTT,FBTYPE,FTP,FBDEL,FY,FBINTOT,G,H,MAJN,NO,PI,Q,R,SUB,SUBN,TA,TP,UL,W,X1,Z,Z1,ZZ,FBAADT,K,L,J,FBTOV,FBPARCD,FBT,FEEO,Z2,FBSITE,FBAUT,T,FBLOC,FBSSN,FBVEN,FBD1,Z0,FB583
K A1,A2,B1,B2,DAT,DIE,FBAACPT,FBAMTPD,FBAAEDT,FBAAOUT,FBAAPD,FBI,FBIN,FBPROG,FBRR,FBXX,PTYPE,S,VAL,X,V,ZS,FB7078,FBFDC,FBCOUNTY,FBMST,FBTTYPE,FBTV,HY,FBDMRA,DIRUT,FBPOP,FBJ,FBAACK1,FBAR,FBDA,FBST
K FBMP,FBK,FBAAAS,%DT,FBDT,FBMAX,FBAMFS,FBAASC,FBHCFA,FBSI,FBCNP,FBAAAMT,FBAAVID,FBAAMM,FBAAMM1,VAPA,FBZX,FBTST,HOLDY,FBAOT
K FBCSID,FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBADJL,FBRRMK,FBRRMKD,FBRRMKL,FBUNITS,FBCNTRP,FBUCI135,FBIA,FBDODINV
AUTHQ K DIC,DFN,CNT,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBAUT,FBPOV,FBPROG,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FBTP,PI,TA,FBMOD,FBMODA,FBZIP,FBTIME,FBFSAMT,FBFSUSD
D GETAUTHK^FBAAUTL1
Q
;
SITE ;set up site variables
D:'$D(FBSITE(0)) SITEP^FBAAUTL Q:$G(FBPOP) I '$G(FBPROG) D
.I $G(FBCHCO) S FBPROG="I ($P(^(0),""^"",3)=6!($P(^(0),""^"",3)=7))&($P(^(0),U,9)'[""FB583"")" Q
.S FBPROG=$S($P(FBSITE(1),"^",6)="":"I $P(^(0),""^"",9)'[""FB583""",1:"I $P(^(0),""^"",3)=2,($P(^(0),""^"",9)'[""FB583"")")
S:'$D(FBAAPTC) FBAAPTC="V"
S FBAAMPI=$P($G(^FBAA(161.4,1,"FBNUM")),"^",3),FBAAMPI=$S(FBAAMPI]"":FBAAMPI,1:100)
Q
;
BT ;select batch
S DIC="^FBAA(161.7,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=""B3""&($G(^(""ST""))=""O"")&(($P(^(0),U,5)=DUZ)!($D(^XUSEC(""FBAA LEVEL 2"",DUZ))))",DIC("W")="W !,"" Obligation #: "",$P(^(0),U,2)" W !! D ^DIC K DIC I X["^"!(X="") S FBAAOUT=1 Q
G BT:Y<0 S (DA,FBAABE)=+Y,Y(0)=^FBAA(161.7,DA,0)
I $P(Y(0),"^",11)>(FBAAMPI-1) W !!,"This Batch already has the maximum number of Payments!" G BT
S Z1=$P(Y(0),"^",11),FB7078="",BO=$P(^FBAA(161.7,DA,0),"^",2)
Q
PAT ;set up patient in patient file
;required input variable DFN
I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DLAYGO,DIC,DINUM,DD,DO,DA
Q
MM ;check for money management of entire invoice
; fb*3.5*116
D MMPPT
Q
OUT K FBAADT,FBX,FBAACP W:FBINTOT>0 !!,"Invoice: "_FBAAIN_" Totals $ "_$J(FBINTOT,1,2) Q
;
MMPPT ;money management/prompt pay type for multiple payment entry
; input
; FBAAPTC = payment type code, "R" when patient reimbursement
; FBV = vendor being paid (ien)
; when called from FBAAMP additional variables will be available
; FBCNTRA = contract ien from authorization
; FBVEN = vendor from authorization
; FB583 = defined when unauthorized claim
; output
; FBAAMM = prompt payment, =1 to ask
; FBAAMM1 = prompt payment type for line
; FBAAOUT = (optional), = 1 to quit
; FBCNTRP = contract for line item (ien)
;
S (FBAAMM,FBAAMM1,FBCNTRP)=""
I $G(FBAAPTC)'="R",'$D(FB583) D
. ;
. ; check if contract required by authorization
. I '$D(FB583),$$UCFA^FBUTL7($G(FBV),$G(FBVEN),$G(FBCNTRA)) D Q
. . W !,"All lines items on this invoice will be considered as contracted services"
. . W !,"under Contract ",$P($G(^FBAA(161.43,FBCNTRA,0)),U)," from the authorization."
. . S (FBAAMM,FBAAMM1)=1
. . S FBCNTRP=FBCNTRA
. ;
. ; when not forced by authorization ask if contracted service
. W !,"The answer to the following will apply to all payments entered via this option."
. S DIR(0)="Y"
. S DIR("A")="Are payments for contracted services"
. S DIR("B")="No"
. S DIR("?",1)="Answering no indicates interest will not be paid for any line items."
. S DIR("?",2)="Answering yes indicates interest will be paid."
. S DIR("?",3)="A fee schedule is not used for contracted services."
. S DIR("?")="Enter either 'Y' or 'N'."
. D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
. S (FBAAMM,FBAAMM1)=$S(Y:1,1:"")
. Q:FBAAMM1=""
. ;
. ; if contracted service, ask contract
. S DIR(0)="PO^161.43:AQEM"
. S DIR("A")="CONTRACT"
. S DIR("?",1)="If the line item is under a contract then select it."
. S DIR("?")="Contract must be active and applicable for the vendor."
. S DIR("S")="I $P($G(^(0)),""^"",2)'=""I"",$$VCNTR^FBUTL7($G(FBV),+Y)"
. D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S FBAAOUT=1 Q
. S:Y>0 FBCNTRP=+Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACO 7959 printed Dec 13, 2024@01:55:07 Page 2
FBAACO ;AISC/GRR - ENTER MEDICAL PAYMENT ;9/25/2014
+1 ;;3.5;FEE BASIS;**4,61,79,116,122,133,108,135,123,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
EN583 ;driver for opt payments (entry point for uc)
+1 KILL FBAAOUT,FBPOP
+2 DO SITE
if $GET(FBPOP)
GOTO Q
DO BT
if $GET(FBAAOUT)
GOTO Q
1 KILL FBAAID,FBAAVID,FBAAOUT,FBDL,FBAAMM
DO SITE
if $GET(FBPOP)
GOTO Q
SET FBINTOT=0
WRITE !!
+1 IF '$DATA(FB583)
KILL FBDL,FBAR
DO GETVET^FBAAUTL1
if 'DFN
GOTO EN583
KILL FBAAOUT,FBDMRA
DO GETAUTH^FBAAUTL1
if FTP']""
GOTO 1
+2 IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+3 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+4 WRITE !,"due to separation of duties."
End DoDot:1
GOTO 1
+5 KILL FBAAOUT
+6 IF $GET(FBCHCO)
SET FB7078=$SELECT($GET(FB7078):FB7078_";FB7078(",$DATA(FB583):FB583_";FB583(",1:"")
+7 if FBAAPTC="R"
DO ^FBAACO0
+8 DO PAT
if $DATA(FB583)
DO GETVEN1^FBAACO1
if '$DATA(FB583)
DO GETVEN^FBAACO1
IF $GET(FBAAOUT)
if $DATA(FB583)
GOTO Q
GOTO 1
+9 WRITE !!
DO FILEV^FBAACO5(DFN,FBV)
IF $GET(FBAAOUT)
if $DATA(FB583)
GOTO Q
GOTO 1
+10 ;check for payments against all linked vendors
+11 SET DA=+Y
DO CHK^FBAACO4
KILL FBAACK1,FBAAOUT,DA,X,Y
+12 KILL FBAAID,FBAAVID
DO GETINV^FBAACO1
IF $GET(FBAAOUT)
if $DATA(FBCHCO)
QUIT
if $DATA(FB583)
GOTO Q
GOTO 1
+13 IF '$DATA(FBAAID)!('$DATA(FBAAVID))
DO GETINDT^FBAACO1
IF $GET(FBAAOUT)
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+14 ;
+15 ; FB*3.5*123 - check for IPAC agreement for Federal vendor and capture DoD invoice number (both req'd if IPAC)
+16 SET FBDODINV=""
+17 SET FBIA=$$IPAC^FBAAMP(FBV)
IF FBIA=-1
SET FBAAOUT=1
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+18 IF FBIA
IF '$$IPACINV^FBAAMP(.FBDODINV)
SET FBAAOUT=1
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+19 ;
+20 ; ask patient account number
+21 SET FBCSID=$$ASKPAN^FBUTL5()
IF FBCSID="^"
KILL FBCSID
SET FBAAOUT=1
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+22 ; if U/C then get FPPS Claim ID else ask user
+23 IF $DATA(FB583)
SET FBFPPSC=$PIECE($GET(^FB583(FB583,5)),U)
WRITE !,"FPPS CLAIM ID: ",$SELECT(FBFPPSC="":"N/A",1:FBFPPSC)
+24 IF '$TEST
SET FBFPPSC=$$FPPSC^FBUTL5()
IF FBFPPSC=-1
KILL FBFPPSC
SET FBAAOUT=1
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+25 ;
+26 ; Enter UCID FB3.5*135
SET FBUCI135=$$ENTROUTP^FBUTL136(DFN,FBV,FBAAVID,FBFPPSC)
+27 ; Enter UCID FB3.5*135
IF FBUCI135<1
KILL FBFPPSC
SET FBAAOUT=1
DO OUT
if $DATA(FB583)
GOTO Q
if '$DATA(FBCHCO)
GOTO 1
QUIT
+28 ;
+29 if $GET(FBMP)
GOTO 1^FBAAMP
DO MM
if $GET(FBAAOUT)
GOTO Q
SVDT KILL FBAAOUT,HOLDY
WRITE !!
DO GETSVDT^FBAACO5(DFN,FBV,FBASSOC,1)
IF $GET(FBAAOUT)
KILL FBAADT,FBX,FBAACP
if FBINTOT>0
WRITE !!,"Invoice: "_FBAAIN_" Totals $ "_$JUSTIFY(FBINTOT,1,2)
if $DATA(FB583)!($GET(FBCHCO))
GOTO Q
GOTO 1
+1 DO SETO^FBAACO3
DO DISPINV^FBAACO1
+2 WRITE !
DO ASKZIP^FBAAFS($GET(FBV),$GET(FBAADT))
+3 IF $GET(FBAAOUT)!(FBZIP']"")
DO DEL^FBAACO3
GOTO SVDT
CPT KILL FBAAOUT
WRITE !
+1 DO CPTM^FBAALU($GET(FBAADT),$GET(DFN))
IF 'FBGOT
DO DEL^FBAACO3
GOTO SVDT
+2 DO CHK2^FBAACO4
IF FBJ']""
GOTO SVPR
CHKE ;determines what action to take on duplicate services entered
+1 KILL FBAAOUT
WRITE !!,*7,"Service selected for that date already in system."
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to add another service for the SAME DATE"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
if Y
GOTO SVPR
+3 IF FBJ]""
IF FBJ'=FBV
WRITE !!,*7,"You must use the 'EDIT PAYMENT' option to edit the service previously",!,"entered for that date."
DO DEL^FBAACO3
GOTO SVDT
+4 SET DIR(0)="Y"
SET DIR("A")="Want to edit it"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
IF Y
DO DOEDIT^FBAACO3
if '$DATA(FBDL)!($GET(FBAAOUT))
GOTO SVDT
if $DATA(FB583)
GOTO Q
GOTO 1
+5 DO ^FBAACO2
if '$GET(FBDEN)
GOTO CPT
SVPR KILL FBAAOUT
+1 IF $$ANES^FBAAFS($$CPT^FBAAUTL4($GET(FBAACP)))
DO ASKTIME^FBAAFS
IF $GET(FBAAOUT)!'$GET(FBTIME)
GOTO CPT
+2 DO SVCPR^FBAACO1
if $GET(FBAAOUT)
GOTO CPT
+3 ;FB*3.5*133 removed provider field save
SET FBAMTPD=0
DO FILE^FBAACO2
IF $DATA(FBAAOUT)
if $DATA(FB583)
GOTO Q
if $DATA(FBDL)
GOTO 1
GOTO Q
+4 DO OUT^FBAACO3
if Z1>(FBAAMPI-20)
WRITE !,*7,"Warning, you can only enter ",(FBAAMPI-Z1)," more line(s)!"
if Z1'>(FBAAMPI-1)
GOTO CPT
DO WARN^FBAACO3
GOTO EN583
+5 GOTO 1
+6 ;
Q ;exit point for outpatient payment routines
+1 KILL FBAAPTC,DIC,Y,A,I,DFN,BO,DA,DI,DQ,DR,E,FBAABDT,FBAABE,FBFY,FBDL,FBAAID,FBAAIN,FBAAMPI,FBAAOPA,FBAAPN,FBCONT,FBDX,FBGOT,FBPOV,FBPT,DLAYGO,FBPSA,FBASSOC,FBZBN,FBZBS,FBDEN,FBV,FBSDI,FBAACPI,FBAACP,FBX,FBLOCK
+2 KILL FBSP,FBTPD,FBTT,FBTYPE,FTP,FBDEL,FY,FBINTOT,G,H,MAJN,NO,PI,Q,R,SUB,SUBN,TA,TP,UL,W,X1,Z,Z1,ZZ,FBAADT,K,L,J,FBTOV,FBPARCD,FBT,FEEO,Z2,FBSITE,FBAUT,T,FBLOC,FBSSN,FBVEN,FBD1,Z0,FB583
+3 KILL A1,A2,B1,B2,DAT,DIE,FBAACPT,FBAMTPD,FBAAEDT,FBAAOUT,FBAAPD,FBI,FBIN,FBPROG,FBRR,FBXX,PTYPE,S,VAL,X,V,ZS,FB7078,FBFDC,FBCOUNTY,FBMST,FBTTYPE,FBTV,HY,FBDMRA,DIRUT,FBPOP,FBJ,FBAACK1,FBAR,FBDA,FBST
+4 KILL FBMP,FBK,FBAAAS,%DT,FBDT,FBMAX,FBAMFS,FBAASC,FBHCFA,FBSI,FBCNP,FBAAAMT,FBAAVID,FBAAMM,FBAAMM1,VAPA,FBZX,FBTST,HOLDY,FBAOT
+5 KILL FBCSID,FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBADJL,FBRRMK,FBRRMKD,FBRRMKL,FBUNITS,FBCNTRP,FBUCI135,FBIA,FBDODINV
AUTHQ KILL DIC,DFN,CNT,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBAUT,FBPOV,FBPROG,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FBTP,PI,TA,FBMOD,FBMODA,FBZIP,FBTIME,FBFSAMT,FBFSUSD
+1 DO GETAUTHK^FBAAUTL1
+2 QUIT
+3 ;
SITE ;set up site variables
+1 if '$DATA(FBSITE(0))
DO SITEP^FBAAUTL
if $GET(FBPOP)
QUIT
IF '$GET(FBPROG)
Begin DoDot:1
+2 IF $GET(FBCHCO)
SET FBPROG="I ($P(^(0),""^"",3)=6!($P(^(0),""^"",3)=7))&($P(^(0),U,9)'[""FB583"")"
QUIT
+3 SET FBPROG=$SELECT($PIECE(FBSITE(1),"^",6)="":"I $P(^(0),""^"",9)'[""FB583""",1:"I $P(^(0),""^"",3)=2,($P(^(0),""^"",9)'[""FB583"")")
End DoDot:1
+4 if '$DATA(FBAAPTC)
SET FBAAPTC="V"
+5 SET FBAAMPI=$PIECE($GET(^FBAA(161.4,1,"FBNUM")),"^",3)
SET FBAAMPI=$SELECT(FBAAMPI]"":FBAAMPI,1:100)
+6 QUIT
+7 ;
BT ;select batch
+1 SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,3)=""B3""&($G(^(""ST""))=""O"")&(($P(^(0),U,5)=DUZ)!($D(^XUSEC(""FBAA LEVEL 2"",DUZ))))"
SET DIC("W")="W !,"" Obligation #: "",$P(^(0),U,2)"
WRITE !!
DO ^DIC
KILL DIC
IF X["^"!(X="")
SET FBAAOUT=1
QUIT
+2 if Y<0
GOTO BT
SET (DA,FBAABE)=+Y
SET Y(0)=^FBAA(161.7,DA,0)
+3 IF $PIECE(Y(0),"^",11)>(FBAAMPI-1)
WRITE !!,"This Batch already has the maximum number of Payments!"
GOTO BT
+4 SET Z1=$PIECE(Y(0),"^",11)
SET FB7078=""
SET BO=$PIECE(^FBAA(161.7,DA,0),"^",2)
+5 QUIT
PAT ;set up patient in patient file
+1 ;required input variable DFN
+2 IF '$DATA(^FBAAC(DFN,0))
KILL DD,DO
SET (X,DINUM)=DFN
SET DIC(0)="L"
SET DLAYGO=162
SET DIC="^FBAAC("
DO FILE^DICN
KILL DLAYGO,DIC,DINUM,DD,DO,DA
+3 QUIT
MM ;check for money management of entire invoice
+1 ; fb*3.5*116
+2 DO MMPPT
+3 QUIT
OUT KILL FBAADT,FBX,FBAACP
if FBINTOT>0
WRITE !!,"Invoice: "_FBAAIN_" Totals $ "_$JUSTIFY(FBINTOT,1,2)
QUIT
+1 ;
MMPPT ;money management/prompt pay type for multiple payment entry
+1 ; input
+2 ; FBAAPTC = payment type code, "R" when patient reimbursement
+3 ; FBV = vendor being paid (ien)
+4 ; when called from FBAAMP additional variables will be available
+5 ; FBCNTRA = contract ien from authorization
+6 ; FBVEN = vendor from authorization
+7 ; FB583 = defined when unauthorized claim
+8 ; output
+9 ; FBAAMM = prompt payment, =1 to ask
+10 ; FBAAMM1 = prompt payment type for line
+11 ; FBAAOUT = (optional), = 1 to quit
+12 ; FBCNTRP = contract for line item (ien)
+13 ;
+14 SET (FBAAMM,FBAAMM1,FBCNTRP)=""
+15 IF $GET(FBAAPTC)'="R"
IF '$DATA(FB583)
Begin DoDot:1
+16 ;
+17 ; check if contract required by authorization
+18 IF '$DATA(FB583)
IF $$UCFA^FBUTL7($GET(FBV),$GET(FBVEN),$GET(FBCNTRA))
Begin DoDot:2
+19 WRITE !,"All lines items on this invoice will be considered as contracted services"
+20 WRITE !,"under Contract ",$PIECE($GET(^FBAA(161.43,FBCNTRA,0)),U)," from the authorization."
+21 SET (FBAAMM,FBAAMM1)=1
+22 SET FBCNTRP=FBCNTRA
End DoDot:2
QUIT
+23 ;
+24 ; when not forced by authorization ask if contracted service
+25 WRITE !,"The answer to the following will apply to all payments entered via this option."
+26 SET DIR(0)="Y"
+27 SET DIR("A")="Are payments for contracted services"
+28 SET DIR("B")="No"
+29 SET DIR("?",1)="Answering no indicates interest will not be paid for any line items."
+30 SET DIR("?",2)="Answering yes indicates interest will be paid."
+31 SET DIR("?",3)="A fee schedule is not used for contracted services."
+32 SET DIR("?")="Enter either 'Y' or 'N'."
+33 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET FBAAOUT=1
QUIT
+34 SET (FBAAMM,FBAAMM1)=$SELECT(Y:1,1:"")
+35 if FBAAMM1=""
QUIT
+36 ;
+37 ; if contracted service, ask contract
+38 SET DIR(0)="PO^161.43:AQEM"
+39 SET DIR("A")="CONTRACT"
+40 SET DIR("?",1)="If the line item is under a contract then select it."
+41 SET DIR("?")="Contract must be active and applicable for the vendor."
+42 SET DIR("S")="I $P($G(^(0)),""^"",2)'=""I"",$$VCNTR^FBUTL7($G(FBV),+Y)"
+43 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET FBAAOUT=1
QUIT
+44 if Y>0
SET FBCNTRP=+Y
End DoDot:1
+45 QUIT
+46 ;
