FBAARJP ;AISC/GRR - PRINT REJECTS PENDING ACTION ;12/23/15 15:25
;;3.5;FEE BASIS;**132,165**;JAN 30, 1995;Build 7
;;Per VA Directive 6402, this routine should not be modified.
; ICR# 10103 XLFDT, ICR# 10005 DT^DICRW
D:$D(DT)#10=0 DT^DICRW
; ask batch status to report
S DIR(0)="S^1:CENTRAL FEE ACCEPTED;2:VOUCHERED;3:BOTH"
S DIR("A")="Select batch status to report"
S DIR("B")="BOTH"
D ^DIR K DIR Q:$D(DIRUT)
S FBSTATL=$S(Y=1:"^F^",Y=2:"^V^",1:"^F^V^")
S DIR(0)="D^:DT:EP",DIR("A")="Exclude rejects transmitted before"
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-730),5)
S DIR("?")=" Do not include time.",DIR("?",1)="Enter earliest transmission date for payment to be included on report."
S DIR("?",2)="Response must not be a future date."
D ^DIR K DIR G:$D(DIRUT) END
S FBSTARTD=Y
S VAR="FBSTATL^FBSTARTD",VAL="",PGM="START^FBAARJP"
D ZIS^FBAAUTL G:FBPOP END
START U IO W:$E(IOST,1,2)="C-" @IOF K QQ,B S (Q,UL)="",$P(Q,"=",80)="=",$P(UL,"-",80)="-",(FBAAOUT,CNT,FBINTOT)=0
D MED:$D(^FBAAC("AH")) G END:FBAAOUT D TRAV:$D(^FBAAC("AG")) G END:FBAAOUT D PHARM:$D(^FBAA(162.1,"AF")) G END:FBAAOUT D CHNH:$D(^FBAAI("AH")) G END:FBAAOUT
I 'CNT W !!,*7,"No Rejects Pending!"
END K FBTYPE,FBVDUZ,FBVD,FBPV,CNT,D,I,PGM,Q,UL,VAL,VAR,Y,Z,A1,A2,A3,B,FBAACPT,FBIN,FBNUM,FBRR,FBINTOT,CPTDESC,FBAAOUT,FBVP,J,K,T,X,L,M,N,S,V,VID,XY,ZS,POP,A,B2,FBINOLD
K FBAC,FBAP,FBDX,FBK,FBL,FBPDT,FBPROC,FBSC,FBTD,FBFD,FBSTATL,FBSTARTD,DIRUT
D CLOSE^FBAAUTL Q
MED F B=0:0 S B=$O(^FBAAC("AH",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)),FBSTATL[(U_^("ST")_U),$$DATEOK(B,FBSTARTD) S B(0)=^FBAA(161.7,B,0),FBTYPE=$P(B(0),"^",3),FBNUM=$P(B(0),"^",1),FBVD=$P(B(0),"^",12),FBVDUZ=$P(B(0),"^",16) D MORE
Q
MORE D HED,HED^FBAACCB,HEDB
F J=0:0 S J=$O(^FBAAC("AH",B,J)) Q:J'>0!(FBAAOUT) F K=0:0 S K=$O(^FBAAC("AH",B,J,K)) Q:K'>0!(FBAAOUT) F L=0:0 S L=$O(^FBAAC("AH",B,J,K,L)) Q:L'>0!(FBAAOUT) F M=0:0 S M=$O(^FBAAC("AH",B,J,K,L,M)) Q:M'>0!(FBAAOUT) D SET^FBAACCB,WRITM
Q:FBAAOUT W !,UL,! D ASKH^FBAACCB0:$E(IOST,1,2)["C-"&('$G(FBNNP)) Q:FBAAOUT W:'$G(FBNNP) @IOF
Q
HEDB W !,"Batch Number: ",FBNUM,?22,"Voucher Date: ",$$DATX^FBAAUTL(FBVD),?45,"Voucherer: ",$S(FBVDUZ="":"",$D(^VA(200,FBVDUZ,0)):$P(^(0),"^",1),1:"Unknown"),!
Q
WRITM Q:FBAAOUT S CNT=CNT+1
N FBL,FBTXT
D REJTXT(162.03,M_","_L_","_K_","_J_",",.FBTXT)
S FBL=0 F S FBL=$O(FBTXT(FBL)) Q:'FBL D
. I $Y+3>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HED^FBAACCB
. W !,FBTXT(FBL)
Q
TRAV F B=0:0 S B=$O(^FBAAC("AG",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)),FBSTATL[(U_^("ST")_U),$$DATEOK(B,FBSTARTD) S B(0)=^FBAA(161.7,B,0),FBTYPE=$P(B(0),"^",3),FBNUM=$P(B(0),"^",1),FBVD=$P(B(0),"^",12),FBVDUZ=$P(B(0),"^",16) D TMORE
Q
TMORE D HED,HEDP^FBAACCB0,HEDB
F J=0:0 S J=$O(^FBAAC("AG",B,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AG",B,J,K)) Q:K'>0 S Y(0)=^FBAAC(J,3,K,0) D SETT^FBAACCB0,WRITT
Q:FBAAOUT W !,UL,! D ASKH^FBAACCB0:$E(IOST,1,2)["C-"&('$G(FBNNP)) Q:FBAAOUT W:'$G(FBNNP) @IOF
Q
WRITT S CNT=CNT+1
N FBL,FBTXT
D REJTXT(162.04,K_","_J_",",.FBTXT)
S FBL=0 F S FBL=$O(FBTXT(FBL)) Q:'FBL D
. I $Y+3>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HEDP^FBAACCB0
. W !,FBTXT(FBL)
Q
PHARM F B=0:0 S B=$O(^FBAA(162.1,"AF",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)),FBSTATL[(U_^("ST")_U),$$DATEOK(B,FBSTARTD) S B(0)=^FBAA(161.7,B,0),FBTYPE=$P(B(0),"^",3),FBNUM=$P(B(0),"^",1),FBVD=$P(B(0),"^",12),FBVDUZ=$P(B(0),"^",16) D PMORE
Q
PMORE D HED,HED^FBAACCB,HEDB
F A=0:0 S A=$O(^FBAA(162.1,"AF",B,A)) Q:A'>0!(FBAAOUT) S FBIN=A D SETV^FBAACCB0 F B2=0:0 S B2=$O(^FBAA(162.1,"AF",B,A,B2)) Q:B2'>0!(FBAAOUT) I $D(^FBAA(162.1,A,"RX",B2,0)) S Z(0)=^(0) D MORE^FBAACCB1,WRITP
Q:FBAAOUT W !,UL,! D ASKH^FBAACCB0:$E(IOST,1,2)="C-"&('$G(FBNNP)) Q:FBAAOUT W:'$G(FBNNP) @IOF
Q
WRITP S CNT=CNT+1
N FBL,FBTXT
D REJTXT(162.11,B2_","_A_",",.FBTXT)
S FBL=0 F S FBL=$O(FBTXT(FBL)) Q:'FBL D
. I $Y+3>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HED^FBAACCB
. W !,FBTXT(FBL)
Q
CHNH F B=0:0 S B=$O(^FBAAI("AH",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)),FBSTATL[(U_^("ST")_U),$$DATEOK(B,FBSTARTD) S B(0)=^FBAA(161.7,B,0),FBTYPE=$P(B(0),"^",3),FBNUM=$P(B(0),"^",1),FBVD=$P(B(0),"^",12),FBVDUZ=$P(B(0),"^",16) D CMORE
Q
CMORE D HED,HEDC^FBAACCB1,HEDB
F I=0:0 S I=$O(^FBAAI("AH",B,I)) Q:I'>0!(FBAAOUT) I $D(^FBAAI(I,0)) S Z(0)=^(0) D CMORE^FBAACCB1,WRITC
Q:FBAAOUT W !,UL,! D ASKH^FBAACCB0:$E(IOST,1,2)="C-"&('$G(FBNNP)) Q:FBAAOUT W:'$G(FBNNP) @IOF
Q
WRITC Q:FBAAOUT S CNT=CNT+1
N FBL,FBTXT
D REJTXT(162.5,I_",",.FBTXT)
S FBL=0 F S FBL=$O(FBTXT(FBL)) Q:'FBL D
. I $Y+3>IOSL D ASKH^FBAACCB0:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF D HEDC^FBAACCB1
. W !,FBTXT(FBL)
Q
;
HED ;write header for report if sent to printer
Q:$E(IOST,1,2)="C-"
W !?3,"REJECTS PENDING ACTION - ",$S(FBSTATL["F^V":"CF Accepted & Vouchered",FBSTATL["F":"Central Fee Accepted",FBSTATL["V":"Vouchered",1:"")," Trans Since: ",$$FMTE^XLFDT(FBSTARTD,5),!?3,$E(Q,1,74),!
Q
;
REJTXT(FBFILE,FBIENS,FBTXT) ; get reject text for line item
; input
; FBFILE - (required) Sub-File (162.03, 162.04, 162.1, or 162.5)
; FBIENS - (required) IENS of line item, FileMan DBS format
; FBTXT - array passed by reference, will be initialzed
; output
; FBTXT - array of text with format
; FBTXT(0)=count of lines
; FBTXT(#)=line of text
; where # is sequential number starting at 1
;
N FBC,FBD,FBFIELDS,FBLST,FBRIENS
K FBTXT
S (FBC,FBTXT(0))=0
; check inputs
Q:"^162.03^162.04^162.11^162.5^"'[("^"_$G(FBFILE)_"^")
Q:$G(FBIENS)=""
;
; determine field numbers based on file
; FBFIELDS will contain the numbers of the following fields/sub-file
; piece 1 = batch number
; piece 2 = amount paid
; piece 3 = reject status
; piece 4 = reject reason
; piece 5 = old batch number
; piece 6 = interface reject
; piece 7 = reject code
; piece 8 = reject code sub-file number
I FBFILE="162.03" S FBFIELDS="7^2^19^20^21^21.3^21.6^162.031"
I FBFILE="162.04" S FBFIELDS="1^2^4^5^6^6.3^6.6^162.041"
I FBFILE="162.11" S FBFIELDS="13^6.5^17^18^19^19.3^19.6^162.111"
I FBFILE="162.5" S FBFIELDS="20^8^13^14^15^15.3^15.6^162.515"
;
S FBD(5)=$$GET1^DIQ(FBFILE,FBIENS,$P(FBFIELDS,"^",5)) ; old batch
Q:FBD(5)="" ; line is not rejected
S FBD(6)=$$GET1^DIQ(FBFILE,FBIENS,$P(FBFIELDS,"^",6),"I") ; inter. rej.
;
; 1st line
S FBC=FBC+1
S FBTXT(FBC)=$$LJ^XLFSTR($S(FBD(6):"Central Fee",1:"Local")_" Reject",20)_"Old Batch #: "_FBD(5)
;
; line for reject reason (if any)
S FBD(4)=$$GET1^DIQ(FBFILE,FBIENS,$P(FBFIELDS,"^",4)) ; reject reason
I FBD(4)]"" S FBC=FBC+1,FBTXT(FBC)="Reject Reason: "_FBD(4)
;
; lines for reject codes (if any)
; get list of entries in REJECT CODE multiple
D GETS^DIQ(FBFILE,FBIENS,$P(FBFIELDS,"^",7)_"*","","FBLST")
;
; loop thru REJECT CODE entries
S FBRIENS=""
F S FBRIENS=$O(FBLST($P(FBFIELDS,"^",8),FBRIENS)) Q:FBRIENS="" D
. N FBARR,FBRC,FBLI
. S FBRC=FBLST($P(FBFIELDS,"^",8),FBRIENS,.01) ; REJECT CODE
. Q:FBRC=""
. ; get description of code from file 161.99
. D RCDES(FBRC,,.FBARR)
. ;
. ; add code and first line of description to output array
. S FBC=FBC+1
. S FBTXT(FBC)=$$LJ^XLFSTR("Rej Code: "_FBRC,16)
. I $D(FBARR(1,0)) S FBTXT(FBC)=FBTXT(FBC)_FBARR(1,0)
. ;
. ; loop thru remaining description lines
. S FBLI=1 F S FBLI=$O(FBARR(FBLI)) Q:'FBLI D
. . Q:'$D(FBARR(FBLI,0))
. . ; add description line to output array
. . S FBC=FBC+1
. . S FBTXT(FBC)=" "_FBARR(FBLI,0)
;
S FBTXT(0)=FBC
Q
;
RCDES(FBRC,FBRM,FBARR) ; Reject Code Description
; input
; FBRC - reject code external value
; FBRM - (optional) right margin, default 60
; FBARR - array, passed by reference, not FBWP, will be initialized
; output
; FBARR - array contained formatted description
; where
; FBARR(0)=line count
; FBARR(1,0)=1st line of description
; FBARR(2,0)=2nd line of description
;
; note: some variables newed because DIWP call is stepping on I
N A,B,DIWL,DIWR,DIWF,FBI,FBRCI,FBWP,FBX,I,J,K,L,M
;
S FBRM=$G(FBRM,60)
K FBARR
Q:$G(FBRC)=""
;
; find IEN of code
S FBRCI=$$FIND1^DIC(161.99,,"X",FBRC)
;
; if entry found then load description from file
S:FBRCI FBX=$$GET1^DIQ(161.99,FBRCI_",",1,"","FBWP")
; if entry not found use default description
S:'FBRCI FBWP(1)="Reject reason code is not currently defined in list."
;
; reformat description
K ^UTILITY($J,"W")
S DIWL=1,DIWR=FBRM,DIWF=""
S FBI=0 F S FBI=$O(FBWP(FBI)) Q:'FBI S X=FBWP(FBI) D ^DIWP
;
; move description into output array
M FBARR=^UTILITY($J,"W",DIWL)
;
K ^UTILITY($J,"W")
Q
;
DATEOK(FBATID,FBSTART) ;Compares batch transmission date to start date
; Returns 0 if transmission date earlier than start date
; Returns 1 if transmission date equals or is later
N FBX,FBY
Q:FBATID'>0 0 Q:FBSTART="" 0
S FBY=$P($P($G(^FBAA(161.7,FBATID,0)),U,14),".")
S FBX=$S(FBY="":1,FBY<FBSTART:0,1:1)
Q FBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAARJP 9159 printed Dec 13, 2024@01:56:25 Page 2
FBAARJP ;AISC/GRR - PRINT REJECTS PENDING ACTION ;12/23/15 15:25
+1 ;;3.5;FEE BASIS;**132,165**;JAN 30, 1995;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; ICR# 10103 XLFDT, ICR# 10005 DT^DICRW
+4 if $DATA(DT)#10=0
DO DT^DICRW
+5 ; ask batch status to report
+6 SET DIR(0)="S^1:CENTRAL FEE ACCEPTED;2:VOUCHERED;3:BOTH"
+7 SET DIR("A")="Select batch status to report"
+8 SET DIR("B")="BOTH"
+9 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+10 SET FBSTATL=$SELECT(Y=1:"^F^",Y=2:"^V^",1:"^F^V^")
+11 SET DIR(0)="D^:DT:EP"
SET DIR("A")="Exclude rejects transmitted before"
+12 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-730),5)
+13 SET DIR("?")=" Do not include time."
SET DIR("?",1)="Enter earliest transmission date for payment to be included on report."
+14 SET DIR("?",2)="Response must not be a future date."
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
+16 SET FBSTARTD=Y
+17 SET VAR="FBSTATL^FBSTARTD"
SET VAL=""
SET PGM="START^FBAARJP"
+18 DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
KILL QQ,B
SET (Q,UL)=""
SET $PIECE(Q,"=",80)="="
SET $PIECE(UL,"-",80)="-"
SET (FBAAOUT,CNT,FBINTOT)=0
+1 if $DATA(^FBAAC("AH"))
DO MED
if FBAAOUT
GOTO END
if $DATA(^FBAAC("AG"))
DO TRAV
if FBAAOUT
GOTO END
if $DATA(^FBAA(162.1,"AF"))
DO PHARM
if FBAAOUT
GOTO END
if $DATA(^FBAAI("AH"))
DO CHNH
if FBAAOUT
GOTO END
+2 IF 'CNT
WRITE !!,*7,"No Rejects Pending!"
END KILL FBTYPE,FBVDUZ,FBVD,FBPV,CNT,D,I,PGM,Q,UL,VAL,VAR,Y,Z,A1,A2,A3,B,FBAACPT,FBIN,FBNUM,FBRR,FBINTOT,CPTDESC,FBAAOUT,FBVP,J,K,T,X,L,M,N,S,V,VID,XY,ZS,POP,A,B2,FBINOLD
+1 KILL FBAC,FBAP,FBDX,FBK,FBL,FBPDT,FBPROC,FBSC,FBTD,FBFD,FBSTATL,FBSTARTD,DIRUT
+2 DO CLOSE^FBAAUTL
QUIT
MED FOR B=0:0
SET B=$ORDER(^FBAAC("AH",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
IF FBSTATL[(U_^("ST")_U)
IF $$DATEOK(B,FBSTARTD)
SET B(0)=^FBAA(161.7,B,0)
SET FBTYPE=$PIECE(B(0),"^",3)
SET FBNUM=$PIECE(B(0),"^",1)
SET FBVD=$PIECE(B(0),"^",12)
SET FBVDUZ=$PIECE(B(0),"^",16)
DO MORE
+1 QUIT
MORE DO HED
DO HED^FBAACCB
DO HEDB
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("AH",B,J))
if J'>0!(FBAAOUT)
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AH",B,J,K))
if K'>0!(FBAAOUT)
QUIT
FOR L=0:0
SET L=$ORDER(^FBAAC("AH",B,J,K,L))
if L'>0!(FBAAOUT)
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC("AH",B,J,K,L,M))
if M'>0!(FBAAOUT)
QUIT
DO SET^FBAACCB
DO WRITM
+2 if FBAAOUT
QUIT
WRITE !,UL,!
if $EXTRACT(IOST,1,2)["C-"&('$GET(FBNNP))
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
if '$GET(FBNNP)
WRITE @IOF
+3 QUIT
HEDB WRITE !,"Batch Number: ",FBNUM,?22,"Voucher Date: ",$$DATX^FBAAUTL(FBVD),?45,"Voucherer: ",$SELECT(FBVDUZ="":"",$DATA(^VA(200,FBVDUZ,0)):$PIECE(^(0),"^",1),1:"Unknown"),!
+1 QUIT
WRITM if FBAAOUT
QUIT
SET CNT=CNT+1
+1 NEW FBL,FBTXT
+2 DO REJTXT(162.03,M_","_L_","_K_","_J_",",.FBTXT)
+3 SET FBL=0
FOR
SET FBL=$ORDER(FBTXT(FBL))
if 'FBL
QUIT
Begin DoDot:1
+4 IF $Y+3>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
WRITE @IOF
DO HED^FBAACCB
+5 WRITE !,FBTXT(FBL)
End DoDot:1
+6 QUIT
TRAV FOR B=0:0
SET B=$ORDER(^FBAAC("AG",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
IF FBSTATL[(U_^("ST")_U)
IF $$DATEOK(B,FBSTARTD)
SET B(0)=^FBAA(161.7,B,0)
SET FBTYPE=$PIECE(B(0),"^",3)
SET FBNUM=$PIECE(B(0),"^",1)
SET FBVD=$PIECE(B(0),"^",12)
SET FBVDUZ=$PIECE(B(0),"^",16)
DO TMORE
+1 QUIT
TMORE DO HED
DO HEDP^FBAACCB0
DO HEDB
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("AG",B,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AG",B,J,K))
if K'>0
QUIT
SET Y(0)=^FBAAC(J,3,K,0)
DO SETT^FBAACCB0
DO WRITT
+2 if FBAAOUT
QUIT
WRITE !,UL,!
if $EXTRACT(IOST,1,2)["C-"&('$GET(FBNNP))
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
if '$GET(FBNNP)
WRITE @IOF
+3 QUIT
WRITT SET CNT=CNT+1
+1 NEW FBL,FBTXT
+2 DO REJTXT(162.04,K_","_J_",",.FBTXT)
+3 SET FBL=0
FOR
SET FBL=$ORDER(FBTXT(FBL))
if 'FBL
QUIT
Begin DoDot:1
+4 IF $Y+3>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
WRITE @IOF
DO HEDP^FBAACCB0
+5 WRITE !,FBTXT(FBL)
End DoDot:1
+6 QUIT
PHARM FOR B=0:0
SET B=$ORDER(^FBAA(162.1,"AF",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
IF FBSTATL[(U_^("ST")_U)
IF $$DATEOK(B,FBSTARTD)
SET B(0)=^FBAA(161.7,B,0)
SET FBTYPE=$PIECE(B(0),"^",3)
SET FBNUM=$PIECE(B(0),"^",1)
SET FBVD=$PIECE(B(0),"^",12)
SET FBVDUZ=$PIECE(B(0),"^",16)
DO PMORE
+1 QUIT
PMORE DO HED
DO HED^FBAACCB
DO HEDB
+1 FOR A=0:0
SET A=$ORDER(^FBAA(162.1,"AF",B,A))
if A'>0!(FBAAOUT)
QUIT
SET FBIN=A
DO SETV^FBAACCB0
FOR B2=0:0
SET B2=$ORDER(^FBAA(162.1,"AF",B,A,B2))
if B2'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(162.1,A,"RX",B2,0))
SET Z(0)=^(0)
DO MORE^FBAACCB1
DO WRITP
+2 if FBAAOUT
QUIT
WRITE !,UL,!
if $EXTRACT(IOST,1,2)="C-"&('$GET(FBNNP))
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
if '$GET(FBNNP)
WRITE @IOF
+3 QUIT
WRITP SET CNT=CNT+1
+1 NEW FBL,FBTXT
+2 DO REJTXT(162.11,B2_","_A_",",.FBTXT)
+3 SET FBL=0
FOR
SET FBL=$ORDER(FBTXT(FBL))
if 'FBL
QUIT
Begin DoDot:1
+4 IF $Y+3>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
WRITE @IOF
DO HED^FBAACCB
+5 WRITE !,FBTXT(FBL)
End DoDot:1
+6 QUIT
CHNH FOR B=0:0
SET B=$ORDER(^FBAAI("AH",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
IF FBSTATL[(U_^("ST")_U)
IF $$DATEOK(B,FBSTARTD)
SET B(0)=^FBAA(161.7,B,0)
SET FBTYPE=$PIECE(B(0),"^",3)
SET FBNUM=$PIECE(B(0),"^",1)
SET FBVD=$PIECE(B(0),"^",12)
SET FBVDUZ=$PIECE(B(0),"^",16)
DO CMORE
+1 QUIT
CMORE DO HED
DO HEDC^FBAACCB1
DO HEDB
+1 FOR I=0:0
SET I=$ORDER(^FBAAI("AH",B,I))
if I'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAAI(I,0))
SET Z(0)=^(0)
DO CMORE^FBAACCB1
DO WRITC
+2 if FBAAOUT
QUIT
WRITE !,UL,!
if $EXTRACT(IOST,1,2)="C-"&('$GET(FBNNP))
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
if '$GET(FBNNP)
WRITE @IOF
+3 QUIT
WRITC if FBAAOUT
QUIT
SET CNT=CNT+1
+1 NEW FBL,FBTXT
+2 DO REJTXT(162.5,I_",",.FBTXT)
+3 SET FBL=0
FOR
SET FBL=$ORDER(FBTXT(FBL))
if 'FBL
QUIT
Begin DoDot:1
+4 IF $Y+3>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO ASKH^FBAACCB0
if FBAAOUT
QUIT
WRITE @IOF
DO HEDC^FBAACCB1
+5 WRITE !,FBTXT(FBL)
End DoDot:1
+6 QUIT
+7 ;
HED ;write header for report if sent to printer
+1 if $EXTRACT(IOST,1,2)="C-"
QUIT
+2 WRITE !?3,"REJECTS PENDING ACTION - ",$SELECT(FBSTATL["F^V":"CF Accepted & Vouchered",FBSTATL["F":"Central Fee Accepted",FBSTATL["V":"Vouchered",1:"")," Trans Since: ",$$FMTE^XLFDT(FBSTARTD,5),!?3,$EXTRACT(Q,1,74),!
+3 QUIT
+4 ;
REJTXT(FBFILE,FBIENS,FBTXT) ; get reject text for line item
+1 ; input
+2 ; FBFILE - (required) Sub-File (162.03, 162.04, 162.1, or 162.5)
+3 ; FBIENS - (required) IENS of line item, FileMan DBS format
+4 ; FBTXT - array passed by reference, will be initialzed
+5 ; output
+6 ; FBTXT - array of text with format
+7 ; FBTXT(0)=count of lines
+8 ; FBTXT(#)=line of text
+9 ; where # is sequential number starting at 1
+10 ;
+11 NEW FBC,FBD,FBFIELDS,FBLST,FBRIENS
+12 KILL FBTXT
+13 SET (FBC,FBTXT(0))=0
+14 ; check inputs
+15 if "^162.03^162.04^162.11^162.5^"'[("^"_$GET(FBFILE)_"^")
QUIT
+16 if $GET(FBIENS)=""
QUIT
+17 ;
+18 ; determine field numbers based on file
+19 ; FBFIELDS will contain the numbers of the following fields/sub-file
+20 ; piece 1 = batch number
+21 ; piece 2 = amount paid
+22 ; piece 3 = reject status
+23 ; piece 4 = reject reason
+24 ; piece 5 = old batch number
+25 ; piece 6 = interface reject
+26 ; piece 7 = reject code
+27 ; piece 8 = reject code sub-file number
+28 IF FBFILE="162.03"
SET FBFIELDS="7^2^19^20^21^21.3^21.6^162.031"
+29 IF FBFILE="162.04"
SET FBFIELDS="1^2^4^5^6^6.3^6.6^162.041"
+30 IF FBFILE="162.11"
SET FBFIELDS="13^6.5^17^18^19^19.3^19.6^162.111"
+31 IF FBFILE="162.5"
SET FBFIELDS="20^8^13^14^15^15.3^15.6^162.515"
+32 ;
+33 ; old batch
SET FBD(5)=$$GET1^DIQ(FBFILE,FBIENS,$PIECE(FBFIELDS,"^",5))
+34 ; line is not rejected
if FBD(5)=""
QUIT
+35 ; inter. rej.
SET FBD(6)=$$GET1^DIQ(FBFILE,FBIENS,$PIECE(FBFIELDS,"^",6),"I")
+36 ;
+37 ; 1st line
+38 SET FBC=FBC+1
+39 SET FBTXT(FBC)=$$LJ^XLFSTR($SELECT(FBD(6):"Central Fee",1:"Local")_" Reject",20)_"Old Batch #: "_FBD(5)
+40 ;
+41 ; line for reject reason (if any)
+42 ; reject reason
SET FBD(4)=$$GET1^DIQ(FBFILE,FBIENS,$PIECE(FBFIELDS,"^",4))
+43 IF FBD(4)]""
SET FBC=FBC+1
SET FBTXT(FBC)="Reject Reason: "_FBD(4)
+44 ;
+45 ; lines for reject codes (if any)
+46 ; get list of entries in REJECT CODE multiple
+47 DO GETS^DIQ(FBFILE,FBIENS,$PIECE(FBFIELDS,"^",7)_"*","","FBLST")
+48 ;
+49 ; loop thru REJECT CODE entries
+50 SET FBRIENS=""
+51 FOR
SET FBRIENS=$ORDER(FBLST($PIECE(FBFIELDS,"^",8),FBRIENS))
if FBRIENS=""
QUIT
Begin DoDot:1
+52 NEW FBARR,FBRC,FBLI
+53 ; REJECT CODE
SET FBRC=FBLST($PIECE(FBFIELDS,"^",8),FBRIENS,.01)
+54 if FBRC=""
QUIT
+55 ; get description of code from file 161.99
+56 DO RCDES(FBRC,,.FBARR)
+57 ;
+58 ; add code and first line of description to output array
+59 SET FBC=FBC+1
+60 SET FBTXT(FBC)=$$LJ^XLFSTR("Rej Code: "_FBRC,16)
+61 IF $DATA(FBARR(1,0))
SET FBTXT(FBC)=FBTXT(FBC)_FBARR(1,0)
+62 ;
+63 ; loop thru remaining description lines
+64 SET FBLI=1
FOR
SET FBLI=$ORDER(FBARR(FBLI))
if 'FBLI
QUIT
Begin DoDot:2
+65 if '$DATA(FBARR(FBLI,0))
QUIT
+66 ; add description line to output array
+67 SET FBC=FBC+1
+68 SET FBTXT(FBC)=" "_FBARR(FBLI,0)
End DoDot:2
End DoDot:1
+69 ;
+70 SET FBTXT(0)=FBC
+71 QUIT
+72 ;
RCDES(FBRC,FBRM,FBARR) ; Reject Code Description
+1 ; input
+2 ; FBRC - reject code external value
+3 ; FBRM - (optional) right margin, default 60
+4 ; FBARR - array, passed by reference, not FBWP, will be initialized
+5 ; output
+6 ; FBARR - array contained formatted description
+7 ; where
+8 ; FBARR(0)=line count
+9 ; FBARR(1,0)=1st line of description
+10 ; FBARR(2,0)=2nd line of description
+11 ;
+12 ; note: some variables newed because DIWP call is stepping on I
+13 NEW A,B,DIWL,DIWR,DIWF,FBI,FBRCI,FBWP,FBX,I,J,K,L,M
+14 ;
+15 SET FBRM=$GET(FBRM,60)
+16 KILL FBARR
+17 if $GET(FBRC)=""
QUIT
+18 ;
+19 ; find IEN of code
+20 SET FBRCI=$$FIND1^DIC(161.99,,"X",FBRC)
+21 ;
+22 ; if entry found then load description from file
+23 if FBRCI
SET FBX=$$GET1^DIQ(161.99,FBRCI_",",1,"","FBWP")
+24 ; if entry not found use default description
+25 if 'FBRCI
SET FBWP(1)="Reject reason code is not currently defined in list."
+26 ;
+27 ; reformat description
+28 KILL ^UTILITY($JOB,"W")
+29 SET DIWL=1
SET DIWR=FBRM
SET DIWF=""
+30 SET FBI=0
FOR
SET FBI=$ORDER(FBWP(FBI))
if 'FBI
QUIT
SET X=FBWP(FBI)
DO ^DIWP
+31 ;
+32 ; move description into output array
+33 MERGE FBARR=^UTILITY($JOB,"W",DIWL)
+34 ;
+35 KILL ^UTILITY($JOB,"W")
+36 QUIT
+37 ;
DATEOK(FBATID,FBSTART) ;Compares batch transmission date to start date
+1 ; Returns 0 if transmission date earlier than start date
+2 ; Returns 1 if transmission date equals or is later
+3 NEW FBX,FBY
+4 if FBATID'>0
QUIT 0
if FBSTART=""
QUIT 0
+5 SET FBY=$PIECE($PIECE($GET(^FBAA(161.7,FBATID,0)),U,14),".")
+6 SET FBX=$SELECT(FBY="":1,FBY<FBSTART:0,1:1)
+7 QUIT FBX
