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

FBAASCB0.m

Go to the documentation of this file.
  1. FBAASCB0 ;AISC/DMK - POST 1358 FOR INPATIENT 7078'S ;4/2/2012
  1. ;;3.5;FEE BASIS;**116,132**;JAN 30, 1995;Build 17
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. K FBERR,^TMP($J) S FBRJC=0,FBINTOT=$P(FZ,U,10)
  1. I '$O(^FBAAI("AC",FBN,0)) W !,*7,"No invoices found for this batch. Unable to release.",! S FBERR=1 Q
  1. ;
  1. S FBII=0 F S FBII=$O(^FBAAI("AC",FBN,FBII)) Q:'FBII!($D(FBERR)) S FBII78=$P($G(^FBAAI(FBII,0)),"^",5),FBAAMT=$P($G(^(0)),"^",9),FBMM=$E($P(^(0),U,6),4,5) D GETAP,GET78:FBII78["FB7078(",UC:FBII78["FB583("
  1. I $G(FBRJC),FBRJC=FBINTOT S FBERR=1 D KILL Q
  1. I $G(FBRJC) K FBERR S (FBRJC,FBII)=0 F S FBII=$O(^TMP($J,FBII)) Q:'FBII S X=$G(^FBAAI(FBII,0)),FBII78=$P(X,U,5),FBAAMT=$P(X,U,9),FBMM=$E($P(X,U,6),4,5) K X,^TMP($J,FBII) D GET78
  1. I $G(FBRJC) S (FBAAMT,FBINTOT)=0 D NEWBT S FBII=0 F S FBII=$O(^TMP($J,FBII)) Q:'FBII D
  1. .S DA=FBII,DIE="^FBAAI(",DR="20////^S X=FBBN" D ^DIE K DR,DA,DIE
  1. .S FBAAMT=FBAAMT+$P(^FBAAI(FBII,0),U,9),FBINTOT=FBINTOT+1
  1. D:$G(FBRJC) RESETBT
  1. ; FB*3.5*116 ; report zero dollar invoices
  1. I $D(FBINV) D
  1. . S FBII=0 F S FBII=$O(FBINV(FBII)) Q:'FBII W !!,"Invoice #: "_FBII_" totals $0.00"
  1. . W $C(7),!!?2,"Batch cannot be released when zero dollar invoices exist."
  1. . W !?2,"Invoices must be corrected or removed from the batch."
  1. . S FBERR=1
  1. Q
  1. ;
  1. KILL K FBII,FBII78,FBAAMT,FBI78,FBMM,PRCSX,FBRJC,FBSTN,FBBN,FBINTOT,FBCNH,^TMP($J) Q
  1. ;
  1. GET78 I '$D(^FB7078(+FBII78,0)) W !,*7,"No associated 7078 for invoice ",FBII,". Unable to release batch.",! S FBERR=1 Q
  1. S FBI78=$P(^FB7078(+FBII78,0),"^"),DFN=+$P(^(0),"^",3),FBI78=$P(FZ,"^",8)_"-"_$P(FBI78,".")_"-"_$P(FBI78,".",2) D
  1. . ;
  1. . ;I $D(FBCNH),'$D(^PRC(424,"E",DFN_";"_+FBII78_";"_FBAAON_";"_FBMM)) D POST^FBAASCB
  1. .D INPOST:$$INTER()
  1. .I $D(FBCNH),'$$INTER S FBERR=1 W !!,$$NAME^FBCHREQ2(DFN)," ",$$SSN^FBAAUTL(DFN),!,*7,"Unable to locate reference number on 1358. Run Post Commitments for",!,"Obligation option."
  1. .I $D(FBCNH),$D(FBERR) S ^TMP($J,+FBII)="",FBRJC=FBRJC+1 K FBERR
  1. Q
  1. ;
  1. INPOST ;PRCSX=INTERNAL DAILY REF #^INTERNAL DATE/TIME^AMT OF PAYMENT^COMMENTS^COMPLETE FLAG
  1. ;FBI78=AUTHORIZATION NAME IN 424 (STA-CXXXXX-REF #)
  1. ;FBERR RETURNED IF IFCAP CALL FAILS
  1. ;FBCOMM=COMMENT
  1. ;FBAAMT=ACTUAL AMOUNT OF PAYMENT
  1. ;INTERFACE ID = DFN_";"_INTERNAL ENTRY NUMBER OF 7078_";"_FBAAON (OBLIGATION)_";" if CNH _FBMM (month of service)
  1. ;INTERNAL DAILY REF # = $O(^PRC(424,"B","STA #-OBLIGATION #-REF #",0))
  1. ;NEW INTERNAL DAILY REF # LOOKUP=$O(^PRC(424,"E",INTERFACE ID,0))
  1. I '$$INTER() W !,*7,"Unable to locate reference number on 1358.",! S FBERR=1 Q
  1. S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
  1. D NOW^%DTC
  1. S PRCSX=$$INTER()_"^"_%_"^"_FBAAMT_"^"_$S($D(FBCOMM):FBCOMM,1:"")_"^"_1
  1. D ^PRCS58CC I Y'=1 W !!,$$NAME^FBCHREQ2(DFN)," (",$$SSN^FBAAUTL(DFN,1),")",!,*7,$P(Y,"^",2),! S FBERR=1 Q
  1. Q
  1. ;
  1. INTER() ;get internal entry number from file 424
  1. ;first check for new INTERFACE ID "E" x-ref in 424
  1. ;2nd check is to "B" x-ref to stay backward compatible with IFCAP 3.6
  1. ;
  1. I '$D(FBCNH),$D(^PRC(424,"E",DFN_";"_+FBII78_";"_FBAAON)) Q $O(^(DFN_";"_+FBII78_";"_FBAAON,0))
  1. I $D(FBCNH),$D(^PRC(424,"E",DFN_";"_+FBII78_";"_FBAAON_";"_FBMM)) Q $O(^(DFN_";"_+FBII78_";"_FBAAON_";"_FBMM,0))
  1. I '$D(FBCNH),$D(^PRC(424,"B",FBI78)) Q $O(^(FBI78,0))
  1. Q 0
  1. ;
  1. NEWBT ;open new batch for cnh line items unable to post to 1358
  1. S FBSTN=$P(FZ,U,8) W ! D GETNXB^FBAAUTL
  1. S DIC="^FBAA(161.7,",DIC(0)="LQ",X=FBBN,DIC("DR")="1////^S X=FBAAON;2////^S X=""B9"";3////^S X=DT;4////^S X=$P(FZ,U,5);11////^S X=""O"";16////^S X=FBSTN",DLAYGO=161.7
  1. K DD,DO D FILE^DICN S FBBN=+Y K DIC,DLAYGO
  1. Q
  1. RESETBT ;reset original batch total $ set new batch totals
  1. S X=$G(^FBAA(161.7,FBBN,0)),$P(X,U,9)=FBAAMT,$P(X,U,10)=FBINTOT,$P(X,U,11)=FBINTOT,^(0)=X K X
  1. S $P(FZ,U,9)=$P(FZ,U,9)-FBAAMT,$P(FZ,U,10)=$P(FZ,U,10)-FBINTOT,$P(FZ,U,11)=$P(FZ,U,11)-FBINTOT,^FBAA(161.7,FBN,0)=FZ
  1. W !!,*7,"A new batch, number ",$P(^FBAA(161.7,FBBN,0),U),", was opened for invoices unable to post to 1358.",!,"Adjust 1358 and take action on new batch.",!
  1. Q
  1. ;
  1. GETAP ; FB*3.5*116 build array of invoices in batch
  1. Q:$D(FBCNH) ; do not build array if CNH batch
  1. Q:FBAAMT>0 ; do not place invoice reference in array if the amount paid is greater than 0.00
  1. S FBINV(FBII)=""
  1. Q
  1. UC ; accumulate amount of unauthorized inpatient claims for later posting
  1. S FBAARA=FBAARA+FBAAMT
  1. Q