FBCHEP ;AISC/DMK - ENTER PAYMENT FOR CONTRACT HOSPITAL ;10/1/2004
;;3.5;FEE BASIS;**4,61,77,82,122,108,124,135,139,123,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
S FBAAPTC="V",FBAAOUT=0
RD K FBAAID,FBAAVID S FBRESUB="" D GETVET^FBAAUTL1 G:DFN']"" Q
S FBPROG="I $P(^(0),U,3)=6,($P(^(0),U,9)'[""FB583"")" D GETAUTH^FBAAUTL1 G RD:$D(DUOUT),RD:FTP']""
;W !!,?25,"< ASSOCIATED 7078 >",!!
;S DIC="^FB7078(",DA=FB7078,DR="0;1" D EN^DIQ
I FB7078="" W !,*7,"No 7078 on file for this authorization." G RD
S FBI7078=FB7078_";FB7078("
;
I '$$UOKPAY^FBUTL9(DFN,FTP) D G RD
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
;
I $D(^FBAAI("E",FBI7078)) S FBAAIN=$O(^FBAAI("E",FBI7078,0)) G OUT
SETINV S FBZ(0)=^FB7078(FB7078,0),FBVET=$P(FBZ(0),"^",3),FBVEN=$P(FBZ(0),"^",2),FBVEN=$P(FBVEN,";",1)
;
EN583 ;Entry from 583 enter payment
I FBAAPTC="R" D ^FBAACO0
S DA=FBVEN D EN1^FBAAVD
I $P($G(^FBAAV(FBVEN,"ADEL")),U)="Y" W !!,*7,"Vendor is flagged for Austin deletion!" G Q
D SITEP^FBAAUTL G Q:FBPOP
S FBAAMPI=$P(FBSITE("FBNUM"),U,4)
;
RDV S FBVE="" S:$D(^FBAAV(FBVEN,"AMS")) FBVE=$P(^("AMS"),"^",2) S:$G(FBVE)'="Y" FBVE="N"
I FBVE="Y" W *7,!!,"Vendor is listed as 'exempt from the pricer'." S DIR(0)="Y",DIR("A")="Do you wish to keep this invoice exempt from the pricer",DIR("B")="Yes" D ^DIR K DIR G Q:$D(DIRUT) S FBVE=$S(Y=1:"Y",1:"N")
I $G(FBVE)'="Y",($P($G(^FBAAV(FBVEN,0)),"^",17)']"") W !!,*7,"Medicare ID Number is needed for this Vendor!" S DIE="^FBAAV(",DR=22 D ^DIE K DIE G Q:$D(DTOUT)!('$L(X))
;
BAT S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)=""Y"")&($G(^(""ST""))=""O"")&(FBAAMPI>$P(^(0),U,10))" W ! D ^DIC K DIC
G Q:X="^"!(X=""),BAT:Y<0 S FBAABE=+Y,FBY(0)=Y(0),Z1=$P(FBY(0),"^",11),BO=$P(FBY(0),"^",2),Z2=$P(FBY(0),"^",10),FBSTN=$P(FBY(0),"^",8),FBCHOB=FBSTN_"-"_$P(FBY(0),"^",2),FBEXMPT=$P(FBY(0),"^",18) S FBAAOUT=0 D CHK I FBAAOUT K Y,Y(0),FBAABE G BAT
I FBI7078["FB7078(",BO'=$P($P(FBZ(0),U),".") W !,*7,"Obligation number on batch does not match 1358.",!,"Obligation number on batch must be ",$P($P(FBZ(0),U),"."),".",! G BAT
S FBINC=$S($P(FBY(0),"^",10)="":0,1:$P(FBY(0),"^",10)),FBLN=$S($P(FBY(0),"^",11)="":0,1:$P(FBY(0),"^",11))
GETNXI D GETNXI^FBAAUTL
W !!,"Invoice # ",FBAAIN," assigned to this Invoice"
RIN S CALLERID="FBCHEP" D GETINDT^FBAACO1 K CALLERID G Q:$G(FBAAOUT)
;
; 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($G(FBVEN)) I FBIA=-1 G Q
I FBIA,'$$IPACINV^FBAAMP(.FBDODINV) G Q
;
; ask patient control number
S FBCSID=$$ASKPCN^FBUTL5() I FBCSID="^" G 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 G Q
; Get Unique Claim ID ; FB*3.5*135
S FBUCI135=$$ENTINPAT^FBUTL136($G(FBSTN),1,,"I",$G(FBFPPSC),$G(FBVEN)) I FBUCI135<1 G Q
; if EDI claim then ask FPPS line item
I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5(,1) I FBFPPSL=-1 G Q
; compute default Covered Days
S FBCDAYS=$$FMDIFF^XLFDT(FBAAEDT,FBAABDT)
I FBCDAYS=0 S FBCDAYS=1
S FBAAMM=$S(FBAAPTC="R":"",$D(FB583):"",1:1) D PPT^FBAACO1()
DIC S DIC="^FBAAI(",DIC(0)="LQ",DLAYGO=162.5,X=FBAAIN D ^DIC G Q:Y<0
S DA=+Y,DIE=DIC,DR="[FBCH ENTER PAYMENT]",DIE("NO^")=""
D
. ; JAS - 12/18/13 - PATCH 139 - Modified original code for ICD-10--date of interest must be Auth. To date, if available.
. N ICDVDT S ICDVDT=$G(FBAAEDT)
. I ICDVDT="" S ICDVDT=$G(FBAABDT)
. D ^DIE
. ; End 139
; file adjustment reasons
D FILEADJ^FBCHFA(DA_",",.FBADJ)
; file remittance remarks
D FILERR^FBCHFR(DA_",",.FBRRMK)
; file Line Item Rendering providers
D FILERP^FBUTL8(DA_",",.FBPROV) ;FB*3.5*122
K DIE,DIC,D,DA,DR
S $P(FBY(0),"^",10)=FBINC+1,$P(FBY(0),"^",11)=FBLN+1,$P(FBY(0),"^",18)=FBEXMPT,^FBAA(161.7,FBAABE,0)=FBY(0) ;D:'$D(FBNOPTF) PTF G Q:$D(FB583),RD
D
. N FBX
. S FBX=FBAAMPI-(FBINC+1)
. I FBX<6 W !,$C(7),"Warning, you can only enter ",FBX," more invoices in this batch!",!
D:'$D(FBNOPTF) PTF
G Q:$D(FB583),RD
OUT W !!,*7,?3,"Invoice number ",FBAAIN," has already been entered for this authorization.",!,?3,"Use the Contract Hospital 'Invoice Edit' option if needed.",!
;check if user wants to add a second invoice for this 7078
W ! S DIR("A")="Want to add another invoice for this episode of care",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR I Y S (FBNOPTF,FBRESUB)=1 G SETINV
Q K BO,CNT,D,DA,DAT,DIC,DIE,DLAYGO,DR,FB7078,FBAABDT,FBAABE,FBAAEDT,FBAAID,FBAAIN,FBAAOUT,FBAAPTC,FBDX,FBTT,FBTYPE,FBVEN,FBVET,FBXX,FTP,I,J,FBK,PI,FBPOP,PTYPE,S,FBZ,Z1,FBI,FBPROG,FBRR,FBSW,FBPOV,FBPT,FBY,T,Y,Z1,Z2,ZZ,FBPSA,A,FBI7078
K FBCHOB,FBAUT,FBSEQ,X,FBSITE,F,FBSTN,FBASSOC,FBLOC,DUOUT,PSA,FBCOUNTY,DFN,FBNOPTF,DIRUT,FBVE,FBAAOUT,FBEXMPT,FBAAPN,FBAMTC,FBDEL,FBINC,FBLN,FBRESUB
K FBD1,FBFDC,FBMST,FBTTYPE,FB583,FBUCI135
K FBCSID,FBFPPSC,FBFPPSL,FBCDAYS,FBAMTP,FBADJ,FBRRMK,FBAAMPI,FBV,FBIA,FBDODINV
D GETAUTHK^FBAAUTL1
Q
PTF I $G(FBVET),$G(FBI7078)["FB583" S:'$G(DFN) DFN=FBVET D PTFC^FBUTL6(DFN,$P(FBZ(0),"^",4))
Q
PRBT ;Entry point for patient reimbursement option
;
S FBAAPTC="R"
G RD
CHK ;Check for vendor and batch being exempt from pricer
I $G(FBVE)'="Y"&($G(FBVE)'="N") S FBVE="N"
I $G(FBEXMPT)="Y" Q:FBVE="Y" G OPEN:FBVE="N"
I $G(FBEXMPT)="N" Q:FBVE="N" G OPEN:FBVE="Y"
I '$G(FBEXMPT)&($G(Z2)'>0) S FBEXMPT=FBVE Q
I '$G(FBEXMPT)&($G(Z2)>0) S $P(^FBAA(161.7,FBAABE,0),"^",18)="N",FBEXMPT="N" G CHK
Q
OPEN W *7,!!,"This Invoice may not be added to Batch # ",+FBY(0),".",!,"***You may not add a ",$S(FBVE="Y":"pricer exempt",1:"non-exempt")," invoice to a ",$S(FBVE="Y":"non-exempt",1:"pricer exempt")," batch.***"
S DIR(0)="Y",DIR("A")="Do you want to open a new batch at this time",DIR("B")="Y" D ^DIR K DIR S:$D(DIRUT)!('Y) FBAAOUT=1 Q:FBAAOUT D RCHOP^FBAAOB S FBEXMPT=FBVE D
.S FBY(0)=$G(^FBAA(161.7,FBAABE,0)),Z1=$P(FBY(0),"^",11),BO=$P(FBY(0),"^",2),Z2=$P(FBY(0),"^",10),FBSTN=$P(FBY(0),"^",8),FBCHOB=FBSTN_"-"_$P(FBY(0),"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHEP 6280 printed Dec 13, 2024@01:57:41 Page 2
FBCHEP ;AISC/DMK - ENTER PAYMENT FOR CONTRACT HOSPITAL ;10/1/2004
+1 ;;3.5;FEE BASIS;**4,61,77,82,122,108,124,135,139,123,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 SET FBAAPTC="V"
SET FBAAOUT=0
RD KILL FBAAID,FBAAVID
SET FBRESUB=""
DO GETVET^FBAAUTL1
if DFN']""
GOTO Q
+1 SET FBPROG="I $P(^(0),U,3)=6,($P(^(0),U,9)'[""FB583"")"
DO GETAUTH^FBAAUTL1
if $DATA(DUOUT)
GOTO RD
if FTP']""
GOTO RD
+2 ;W !!,?25,"< ASSOCIATED 7078 >",!!
+3 ;S DIC="^FB7078(",DA=FB7078,DR="0;1" D EN^DIQ
+4 IF FB7078=""
WRITE !,*7,"No 7078 on file for this authorization."
GOTO RD
+5 SET FBI7078=FB7078_";FB7078("
+6 ;
+7 IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+8 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+9 WRITE !,"due to separation of duties."
End DoDot:1
GOTO RD
+10 ;
+11 IF $DATA(^FBAAI("E",FBI7078))
SET FBAAIN=$ORDER(^FBAAI("E",FBI7078,0))
GOTO OUT
SETINV SET FBZ(0)=^FB7078(FB7078,0)
SET FBVET=$PIECE(FBZ(0),"^",3)
SET FBVEN=$PIECE(FBZ(0),"^",2)
SET FBVEN=$PIECE(FBVEN,";",1)
+1 ;
EN583 ;Entry from 583 enter payment
+1 IF FBAAPTC="R"
DO ^FBAACO0
+2 SET DA=FBVEN
DO EN1^FBAAVD
+3 IF $PIECE($GET(^FBAAV(FBVEN,"ADEL")),U)="Y"
WRITE !!,*7,"Vendor is flagged for Austin deletion!"
GOTO Q
+4 DO SITEP^FBAAUTL
if FBPOP
GOTO Q
+5 SET FBAAMPI=$PIECE(FBSITE("FBNUM"),U,4)
+6 ;
RDV SET FBVE=""
if $DATA(^FBAAV(FBVEN,"AMS"))
SET FBVE=$PIECE(^("AMS"),"^",2)
if $GET(FBVE)'="Y"
SET FBVE="N"
+1 IF FBVE="Y"
WRITE *7,!!,"Vendor is listed as 'exempt from the pricer'."
SET DIR(0)="Y"
SET DIR("A")="Do you wish to keep this invoice exempt from the pricer"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
SET FBVE=$SELECT(Y=1:"Y",1:"N")
+2 IF $GET(FBVE)'="Y"
IF ($PIECE($GET(^FBAAV(FBVEN,0)),"^",17)']"")
WRITE !!,*7,"Medicare ID Number is needed for this Vendor!"
SET DIE="^FBAAV("
SET DR=22
DO ^DIE
KILL DIE
if $DATA(DTOUT)!('$LENGTH(X))
GOTO Q
+3 ;
BAT SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQMZ"
SET DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)=""Y"")&($G(^(""ST""))=""O"")&(FBAAMPI>$P(^(0),U,10))"
WRITE !
DO ^DIC
KILL DIC
+1 if X="^"!(X="")
GOTO Q
if Y<0
GOTO BAT
SET FBAABE=+Y
SET FBY(0)=Y(0)
SET Z1=$PIECE(FBY(0),"^",11)
SET BO=$PIECE(FBY(0),"^",2)
SET Z2=$PIECE(FBY(0),"^",10)
SET FBSTN=$PIECE(FBY(0),"^",8)
SET FBCHOB=FBSTN_"-"_$PIECE(FBY(0),"^",2)
SET FBEXMPT=$PIECE(FBY(0),"^",18)
SET FBAAOUT=0
DO CHK
IF FBAAOUT
KILL Y,Y(0),FBAABE
GOTO BAT
+2 IF FBI7078["FB7078("
IF BO'=$PIECE($PIECE(FBZ(0),U),".")
WRITE !,*7,"Obligation number on batch does not match 1358.",!,"Obligation number on batch must be ",$PIECE($PIECE(FBZ(0),U),"."),".",!
GOTO BAT
+3 SET FBINC=$SELECT($PIECE(FBY(0),"^",10)="":0,1:$PIECE(FBY(0),"^",10))
SET FBLN=$SELECT($PIECE(FBY(0),"^",11)="":0,1:$PIECE(FBY(0),"^",11))
GETNXI DO GETNXI^FBAAUTL
+1 WRITE !!,"Invoice # ",FBAAIN," assigned to this Invoice"
RIN SET CALLERID="FBCHEP"
DO GETINDT^FBAACO1
KILL CALLERID
if $GET(FBAAOUT)
GOTO Q
+1 ;
+2 ; FB*3.5*123 - check for IPAC agreement for Federal vendor and capture DoD invoice number (both req'd if IPAC)
+3 SET FBDODINV=""
+4 SET FBIA=$$IPAC^FBAAMP($GET(FBVEN))
IF FBIA=-1
GOTO Q
+5 IF FBIA
IF '$$IPACINV^FBAAMP(.FBDODINV)
GOTO Q
+6 ;
+7 ; ask patient control number
+8 SET FBCSID=$$ASKPCN^FBUTL5()
IF FBCSID="^"
GOTO Q
+9 ; if U/C then get FPPS Claim ID else ask user
+10 IF $DATA(FB583)
SET FBFPPSC=$PIECE($GET(^FB583(FB583,5)),U)
WRITE !,"FPPS CLAIM ID: ",$SELECT(FBFPPSC="":"N/A",1:FBFPPSC)
+11 IF '$TEST
SET FBFPPSC=$$FPPSC^FBUTL5()
IF FBFPPSC=-1
GOTO Q
+12 ; Get Unique Claim ID ; FB*3.5*135
+13 SET FBUCI135=$$ENTINPAT^FBUTL136($GET(FBSTN),1,,"I",$GET(FBFPPSC),$GET(FBVEN))
IF FBUCI135<1
GOTO Q
+14 ; if EDI claim then ask FPPS line item
+15 IF FBFPPSC]""
SET FBFPPSL=$$FPPSL^FBUTL5(,1)
IF FBFPPSL=-1
GOTO Q
+16 ; compute default Covered Days
+17 SET FBCDAYS=$$FMDIFF^XLFDT(FBAAEDT,FBAABDT)
+18 IF FBCDAYS=0
SET FBCDAYS=1
+19 SET FBAAMM=$SELECT(FBAAPTC="R":"",$DATA(FB583):"",1:1)
DO PPT^FBAACO1()
DIC SET DIC="^FBAAI("
SET DIC(0)="LQ"
SET DLAYGO=162.5
SET X=FBAAIN
DO ^DIC
if Y<0
GOTO Q
+1 SET DA=+Y
SET DIE=DIC
SET DR="[FBCH ENTER PAYMENT]"
SET DIE("NO^")=""
+2 Begin DoDot:1
+3 ; JAS - 12/18/13 - PATCH 139 - Modified original code for ICD-10--date of interest must be Auth. To date, if available.
+4 NEW ICDVDT
SET ICDVDT=$GET(FBAAEDT)
+5 IF ICDVDT=""
SET ICDVDT=$GET(FBAABDT)
+6 DO ^DIE
+7 ; End 139
End DoDot:1
+8 ; file adjustment reasons
+9 DO FILEADJ^FBCHFA(DA_",",.FBADJ)
+10 ; file remittance remarks
+11 DO FILERR^FBCHFR(DA_",",.FBRRMK)
+12 ; file Line Item Rendering providers
+13 ;FB*3.5*122
DO FILERP^FBUTL8(DA_",",.FBPROV)
+14 KILL DIE,DIC,D,DA,DR
+15 ;D:'$D(FBNOPTF) PTF G Q:$D(FB583),RD
SET $PIECE(FBY(0),"^",10)=FBINC+1
SET $PIECE(FBY(0),"^",11)=FBLN+1
SET $PIECE(FBY(0),"^",18)=FBEXMPT
SET ^FBAA(161.7,FBAABE,0)=FBY(0)
+16 Begin DoDot:1
+17 NEW FBX
+18 SET FBX=FBAAMPI-(FBINC+1)
+19 IF FBX<6
WRITE !,$CHAR(7),"Warning, you can only enter ",FBX," more invoices in this batch!",!
End DoDot:1
+20 if '$DATA(FBNOPTF)
DO PTF
+21 if $DATA(FB583)
GOTO Q
GOTO RD
OUT WRITE !!,*7,?3,"Invoice number ",FBAAIN," has already been entered for this authorization.",!,?3,"Use the Contract Hospital 'Invoice Edit' option if needed.",!
+1 ;check if user wants to add a second invoice for this 7078
+2 WRITE !
SET DIR("A")="Want to add another invoice for this episode of care"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y
SET (FBNOPTF,FBRESUB)=1
GOTO SETINV
Q KILL BO,CNT,D,DA,DAT,DIC,DIE,DLAYGO,DR,FB7078,FBAABDT,FBAABE,FBAAEDT,FBAAID,FBAAIN,FBAAOUT,FBAAPTC,FBDX,FBTT,FBTYPE,FBVEN,FBVET,FBXX,FTP,I,J,FBK,PI,FBPOP,PTYPE,S,FBZ,Z1,FBI,FBPROG,FBRR,FBSW,FBPOV,FBPT,FBY,T,Y,Z1,Z2,ZZ,FBPSA,A,FBI7078
+1 KILL FBCHOB,FBAUT,FBSEQ,X,FBSITE,F,FBSTN,FBASSOC,FBLOC,DUOUT,PSA,FBCOUNTY,DFN,FBNOPTF,DIRUT,FBVE,FBAAOUT,FBEXMPT,FBAAPN,FBAMTC,FBDEL,FBINC,FBLN,FBRESUB
+2 KILL FBD1,FBFDC,FBMST,FBTTYPE,FB583,FBUCI135
+3 KILL FBCSID,FBFPPSC,FBFPPSL,FBCDAYS,FBAMTP,FBADJ,FBRRMK,FBAAMPI,FBV,FBIA,FBDODINV
+4 DO GETAUTHK^FBAAUTL1
+5 QUIT
PTF IF $GET(FBVET)
IF $GET(FBI7078)["FB583"
if '$GET(DFN)
SET DFN=FBVET
DO PTFC^FBUTL6(DFN,$PIECE(FBZ(0),"^",4))
+1 QUIT
PRBT ;Entry point for patient reimbursement option
+1 ;
+2 SET FBAAPTC="R"
+3 GOTO RD
CHK ;Check for vendor and batch being exempt from pricer
+1 IF $GET(FBVE)'="Y"&($GET(FBVE)'="N")
SET FBVE="N"
+2 IF $GET(FBEXMPT)="Y"
if FBVE="Y"
QUIT
if FBVE="N"
GOTO OPEN
+3 IF $GET(FBEXMPT)="N"
if FBVE="N"
QUIT
if FBVE="Y"
GOTO OPEN
+4 IF '$GET(FBEXMPT)&($GET(Z2)'>0)
SET FBEXMPT=FBVE
QUIT
+5 IF '$GET(FBEXMPT)&($GET(Z2)>0)
SET $PIECE(^FBAA(161.7,FBAABE,0),"^",18)="N"
SET FBEXMPT="N"
GOTO CHK
+6 QUIT
OPEN WRITE *7,!!,"This Invoice may not be added to Batch # ",+FBY(0),".",!,"***You may not add a ",$SELECT(FBVE="Y":"pricer exempt",1:"non-exempt")," invoice to a ",$SELECT(FBVE="Y":"non-exempt",1:"pricer exempt")," batch.***"
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to open a new batch at this time"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
SET FBAAOUT=1
if FBAAOUT
QUIT
DO RCHOP^FBAAOB
SET FBEXMPT=FBVE
Begin DoDot:1
+2 SET FBY(0)=$GET(^FBAA(161.7,FBAABE,0))
SET Z1=$PIECE(FBY(0),"^",11)
SET BO=$PIECE(FBY(0),"^",2)
SET Z2=$PIECE(FBY(0),"^",10)
SET FBSTN=$PIECE(FBY(0),"^",8)
SET FBCHOB=FBSTN_"-"_$PIECE(FBY(0),"^",2)
End DoDot:1
+3 QUIT
