- 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 Feb 18, 2025@23:21:33 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 ;