- 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 Feb 18, 2025@23:23:03 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