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