FBSVBR ;ISW/SAB - PAYMENT BATCH RESULT MESSAGE SERVER ;5/8/2012
;;3.5;FEE BASIS;**131,132,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine is called by a server option to process the
; Payment Batch Result message sent by Central Fee.
;
; ICRs
; #2053 FILE^DIE
; #2054 CLEAN^DILF
; #2056 $$GET1^DIQ
; #10069 XMB
; #10072 REMSBMSG^XMA1C
; #10096 ^%ZOSF("ERRTN" ), ^%ZOSF("TRAP")
; #10103 $$FMTE^XLFDT, $$NOW^XLFDT
; #10104 $$TRIM^XLFSTR
;
; init
N FBBAMT,FBERR,FBHL,FBN,FBSN,FBSTAT,FBTYPE,X,XMER,XMRG,FBNEW
S FBERR=0
;
; switch to a Fee Basis server error trap
S X="TRAP^FBMRASV2" S @^%ZOSF("TRAP")
;
HDR ; process header line
X XMREC
I XMER<0 D ERR("Error reading header line.")
I FBERR G END
I $E(XMRG,2,4)="FEB" G HDR ; skip initial line if just envelope data
;
;FB*3.5*158
I $L(XMRG)=33 S FBNEW=0 ;six digit batch number
E I $L(XMRG)=34 S FBNEW=1 ;seven digit batch number
E D ERR("Header line has incorrect length.")
I FBERR G END
;
; extract data from header line
S FBHL(1)=$$TRIM^XLFSTR($E(XMRG,1,6),"R") ; station number
S FBHL(2)=$E(XMRG,7,14) ; date YYYYMMDD
S FBHL(3)=$E(XMRG,15) ; processing stage (R)
S FBHL(4)=$E(XMRG,16) ; payment type (3, 5, 9, or T)
;FB*3.5*158
I FBNEW D ;7 digit batch number
. S FBHL(5)=+$E(XMRG,17,23)
. S FBHL(6)=$$TRIM^XLFSTR($E(XMRG,24,27)) ; batch reject code
. S FBHL(7)=+$E(XMRG,28,30) ; number accepted
. S FBHL(8)=+$E(XMRG,31,33) ; number rejected
. S FBHL(9)=$E(XMRG,34) ; delimiter ($)
E D ;6 digit batch number
. S FBHL(5)=+$E(XMRG,17,22)
. S FBHL(6)=$$TRIM^XLFSTR($E(XMRG,23,26)) ; batch reject code
. S FBHL(7)=+$E(XMRG,27,29) ; number accepted
. S FBHL(8)=+$E(XMRG,30,32) ; number rejected
. S FBHL(9)=$E(XMRG,33) ; delimiter ($)
;
; validate header data
I FBHL(3)'="R" D ERR("Processing stage ("_FBHL(3)_") is invalid.")
I "^3^5^9^T^"'[("^"_FBHL(4)_"^") D ERR("Payment type ("_FBHL(4)_") is invalid.")
I FBERR G END
;
; determine batch IEN
S FBN=$O(^FBAA(161.7,"B",FBHL(5),0))
I 'FBN D ERR("Could not locate record for batch "_FBHL(5)_".")
I FBERR G END
;
; obtain batch data
S FBTYPE=$$GET1^DIQ(161.7,FBN_",",2,"I") ; type (internal)
S FBSTAT=$$GET1^DIQ(161.7,FBN_",",11,"I") ; status (internal)
S FBSN=$$GET1^DIQ(161.7,FBN_",",16) ; station number (3 digit)
;
; verify batch values
I FBHL(4)="T",FBTYPE'="B2" D ERR("Payment Type in message is not consistent with the batch type.")
I FBHL(4),FBHL(4)'=$E(FBTYPE,2) D ERR("Payment Type in message is not consistent with the batch type.")
I FBSN'=$E(FBHL(1),1,3) D ERR("Station number in message is not consistent with the batch station number.")
I FBSTAT'="T" D ERR("Current batch status is not TRANSMITTED.")
I FBERR G END
;
S FBBAMT=0 ; init dollar amount for posting to 1358 by batch
;
; if batch reject code sent then reject entire batch
I FBHL(6)'="" D
. N FBIEN,FBIENS,FBRCA
. S FBRCA(1)=FBHL(6) ; reject code array
. ;
. ; loop thru line items in batch
. I FBTYPE="B2" D
. . S FBIEN(1)=0
. . F S FBIEN(1)=$O(^FBAAC("AD",FBN,FBIEN(1))) Q:'FBIEN(1) D
. . . S FBIEN=0
. . . F S FBIEN=$O(^FBAAC("AD",FBN,FBIEN(1),FBIEN)) Q:'FBIEN D
. . . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . . . D REJLN
. ;
. I FBTYPE="B3" D
. . S FBIEN(3)=0
. . F S FBIEN(3)=$O(^FBAAC("AC",FBN,FBIEN(3))) Q:'FBIEN(3) D
. . . S FBIEN(2)=0
. . . F S FBIEN(2)=$O(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2))) Q:'FBIEN(2) D
. . . . S FBIEN(1)=0
. . . . F S FBIEN(1)=$O(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2),FBIEN(1))) Q:'FBIEN(1) D
. . . . . S FBIEN=0
. . . . . F S FBIEN=$O(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2),FBIEN(1),FBIEN)) Q:'FBIEN D
. . . . . . S FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
. . . . . . D REJLN
. ;
. I FBTYPE="B5" D
. . S FBIEN(1)=0
. . F S FBIEN(1)=$O(^FBAA(162.1,"AE",FBN,FBIEN(1))) Q:'FBIEN(1) D
. . . S FBIEN=0
. . . F S FBIEN=$O(^FBAA(162.1,"AE",FBN,FBIEN(1),FBIEN)) Q:'FBIEN D
. . . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . . . D REJLN
. ;
. I FBTYPE="B9" D
. . S FBIEN=0
. . F S FBIEN=$O(^FBAAI("AC",FBN,FBIEN)) Q:'FBIEN D
. . . S FBIENS=FBIEN_","
. . . D REJLN
;
; if batch reject code not sent then process line rejects (if any)
I FBHL(6)="" D
. ; loop thru detail lines in message
. F X XMREC Q:XMER<0!($E(XMRG,1,4)="NNNN") I XMRG]"" D
. . N FBI,FBJ,FBIEN,FBIENS,FBRCA,FBX
. . ; determine the reject codes for the line item
. . S FBJ=0 ; init number of reject codes for line item
. . ; loop thru the five data elements that can hold a reject code
. . F FBI=1:1:5 D
. . . N FBP
. . . S FBP=$S(FBNEW:54,1:53)+((FBI-1)*4) ; calc data element starting position
. . . S FBX=$$TRIM^XLFSTR($E(XMRG,FBP,FBP+3))
. . . I FBX'="" S FBJ=FBJ+1,FBRCA(FBJ)=FBX ; add to array
. . ;
. . ; determine the IENs for the line item
. . S FBX=$E(XMRG,$S(FBNEW:24,1:23),$S(FBNEW:53,1:52)) ; IEN string
. . I FBTYPE="B2" D
. . . S FBIEN(1)=+$P(FBX,U),FBIEN=+$P(FBX,U,2)
. . . ; if line item not found then check if moved
. . . I '$D(^FBAAC(FBIEN(1),3,FBIEN,0)) D
. . . . N FBPROG
. . . . S FBPROG="T"
. . . . D CHKMOVE^FBPAID1
. . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . ;
. . I FBTYPE="B3" D
. . . S FBIEN(3)=+$P(FBX,U),FBIEN(2)=+$P(FBX,U,2)
. . . S FBIEN(1)=+$P(FBX,U,3),FBIEN=+$P(FBX,U,4)
. . . ; if line item not found then check if moved
. . . I '$D(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0)) D
. . . . N FBPROG
. . . . S FBPROG=3
. . . . D CHKMOVE^FBPAID1
. . . S FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
. . ;
. . I FBTYPE="B5" D
. . . S FBIEN(1)=+$P(FBX,U),FBIEN=+$P(FBX,U,2)
. . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . ;
. . I FBTYPE="B9" D
. . . S FBIEN=+FBX
. . . S FBIENS=FBIEN_","
. . ;
. . ; call to reject the line item
. . D REJLN
;
; update obligation for rejected lines posted by batch
I FBBAMT>0 D
. N FBX
. S FBX=$$POSTBAT^FB1358(FBN,FBBAMT,"R",1)
. I 'FBX D
. . D ERR("Error posting to 1358 for batch")
. . D ERR(" "_$P(FBX,"^",2))
;
; update batch status
I FBN D
. N DIERR,FBFDA,FBX
. S FBX="F" ; init new status as Central Fee Accepted
. ; if no lines remain in batch change new status to Vouchered
. I FBTYPE="B2",'$O(^FBAAC("AD",FBN,0)) S FBX="V"
. I FBTYPE="B3",'$O(^FBAAC("AC",FBN,0)) S FBX="V"
. I FBTYPE="B5",'$O(^FBAA(162.1,"AE",FBN,0)) S FBX="V"
. I FBTYPE="B9",'$O(^FBAAI("AC",FBN,0)) S FBX="V"
. S FBFDA(161.7,FBN_",",11)=FBX
. I FBX="V" D
. . S FBFDA(161.7,FBN_",",13)=DT ; DATE FINALIZED
. . S FBFDA(161.7,FBN_",",14)=DUZ ; PERSON WHO COMPLETED
. D FILE^DIE("","FBFDA")
. D CLEAN^DILF
;
END ;
; switch back to the standard Kernel error trap
S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
;
; remove Central Fee message from server basket
N XMSER,XMZ
S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
;
I FBERR D
. ; add text to bulletin
. D ERR(" ")
. D ERR("The above message # has been forwarded to the FEE mail group.")
. ;
. ; send bulletin
. D SNDBUL("for batch "_$G(FBHL(5))_" results")
. ;
. ; forward served message to G.FEE
. N XMDUZ,XMY,XMZ
. S XMY("G.FEE")=""
. S XMZ=XQMSG
. D ENT1^XMD
;
K XQSTXT
Q
;
ERR(FBTXT) ; set error flag and save text for inclusion in bulletin
N FBL
S FBERR=1
S FBL=$P($G(XQSTXT(0)),"^",4)
S FBL=FBL+1
S XQSTXT(FBL)=$G(FBTXT)
S $P(XQSTXT(0),"^",3,4)=FBL_"^"_FBL
Q
;
REJLN ; reject payment line item
N FBX
; set reject flag
S FBX=$$SETREJ^FBAAVR4(FBN,FBTYPE,FBIENS,1,,.FBRCA)
;
; if problem
I 'FBX D
. D ERR("Error rejecting line with IENS "_FBIENS)
. D ERR(" "_$P(FBX,"^",2))
;
; if success
I FBX D
. N FBPBYINV
. ; determine if 1358 posted by invoice or batch
. S FBPBYINV=0
. I FBTYPE="B9",$$GET1^DIQ(162.5,FBIENS,4,"I")'["FB583" S FBPBYINV=1
. ;
. ; if by batch then accumulate amount for later posting
. I 'FBPBYINV S FBBAMT=FBBAMT+$P(FBX,"^",3)
. ;
. ; if by B9 invoice then post it now
. I FBPBYINV D
. . N FBX1
. . S FBX1=$$POSTINV^FB1358(FBN,+FBIENS,"R",1)
. . I 'FBX1 D
. . . D ERR("Error posting invoice "_+FBIENS_" to 1358")
. . . D ERR(" "_$P(FBX1,"^",2))
Q
;
SNDBUL(FBSUB) ; send bulletin
;
N XMB,XMBTMP,XMDF,XMDT,XMDUZ,XMTEXT,XMY,XMYBLOB
S XMB="FBAA SERVER"
S XMB(1)=$$FMTE^XLFDT($$NOW^XLFDT) ; date/time
S XMB(2)=$G(XQSND) ; sender of message sent to server option
S XMB(3)=$G(XQSOP) ; server option
S XMB(4)=$G(XQSUB) ; subject of message sent to server option
S XMB(5)=$G(XQMSG) ; number of message sent to server option
S XMB(6)="An issue occurred that requires notification." ; comment
S XMB(7)=$G(FBSUB) ; optional text for bulletin message subject
S:$O(XQSTXT(0)) XMTEXT="XQSTXT(" ; additional text
S XMY("G.FEE")=""
S XMY("G.FEE FINANCE")=""
D ^XMB
Q
;FBSVBR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBSVBR 8957 printed Nov 22, 2024@17:10:09 Page 2
FBSVBR ;ISW/SAB - PAYMENT BATCH RESULT MESSAGE SERVER ;5/8/2012
+1 ;;3.5;FEE BASIS;**131,132,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine is called by a server option to process the
+5 ; Payment Batch Result message sent by Central Fee.
+6 ;
+7 ; ICRs
+8 ; #2053 FILE^DIE
+9 ; #2054 CLEAN^DILF
+10 ; #2056 $$GET1^DIQ
+11 ; #10069 XMB
+12 ; #10072 REMSBMSG^XMA1C
+13 ; #10096 ^%ZOSF("ERRTN" ), ^%ZOSF("TRAP")
+14 ; #10103 $$FMTE^XLFDT, $$NOW^XLFDT
+15 ; #10104 $$TRIM^XLFSTR
+16 ;
+17 ; init
+18 NEW FBBAMT,FBERR,FBHL,FBN,FBSN,FBSTAT,FBTYPE,X,XMER,XMRG,FBNEW
+19 SET FBERR=0
+20 ;
+21 ; switch to a Fee Basis server error trap
+22 SET X="TRAP^FBMRASV2"
SET @^%ZOSF("TRAP")
+23 ;
HDR ; process header line
+1 XECUTE XMREC
+2 IF XMER<0
DO ERR("Error reading header line.")
+3 IF FBERR
GOTO END
+4 ; skip initial line if just envelope data
IF $EXTRACT(XMRG,2,4)="FEB"
GOTO HDR
+5 ;
+6 ;FB*3.5*158
+7 ;six digit batch number
IF $LENGTH(XMRG)=33
SET FBNEW=0
+8 ;seven digit batch number
IF '$TEST
IF $LENGTH(XMRG)=34
SET FBNEW=1
+9 IF '$TEST
DO ERR("Header line has incorrect length.")
+10 IF FBERR
GOTO END
+11 ;
+12 ; extract data from header line
+13 ; station number
SET FBHL(1)=$$TRIM^XLFSTR($EXTRACT(XMRG,1,6),"R")
+14 ; date YYYYMMDD
SET FBHL(2)=$EXTRACT(XMRG,7,14)
+15 ; processing stage (R)
SET FBHL(3)=$EXTRACT(XMRG,15)
+16 ; payment type (3, 5, 9, or T)
SET FBHL(4)=$EXTRACT(XMRG,16)
+17 ;FB*3.5*158
+18 ;7 digit batch number
IF FBNEW
Begin DoDot:1
+19 SET FBHL(5)=+$EXTRACT(XMRG,17,23)
+20 ; batch reject code
SET FBHL(6)=$$TRIM^XLFSTR($EXTRACT(XMRG,24,27))
+21 ; number accepted
SET FBHL(7)=+$EXTRACT(XMRG,28,30)
+22 ; number rejected
SET FBHL(8)=+$EXTRACT(XMRG,31,33)
+23 ; delimiter ($)
SET FBHL(9)=$EXTRACT(XMRG,34)
End DoDot:1
+24 ;6 digit batch number
IF '$TEST
Begin DoDot:1
+25 SET FBHL(5)=+$EXTRACT(XMRG,17,22)
+26 ; batch reject code
SET FBHL(6)=$$TRIM^XLFSTR($EXTRACT(XMRG,23,26))
+27 ; number accepted
SET FBHL(7)=+$EXTRACT(XMRG,27,29)
+28 ; number rejected
SET FBHL(8)=+$EXTRACT(XMRG,30,32)
+29 ; delimiter ($)
SET FBHL(9)=$EXTRACT(XMRG,33)
End DoDot:1
+30 ;
+31 ; validate header data
+32 IF FBHL(3)'="R"
DO ERR("Processing stage ("_FBHL(3)_") is invalid.")
+33 IF "^3^5^9^T^"'[("^"_FBHL(4)_"^")
DO ERR("Payment type ("_FBHL(4)_") is invalid.")
+34 IF FBERR
GOTO END
+35 ;
+36 ; determine batch IEN
+37 SET FBN=$ORDER(^FBAA(161.7,"B",FBHL(5),0))
+38 IF 'FBN
DO ERR("Could not locate record for batch "_FBHL(5)_".")
+39 IF FBERR
GOTO END
+40 ;
+41 ; obtain batch data
+42 ; type (internal)
SET FBTYPE=$$GET1^DIQ(161.7,FBN_",",2,"I")
+43 ; status (internal)
SET FBSTAT=$$GET1^DIQ(161.7,FBN_",",11,"I")
+44 ; station number (3 digit)
SET FBSN=$$GET1^DIQ(161.7,FBN_",",16)
+45 ;
+46 ; verify batch values
+47 IF FBHL(4)="T"
IF FBTYPE'="B2"
DO ERR("Payment Type in message is not consistent with the batch type.")
+48 IF FBHL(4)
IF FBHL(4)'=$EXTRACT(FBTYPE,2)
DO ERR("Payment Type in message is not consistent with the batch type.")
+49 IF FBSN'=$EXTRACT(FBHL(1),1,3)
DO ERR("Station number in message is not consistent with the batch station number.")
+50 IF FBSTAT'="T"
DO ERR("Current batch status is not TRANSMITTED.")
+51 IF FBERR
GOTO END
+52 ;
+53 ; init dollar amount for posting to 1358 by batch
SET FBBAMT=0
+54 ;
+55 ; if batch reject code sent then reject entire batch
+56 IF FBHL(6)'=""
Begin DoDot:1
+57 NEW FBIEN,FBIENS,FBRCA
+58 ; reject code array
SET FBRCA(1)=FBHL(6)
+59 ;
+60 ; loop thru line items in batch
+61 IF FBTYPE="B2"
Begin DoDot:2
+62 SET FBIEN(1)=0
+63 FOR
SET FBIEN(1)=$ORDER(^FBAAC("AD",FBN,FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:3
+64 SET FBIEN=0
+65 FOR
SET FBIEN=$ORDER(^FBAAC("AD",FBN,FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:4
+66 SET FBIENS=FBIEN_","_FBIEN(1)_","
+67 DO REJLN
End DoDot:4
End DoDot:3
End DoDot:2
+68 ;
+69 IF FBTYPE="B3"
Begin DoDot:2
+70 SET FBIEN(3)=0
+71 FOR
SET FBIEN(3)=$ORDER(^FBAAC("AC",FBN,FBIEN(3)))
if 'FBIEN(3)
QUIT
Begin DoDot:3
+72 SET FBIEN(2)=0
+73 FOR
SET FBIEN(2)=$ORDER(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2)))
if 'FBIEN(2)
QUIT
Begin DoDot:4
+74 SET FBIEN(1)=0
+75 FOR
SET FBIEN(1)=$ORDER(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2),FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:5
+76 SET FBIEN=0
+77 FOR
SET FBIEN=$ORDER(^FBAAC("AC",FBN,FBIEN(3),FBIEN(2),FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:6
+78 SET FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
+79 DO REJLN
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+80 ;
+81 IF FBTYPE="B5"
Begin DoDot:2
+82 SET FBIEN(1)=0
+83 FOR
SET FBIEN(1)=$ORDER(^FBAA(162.1,"AE",FBN,FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:3
+84 SET FBIEN=0
+85 FOR
SET FBIEN=$ORDER(^FBAA(162.1,"AE",FBN,FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:4
+86 SET FBIENS=FBIEN_","_FBIEN(1)_","
+87 DO REJLN
End DoDot:4
End DoDot:3
End DoDot:2
+88 ;
+89 IF FBTYPE="B9"
Begin DoDot:2
+90 SET FBIEN=0
+91 FOR
SET FBIEN=$ORDER(^FBAAI("AC",FBN,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:3
+92 SET FBIENS=FBIEN_","
+93 DO REJLN
End DoDot:3
End DoDot:2
End DoDot:1
+94 ;
+95 ; if batch reject code not sent then process line rejects (if any)
+96 IF FBHL(6)=""
Begin DoDot:1
+97 ; loop thru detail lines in message
+98 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="NNNN")
QUIT
IF XMRG]""
Begin DoDot:2
+99 NEW FBI,FBJ,FBIEN,FBIENS,FBRCA,FBX
+100 ; determine the reject codes for the line item
+101 ; init number of reject codes for line item
SET FBJ=0
+102 ; loop thru the five data elements that can hold a reject code
+103 FOR FBI=1:1:5
Begin DoDot:3
+104 NEW FBP
+105 ; calc data element starting position
SET FBP=$SELECT(FBNEW:54,1:53)+((FBI-1)*4)
+106 SET FBX=$$TRIM^XLFSTR($EXTRACT(XMRG,FBP,FBP+3))
+107 ; add to array
IF FBX'=""
SET FBJ=FBJ+1
SET FBRCA(FBJ)=FBX
End DoDot:3
+108 ;
+109 ; determine the IENs for the line item
+110 ; IEN string
SET FBX=$EXTRACT(XMRG,$SELECT(FBNEW:24,1:23),$SELECT(FBNEW:53,1:52))
+111 IF FBTYPE="B2"
Begin DoDot:3
+112 SET FBIEN(1)=+$PIECE(FBX,U)
SET FBIEN=+$PIECE(FBX,U,2)
+113 ; if line item not found then check if moved
+114 IF '$DATA(^FBAAC(FBIEN(1),3,FBIEN,0))
Begin DoDot:4
+115 NEW FBPROG
+116 SET FBPROG="T"
+117 DO CHKMOVE^FBPAID1
End DoDot:4
+118 SET FBIENS=FBIEN_","_FBIEN(1)_","
End DoDot:3
+119 ;
+120 IF FBTYPE="B3"
Begin DoDot:3
+121 SET FBIEN(3)=+$PIECE(FBX,U)
SET FBIEN(2)=+$PIECE(FBX,U,2)
+122 SET FBIEN(1)=+$PIECE(FBX,U,3)
SET FBIEN=+$PIECE(FBX,U,4)
+123 ; if line item not found then check if moved
+124 IF '$DATA(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0))
Begin DoDot:4
+125 NEW FBPROG
+126 SET FBPROG=3
+127 DO CHKMOVE^FBPAID1
End DoDot:4
+128 SET FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
End DoDot:3
+129 ;
+130 IF FBTYPE="B5"
Begin DoDot:3
+131 SET FBIEN(1)=+$PIECE(FBX,U)
SET FBIEN=+$PIECE(FBX,U,2)
+132 SET FBIENS=FBIEN_","_FBIEN(1)_","
End DoDot:3
+133 ;
+134 IF FBTYPE="B9"
Begin DoDot:3
+135 SET FBIEN=+FBX
+136 SET FBIENS=FBIEN_","
End DoDot:3
+137 ;
+138 ; call to reject the line item
+139 DO REJLN
End DoDot:2
End DoDot:1
+140 ;
+141 ; update obligation for rejected lines posted by batch
+142 IF FBBAMT>0
Begin DoDot:1
+143 NEW FBX
+144 SET FBX=$$POSTBAT^FB1358(FBN,FBBAMT,"R",1)
+145 IF 'FBX
Begin DoDot:2
+146 DO ERR("Error posting to 1358 for batch")
+147 DO ERR(" "_$PIECE(FBX,"^",2))
End DoDot:2
End DoDot:1
+148 ;
+149 ; update batch status
+150 IF FBN
Begin DoDot:1
+151 NEW DIERR,FBFDA,FBX
+152 ; init new status as Central Fee Accepted
SET FBX="F"
+153 ; if no lines remain in batch change new status to Vouchered
+154 IF FBTYPE="B2"
IF '$ORDER(^FBAAC("AD",FBN,0))
SET FBX="V"
+155 IF FBTYPE="B3"
IF '$ORDER(^FBAAC("AC",FBN,0))
SET FBX="V"
+156 IF FBTYPE="B5"
IF '$ORDER(^FBAA(162.1,"AE",FBN,0))
SET FBX="V"
+157 IF FBTYPE="B9"
IF '$ORDER(^FBAAI("AC",FBN,0))
SET FBX="V"
+158 SET FBFDA(161.7,FBN_",",11)=FBX
+159 IF FBX="V"
Begin DoDot:2
+160 ; DATE FINALIZED
SET FBFDA(161.7,FBN_",",13)=DT
+161 ; PERSON WHO COMPLETED
SET FBFDA(161.7,FBN_",",14)=DUZ
End DoDot:2
+162 DO FILE^DIE("","FBFDA")
+163 DO CLEAN^DILF
End DoDot:1
+164 ;
END ;
+1 ; switch back to the standard Kernel error trap
+2 SET X=^%ZOSF("ERRTN")
SET @^%ZOSF("TRAP")
+3 ;
+4 ; remove Central Fee message from server basket
+5 NEW XMSER,XMZ
+6 SET XMSER="S."_XQSOP
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+7 ;
+8 IF FBERR
Begin DoDot:1
+9 ; add text to bulletin
+10 DO ERR(" ")
+11 DO ERR("The above message # has been forwarded to the FEE mail group.")
+12 ;
+13 ; send bulletin
+14 DO SNDBUL("for batch "_$GET(FBHL(5))_" results")
+15 ;
+16 ; forward served message to G.FEE
+17 NEW XMDUZ,XMY,XMZ
+18 SET XMY("G.FEE")=""
+19 SET XMZ=XQMSG
+20 DO ENT1^XMD
End DoDot:1
+21 ;
+22 KILL XQSTXT
+23 QUIT
+24 ;
ERR(FBTXT) ; set error flag and save text for inclusion in bulletin
+1 NEW FBL
+2 SET FBERR=1
+3 SET FBL=$PIECE($GET(XQSTXT(0)),"^",4)
+4 SET FBL=FBL+1
+5 SET XQSTXT(FBL)=$GET(FBTXT)
+6 SET $PIECE(XQSTXT(0),"^",3,4)=FBL_"^"_FBL
+7 QUIT
+8 ;
REJLN ; reject payment line item
+1 NEW FBX
+2 ; set reject flag
+3 SET FBX=$$SETREJ^FBAAVR4(FBN,FBTYPE,FBIENS,1,,.FBRCA)
+4 ;
+5 ; if problem
+6 IF 'FBX
Begin DoDot:1
+7 DO ERR("Error rejecting line with IENS "_FBIENS)
+8 DO ERR(" "_$PIECE(FBX,"^",2))
End DoDot:1
+9 ;
+10 ; if success
+11 IF FBX
Begin DoDot:1
+12 NEW FBPBYINV
+13 ; determine if 1358 posted by invoice or batch
+14 SET FBPBYINV=0
+15 IF FBTYPE="B9"
IF $$GET1^DIQ(162.5,FBIENS,4,"I")'["FB583"
SET FBPBYINV=1
+16 ;
+17 ; if by batch then accumulate amount for later posting
+18 IF 'FBPBYINV
SET FBBAMT=FBBAMT+$PIECE(FBX,"^",3)
+19 ;
+20 ; if by B9 invoice then post it now
+21 IF FBPBYINV
Begin DoDot:2
+22 NEW FBX1
+23 SET FBX1=$$POSTINV^FB1358(FBN,+FBIENS,"R",1)
+24 IF 'FBX1
Begin DoDot:3
+25 DO ERR("Error posting invoice "_+FBIENS_" to 1358")
+26 DO ERR(" "_$PIECE(FBX1,"^",2))
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
SNDBUL(FBSUB) ; send bulletin
+1 ;
+2 NEW XMB,XMBTMP,XMDF,XMDT,XMDUZ,XMTEXT,XMY,XMYBLOB
+3 SET XMB="FBAA SERVER"
+4 ; date/time
SET XMB(1)=$$FMTE^XLFDT($$NOW^XLFDT)
+5 ; sender of message sent to server option
SET XMB(2)=$GET(XQSND)
+6 ; server option
SET XMB(3)=$GET(XQSOP)
+7 ; subject of message sent to server option
SET XMB(4)=$GET(XQSUB)
+8 ; number of message sent to server option
SET XMB(5)=$GET(XQMSG)
+9 ; comment
SET XMB(6)="An issue occurred that requires notification."
+10 ; optional text for bulletin message subject
SET XMB(7)=$GET(FBSUB)
+11 ; additional text
if $ORDER(XQSTXT(0))
SET XMTEXT="XQSTXT("
+12 SET XMY("G.FEE")=""
+13 SET XMY("G.FEE FINANCE")=""
+14 DO ^XMB
+15 QUIT
+16 ;FBSVBR
