FBCHRJP ;AISC/DMK/CMR - PRINT REJECTED PAYMENTS FROM PRICER ;18APR90
;;3.5;FEE BASIS;**58,69,139**;JAN 30, 1995;Build 127
;;Per VA Directive 6402, this routine should not be modified.
I '$D(^FBAAI("AH")) W !,*7,"No payments rejected!",! Q
S (VAR,VAL)="",PGM="START^FBCHRJP" D ZIS^FBAAUTL G END:FBPOP
START K ^TMP($J,"FB") S (FBAAOUT,FBLISTC)=0,Q="",$P(Q,"=",80)="=",QQ="-",$P(QQ,"-",39)="-" U IO W:$E(IOST,1,2)["C-" @IOF D HED
F FBA=0:0 S FBA=$O(^FBAAI("AH",FBA)) Q:FBA="" I $D(^FBAA(161.7,FBA,0)),$P(^(0),"^",15)="Y" S FBN=+^(0) D
.F FBI=0:0 S FBI=$O(^FBAAI("AH",FBA,FBI)) Q:FBI'>0 I $D(^FBAAI(FBI,0)),$P(^(0),"^",9)="",$D(^FBAAI(FBI,"FBREJ")) D
..S FBSORT=1 D VET^FBCHDI,SET^FBPAY67
S (FBVEN,FBNAME)="",(FBDT,FBI)=0 K FBIN
F S FBVEN=$O(^TMP($J,"FB",6,FBVEN)) Q:FBVEN=""!(FBAAOUT) F S FBNAME=$O(^TMP($J,"FB",6,FBVEN,FBNAME)) Q:FBNAME=""!(FBAAOUT) F S FBDT=$O(^TMP($J,"FB",6,FBVEN,FBNAME,FBDT)) Q:FBDT'>0!(FBAAOUT) D
.F S FBI=$O(^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI)) Q:FBI'>0!(FBAAOUT) D D PRINT
..F I=1:1:9 S FBIN(I)=$P(^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI),"^",I)
..S FB7078=$S($P(^FBAAI(FBI,0),"^",5)["FB7078":$P($G(^FB7078(+$P(^FBAAI(FBI,0),"^",5),0)),"^"),1:"") F I=1:1:3 S FBREJ(I)=$P(^FBAAI(FBI,"FBREJ"),"^",I)
END K DFN,FB,FBA,FBAAOUT,FBDX,FBI,FBIN,FBLISTC,FBN,FBPROC,FBVEN,FBVID,J,K,L,PGM,Q,QQ,VA,VADM,VAL,VAR,Y,FB7078,FBPROC1,FBREJ,FBINV,^TMP($J)
D CLOSE^FBAAUTL,END^FBCHDI
Q
PRINT I $Y+5>IOSL,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
I $Y+5>IOSL W @IOF D HED
S FBINV=^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI,"FBINV") ;set by FBPAY67
;If adj code found print it, if not then print suspend code
I $P(FBINV,U,5)]"" S FBIN(4)=$P(FBINV,U,5)
W !!,"Vendor: ",$P(FBVEN,";"),?41,"Vendor ID: ",+$P(FBVEN,";",2)
W !,"Patient: ",$P(FBNAME,";"),?41,"Patient ID: ",$$SSN^FBAAUTL($P(FBNAME,";",2))
W ! W:FBIN(8)["R" "*" W:FBIN(9)]"" "#" W ?3,FBIN(1),?23,FBIN(2),?33,FBIN(3),?42,FBIN(4),?49,FBIN(5),?61,FBIN(6),?72,FBIN(7)
;If FPPS Claim ID exists then print it.
I $P(FBINV,U,3)]"" D
.W !?3,"FPPS Claim ID: ",$P(FBINV,U,3)," FPPS Line Item: ",$P(FBINV,U,4)
;FB*3.5*139-ICD10 REMEDIATION-jlg- fixed issue with zero being displayed in DX field. Modified next line.
W !?3,"DX: ",$P($P($G(^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI,"DX")),U,1),"/",1)
W !?3,"Associated 7078: ",FB7078,!?3,$S(FBREJ(1)="P":"Rejects Pending!",FBREJ(1)="C":"Rejected!",1:""),?23,"Reject Reason: ",FBREJ(2),!?3,"Old Batch #: ",FBREJ(3)
Q
HED W !?18,"CIVIL HOSPITAL REJECTED PAYMENT HISTORY",!?18,QQ
W !!?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)"
W !?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Adj",?49,"Invoice",?61,"From",?73,"To"
W !?23,"Claimed",?35,"Paid",?42,"Code",?53,"Num",?61,"Date",?71,"Date",!,Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHRJP 2816 printed Nov 22, 2024@17:08:06 Page 2
FBCHRJP ;AISC/DMK/CMR - PRINT REJECTED PAYMENTS FROM PRICER ;18APR90
+1 ;;3.5;FEE BASIS;**58,69,139**;JAN 30, 1995;Build 127
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 IF '$DATA(^FBAAI("AH"))
WRITE !,*7,"No payments rejected!",!
QUIT
+4 SET (VAR,VAL)=""
SET PGM="START^FBCHRJP"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START KILL ^TMP($JOB,"FB")
SET (FBAAOUT,FBLISTC)=0
SET Q=""
SET $PIECE(Q,"=",80)="="
SET QQ="-"
SET $PIECE(QQ,"-",39)="-"
USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
DO HED
+1 FOR FBA=0:0
SET FBA=$ORDER(^FBAAI("AH",FBA))
if FBA=""
QUIT
IF $DATA(^FBAA(161.7,FBA,0))
IF $PIECE(^(0),"^",15)="Y"
SET FBN=+^(0)
Begin DoDot:1
+2 FOR FBI=0:0
SET FBI=$ORDER(^FBAAI("AH",FBA,FBI))
if FBI'>0
QUIT
IF $DATA(^FBAAI(FBI,0))
IF $PIECE(^(0),"^",9)=""
IF $DATA(^FBAAI(FBI,"FBREJ"))
Begin DoDot:2
+3 SET FBSORT=1
DO VET^FBCHDI
DO SET^FBPAY67
End DoDot:2
End DoDot:1
+4 SET (FBVEN,FBNAME)=""
SET (FBDT,FBI)=0
KILL FBIN
+5 FOR
SET FBVEN=$ORDER(^TMP($JOB,"FB",6,FBVEN))
if FBVEN=""!(FBAAOUT)
QUIT
FOR
SET FBNAME=$ORDER(^TMP($JOB,"FB",6,FBVEN,FBNAME))
if FBNAME=""!(FBAAOUT)
QUIT
FOR
SET FBDT=$ORDER(^TMP($JOB,"FB",6,FBVEN,FBNAME,FBDT))
if FBDT'>0!(FBAAOUT)
QUIT
Begin DoDot:1
+6 FOR
SET FBI=$ORDER(^TMP($JOB,"FB",6,FBVEN,FBNAME,FBDT,FBI))
if FBI'>0!(FBAAOUT)
QUIT
Begin DoDot:2
+7 FOR I=1:1:9
SET FBIN(I)=$PIECE(^TMP($JOB,"FB",6,FBVEN,FBNAME,FBDT,FBI),"^",I)
+8 SET FB7078=$SELECT($PIECE(^FBAAI(FBI,0),"^",5)["FB7078":$PIECE($GET(^FB7078(+$PIECE(^FBAAI(FBI,0),"^",5),0)),"^"),1:"")
FOR I=1:1:3
SET FBREJ(I)=$PIECE(^FBAAI(FBI,"FBREJ"),"^",I)
End DoDot:2
DO PRINT
End DoDot:1
END KILL DFN,FB,FBA,FBAAOUT,FBDX,FBI,FBIN,FBLISTC,FBN,FBPROC,FBVEN,FBVID,J,K,L,PGM,Q,QQ,VA,VADM,VAL,VAR,Y,FB7078,FBPROC1,FBREJ,FBINV,^TMP($JOB)
+1 DO CLOSE^FBAAUTL
DO END^FBCHDI
+2 QUIT
PRINT IF $Y+5>IOSL
IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBAAOUT=1
QUIT
+1 IF $Y+5>IOSL
WRITE @IOF
DO HED
+2 ;set by FBPAY67
SET FBINV=^TMP($JOB,"FB",6,FBVEN,FBNAME,FBDT,FBI,"FBINV")
+3 ;If adj code found print it, if not then print suspend code
+4 IF $PIECE(FBINV,U,5)]""
SET FBIN(4)=$PIECE(FBINV,U,5)
+5 WRITE !!,"Vendor: ",$PIECE(FBVEN,";"),?41,"Vendor ID: ",+$PIECE(FBVEN,";",2)
+6 WRITE !,"Patient: ",$PIECE(FBNAME,";"),?41,"Patient ID: ",$$SSN^FBAAUTL($PIECE(FBNAME,";",2))
+7 WRITE !
if FBIN(8)["R"
WRITE "*"
if FBIN(9)]""
WRITE "#"
WRITE ?3,FBIN(1),?23,FBIN(2),?33,FBIN(3),?42,FBIN(4),?49,FBIN(5),?61,FBIN(6),?72,FBIN(7)
+8 ;If FPPS Claim ID exists then print it.
+9 IF $PIECE(FBINV,U,3)]""
Begin DoDot:1
+10 WRITE !?3,"FPPS Claim ID: ",$PIECE(FBINV,U,3)," FPPS Line Item: ",$PIECE(FBINV,U,4)
End DoDot:1
+11 ;FB*3.5*139-ICD10 REMEDIATION-jlg- fixed issue with zero being displayed in DX field. Modified next line.
+12 WRITE !?3,"DX: ",$PIECE($PIECE($GET(^TMP($JOB,"FB",6,FBVEN,FBNAME,FBDT,FBI,"DX")),U,1),"/",1)
+13 WRITE !?3,"Associated 7078: ",FB7078,!?3,$SELECT(FBREJ(1)="P":"Rejects Pending!",FBREJ(1)="C":"Rejected!",1:""),?23,"Reject Reason: ",FBREJ(2),!?3,"Old Batch #: ",FBREJ(3)
+14 QUIT
HED WRITE !?18,"CIVIL HOSPITAL REJECTED PAYMENT HISTORY",!?18,QQ
+1 WRITE !!?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)"
+2 WRITE !?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Adj",?49,"Invoice",?61,"From",?73,"To"
+3 WRITE !?23,"Claimed",?35,"Paid",?42,"Code",?53,"Num",?61,"Date",?71,"Date",!,Q
+4 QUIT
