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