FBCHRR ;AISC/DMK - RE-INITIATE REJECTS FROM PRICER ;1/22/15 12:43
;;3.5;FEE BASIS;**61,108,123,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
DIC S FBTYPE="B9"
W ! S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,15)=""Y""&($P(^(0),U,17)]"""")"_$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"",1:"&($P(^(0),U,5)=DUZ)"),DIC("A")="Select Batch with Pricer Rejects: " D ^DIC
G END:X="^"!(X=""),DIC:Y<0 S FBN=+Y,FBN(0)=Y(0)
I '$D(^FBAAI("AH",FBN)) W !!,*7,"No items rejected for this batch!",! G DIC
DIC1 W !! S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("A")="Select New Batch Number: ",DIC("S")="I $P(^(0),U,3)=FBTYPE&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)=""Y"")&($G(^(""ST""))=""O"")&($P(^(0),U,18)'[""Y"")"
D ^DIC K DIC G DIC:$E(X)="^"!(X=""),DIC1:Y<0 S FBNB=+Y,FBNB(0)=Y(0)
DIC2 W ! S DIC="^FBAAI(",DIC(0)="AEQMZ",DIC("A")="Select Patient: ",D="D",DIC("S")="I $D(^(""FBREJ"")),$P(^(""FBREJ""),U,3)=FBN" D IX^DIC G DIC:$E(X)="^"!(X=""),DIC2:Y<0 S FBI=+Y,FBI(0)=Y(0) G END:'$D(^FBAAI(FBI,0))
S FBLISTC="" D HOME^%ZIS,START^FBCHDI2
;
; enforce separation of duties
S FBDFN=$P(FBI(0),U,4)
S FB7078I=$P(FBI(0),U,5)
S FTP=$S(FB7078I]"":$O(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")
I '$$UOKPAY^FBUTL9(FBDFN,FTP) D G DIC2
. W !!,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP
. W !,"due to separation of duties."
;
ASK S DIR(0)="Y",DIR("A")="Want to re-initiate this payment",DIR("B")="NO" D ^DIR K DIR G END:$D(DIRUT),DIC:'Y
S (DIC,DIE)="^FBAAI(",DIC(0)="AEQM",DA=FBI,DR="20////^S X=FBNB" D ^DIE
K ^FBAAI(FBI,"FBREJ"),^FBAAI("AH",FBN,FBI) S $P(FBNB(0),"^",10)=$P(FBNB(0),"^",10)+1,$P(FBNB(0),"^",11)=$P(FBNB(0),"^",11)+1,$P(FBNB(0),"^",18)="N",^FBAA(161.7,FBNB,0)=FBNB(0)
I '$D(^FBAAI("AH",FBN)) S $P(FBN(0),"^",17)="",^FBAA(161.7,FBN,0)=FBN(0)
I $D(^FBAAI("AH",FBN)) G DIC2
EDIT S DIR(0)="Y",DIR("A")="Want to edit payment now",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y
S FBPRICE=""
;
; FB*3.5*123 - edit inpatient invoice - check for IPAC data for Federal Vendors
I '$$IPACEDIT^FBAAPET1(162.5,FBI,.FBIA,.FBDODINV) G DIC2
;
; get values of FPPS Claim ID and Line Item
S FBFPPSC=$P($G(^FBAAI(FBI,3)),U)
S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2)
; load current adjustment data
D LOADADJ^FBCHFA(FBI_",",.FBADJ)
; save adjustment data prior to edit session in sorted list
S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
; load current remittance remark data
D LOADRR^FBCHFR(FBI_",",.FBRRMK)
; save remittance remarks prior to edit session in sorted list
S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
S LASTDX=$$LAST^FBCHEP1(FBI,"DX"),LASTPROC=$$LAST^FBCHEP1(FBI,"PROC")
S (DIC,DIE)="^FBAAI(",DA=FBI,DR="[FBCH EDIT PAYMENT]"
D G END:$D(DTOUT)
. N ICDVDT,DFN,FB583,FBAAMM1,FBAAPTC,FBCNTRA,FBCNTRP,FBV,FBVEN,FTP
. S ICDVDT=$$FRDTINV^FBCSV1(DA) ; date for files 80 and 80.1 identifier
. ; get variables for call to PPT^FBAACO1
. S FBAAMM1=$P($G(^FBAAI(DA,2)),U,3)
. S FBCNTRP=$P($G(^FBAAI(DA,5)),U,8)
. S FBV=$P($G(^FBAAI(DA,0)),U,3)
. S DFN=$P($G(^FBAAI(DA,0)),U,4)
. S FBAAPTC=$P($G(^FBAAI(DA,0)),U,13)
. S X=$P($G(^FBAAI(DA,0)),U,5)
. S:X[";FB583(" FB583=+X
. S FTP=$S(X]"":+$O(^FBAAA("AG",X,DFN,0)),1:"")
. S FBVEN=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,4),1:"")
. S FBCNTRA=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,22),1:"")
. D ^DIE
; if adjustment data changed then file
I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(FBI_",",.FBADJ)
; if remit remark data changed then file
I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(FBI_",",.FBRRMK)
; remove any gaps in codes
D RMVGAP^FBCHEP1(FBI,1)
END K DIC,D,DA,DIRUT,DR,DTOUT,DUOUT,FBPRICE,VAL,DIE,FBI,FBN,FBNB,FBTYPE,I,POP,X,Y,FBLISTC
K FBFPPSC,FBFPPSL,FBADJ,FBADJL,FBRRMK,FBRRMKL
K LASTDX,LASTPROC,FBIA,FBDODINV
D END^FBCHDI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHRR 3871 printed Apr 09, 2024@21:02:30 Page 2
FBCHRR ;AISC/DMK - RE-INITIATE REJECTS FROM PRICER ;1/22/15 12:43
+1 ;;3.5;FEE BASIS;**61,108,123,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
DIC SET FBTYPE="B9"
+1 WRITE !
SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQMZ"
SET DIC("S")="I $P(^(0),U,15)=""Y""&($P(^(0),U,17)]"""")"_$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"",1:"&($P(^(0),U,5)=DUZ)")
SET DIC("A")="Select Batch with Pricer Rejects: "
DO ^DIC
+2 if X="^"!(X="")
GOTO END
if Y<0
GOTO DIC
SET FBN=+Y
SET FBN(0)=Y(0)
+3 IF '$DATA(^FBAAI("AH",FBN))
WRITE !!,*7,"No items rejected for this batch!",!
GOTO DIC
DIC1 WRITE !!
SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select New Batch Number: "
SET DIC("S")="I $P(^(0),U,3)=FBTYPE&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)=""Y"")&($G(^(""ST""))=""O"")&($P(^(0),U,18)'[""Y"")"
+1 DO ^DIC
KILL DIC
if $EXTRACT(X)="^"!(X="")
GOTO DIC
if Y<0
GOTO DIC1
SET FBNB=+Y
SET FBNB(0)=Y(0)
DIC2 WRITE !
SET DIC="^FBAAI("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Patient: "
SET D="D"
SET DIC("S")="I $D(^(""FBREJ"")),$P(^(""FBREJ""),U,3)=FBN"
DO IX^DIC
if $EXTRACT(X)="^"!(X="")
GOTO DIC
if Y<0
GOTO DIC2
SET FBI=+Y
SET FBI(0)=Y(0)
if '$DATA(^FBAAI(FBI,0))
GOTO END
+1 SET FBLISTC=""
DO HOME^%ZIS
DO START^FBCHDI2
+2 ;
+3 ; enforce separation of duties
+4 SET FBDFN=$PIECE(FBI(0),U,4)
+5 SET FB7078I=$PIECE(FBI(0),U,5)
+6 SET FTP=$SELECT(FB7078I]"":$ORDER(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")
+7 IF '$$UOKPAY^FBUTL9(FBDFN,FTP)
Begin DoDot:1
+8 WRITE !!,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP
+9 WRITE !,"due to separation of duties."
End DoDot:1
GOTO DIC2
+10 ;
ASK SET DIR(0)="Y"
SET DIR("A")="Want to re-initiate this payment"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if 'Y
GOTO DIC
+1 SET (DIC,DIE)="^FBAAI("
SET DIC(0)="AEQM"
SET DA=FBI
SET DR="20////^S X=FBNB"
DO ^DIE
+2 KILL ^FBAAI(FBI,"FBREJ"),^FBAAI("AH",FBN,FBI)
SET $PIECE(FBNB(0),"^",10)=$PIECE(FBNB(0),"^",10)+1
SET $PIECE(FBNB(0),"^",11)=$PIECE(FBNB(0),"^",11)+1
SET $PIECE(FBNB(0),"^",18)="N"
SET ^FBAA(161.7,FBNB,0)=FBNB(0)
+3 IF '$DATA(^FBAAI("AH",FBN))
SET $PIECE(FBN(0),"^",17)=""
SET ^FBAA(161.7,FBN,0)=FBN(0)
+4 IF $DATA(^FBAAI("AH",FBN))
GOTO DIC2
EDIT SET DIR(0)="Y"
SET DIR("A")="Want to edit payment now"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO END
+1 SET FBPRICE=""
+2 ;
+3 ; FB*3.5*123 - edit inpatient invoice - check for IPAC data for Federal Vendors
+4 IF '$$IPACEDIT^FBAAPET1(162.5,FBI,.FBIA,.FBDODINV)
GOTO DIC2
+5 ;
+6 ; get values of FPPS Claim ID and Line Item
+7 SET FBFPPSC=$PIECE($GET(^FBAAI(FBI,3)),U)
+8 SET FBFPPSL=$PIECE($GET(^FBAAI(FBI,3)),U,2)
+9 ; load current adjustment data
+10 DO LOADADJ^FBCHFA(FBI_",",.FBADJ)
+11 ; save adjustment data prior to edit session in sorted list
+12 ; sorted list of original adjustments
SET FBADJL(0)=$$ADJL^FBUTL2(.FBADJ)
+13 ; load current remittance remark data
+14 DO LOADRR^FBCHFR(FBI_",",.FBRRMK)
+15 ; save remittance remarks prior to edit session in sorted list
+16 SET FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
+17 SET LASTDX=$$LAST^FBCHEP1(FBI,"DX")
SET LASTPROC=$$LAST^FBCHEP1(FBI,"PROC")
+18 SET (DIC,DIE)="^FBAAI("
SET DA=FBI
SET DR="[FBCH EDIT PAYMENT]"
+19 Begin DoDot:1
+20 NEW ICDVDT,DFN,FB583,FBAAMM1,FBAAPTC,FBCNTRA,FBCNTRP,FBV,FBVEN,FTP
+21 ; date for files 80 and 80.1 identifier
SET ICDVDT=$$FRDTINV^FBCSV1(DA)
+22 ; get variables for call to PPT^FBAACO1
+23 SET FBAAMM1=$PIECE($GET(^FBAAI(DA,2)),U,3)
+24 SET FBCNTRP=$PIECE($GET(^FBAAI(DA,5)),U,8)
+25 SET FBV=$PIECE($GET(^FBAAI(DA,0)),U,3)
+26 SET DFN=$PIECE($GET(^FBAAI(DA,0)),U,4)
+27 SET FBAAPTC=$PIECE($GET(^FBAAI(DA,0)),U,13)
+28 SET X=$PIECE($GET(^FBAAI(DA,0)),U,5)
+29 if X[";FB583("
SET FB583=+X
+30 SET FTP=$SELECT(X]"":+$ORDER(^FBAAA("AG",X,DFN,0)),1:"")
+31 SET FBVEN=$SELECT(FTP:$PIECE($GET(^FBAAA(DFN,1,FTP,0)),U,4),1:"")
+32 SET FBCNTRA=$SELECT(FTP:$PIECE($GET(^FBAAA(DFN,1,FTP,0)),U,22),1:"")
+33 DO ^DIE
End DoDot:1
if $DATA(DTOUT)
GOTO END
+34 ; if adjustment data changed then file
+35 IF $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0)
DO FILEADJ^FBCHFA(FBI_",",.FBADJ)
+36 ; if remit remark data changed then file
+37 IF $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0)
DO FILERR^FBCHFR(FBI_",",.FBRRMK)
+38 ; remove any gaps in codes
+39 DO RMVGAP^FBCHEP1(FBI,1)
END KILL DIC,D,DA,DIRUT,DR,DTOUT,DUOUT,FBPRICE,VAL,DIE,FBI,FBN,FBNB,FBTYPE,I,POP,X,Y,FBLISTC
+1 KILL FBFPPSC,FBFPPSL,FBADJ,FBADJL,FBRRMK,FBRRMKL
+2 KILL LASTDX,LASTPROC,FBIA,FBDODINV
+3 DO END^FBCHDI
+4 QUIT
