FBSVPR ;ISW/SAB - PAYMENT BATCH RESULT MESSAGE SERVER ;3/23/2012
;;3.5;FEE BASIS;**131,132**;JAN 30, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine is called by a server option to process the
; Post Voucher Reject message sent by Central Fee.
;
; ICRs
; #2056 $$GET1^DIQ
; #10069 XMB
; #10072 REMSBMSG^XMA1C
; #10096 ^%ZOSF("ERRTN" ), ^%ZOSF("TRAP")
; #10103 $$FMTE^XLFDT, $$NOW^XLFDT
; #10104 $$TRIM^XLFSTR
;
; init
N FBBATCH,FBERR,FBHL,FBTYPE,X,XMER,XMRG
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)="FEP" G HDR ; skip initial line if just envelope data
;
I $L(XMRG)'=17 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 (P)
S FBHL(4)=$E(XMRG,16) ; payment type (3, 5, 9, or T)
S FBHL(5)=$E(XMRG,17) ; delimiter ($)
;
; validate header data
I FBHL(3)'="P" 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 type
I FBHL(4)="T" S FBTYPE="B2"
I FBHL(4) S FBTYPE="B"_FBHL(4)
;
; process line rejects
; loop thru detail lines in message
F X XMREC Q:XMER<0!($E(XMRG,1,4)="NNNN") I XMRG]"" D
. N FBI,FBIEN,FBIENS,FBJ,FBN,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=47+((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,17,46) ; 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)_","
. . S FBN=$$GET1^DIQ(162.04,FBIENS,1,"I") ; batch IEN
. ;
. 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)_","
. . S FBN=$$GET1^DIQ(162.03,FBIENS,7,"I") ; batch IEN
. ;
. I FBTYPE="B5" D
. . S FBIEN(1)=+$P(FBX,U),FBIEN=+$P(FBX,U,2)
. . S FBIENS=FBIEN_","_FBIEN(1)_","
. . S FBN=$$GET1^DIQ(162.11,FBIENS,13,"I") ; batch IEN
. ;
. I FBTYPE="B9" D
. . S FBIEN=+FBX
. . S FBIENS=FBIEN_","
. . S FBN=$$GET1^DIQ(162.5,FBIENS,20,"I") ; batch IEN
. ;
. ; call to reject the line item
. D REJLN
;
; update obligation for rejected lines posted by batch (if any)
I $O(FBBATCH(0)) D
. N FBBAMT,FBN
. ; loop thru batch
. S FBN=0 F S FBN=$O(FBBATCH(FBN)) Q:'FBN D
. . N FBX
. . S FBBAMT=FBBATCH(FBN)
. . Q:FBBAMT'>0
. . S FBX=$$POSTBAT^FB1358(FBN,FBBAMT,"R",1)
. . I 'FBX D
. . . D ERR("Error posting to 1358 for batch")
. . . D ERR(" "_$P(FBX,"^",2))
;
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^FBSVBR("for post voucher rejects")
. ;
. ; 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
S FBX=1
;
; verify batch data (note: null batch value is handled by $$SETREJ)
I FBN D
. N FBNUM,FBSN,FBSTAT
. ;
. ; obtain batch data
. S FBNUM=$$GET1^DIQ(161.7,FBN_",",.01) ; batch number
. 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 FBSN'=$E(FBHL(1),1,3) S FBX="0^Station number in message is not consistent with batch "_FBNUM_"." Q
. I FBSTAT'="V" S FBX="0^Batch "_FBNUM_" status is not VOUCHERED." Q
;
; if batch OK then set reject flag for line
I FBX 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 FBN,FBPBYINV
. S FBN=$P(FBX,"^",2) ; batch IEN
. ;
. ; 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 FBBATCH(FBN)=$G(FBBATCH(FBN))+$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(FBX,"^",2))
Q
;
;FBSVPR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBSVPR 5756 printed Dec 13, 2024@02:00 Page 2
FBSVPR ;ISW/SAB - PAYMENT BATCH RESULT MESSAGE SERVER ;3/23/2012
+1 ;;3.5;FEE BASIS;**131,132**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine is called by a server option to process the
+5 ; Post Voucher Reject message sent by Central Fee.
+6 ;
+7 ; ICRs
+8 ; #2056 $$GET1^DIQ
+9 ; #10069 XMB
+10 ; #10072 REMSBMSG^XMA1C
+11 ; #10096 ^%ZOSF("ERRTN" ), ^%ZOSF("TRAP")
+12 ; #10103 $$FMTE^XLFDT, $$NOW^XLFDT
+13 ; #10104 $$TRIM^XLFSTR
+14 ;
+15 ; init
+16 NEW FBBATCH,FBERR,FBHL,FBTYPE,X,XMER,XMRG
+17 SET FBERR=0
+18 ;
+19 ; switch to a Fee Basis server error trap
+20 SET X="TRAP^FBMRASV2"
SET @^%ZOSF("TRAP")
+21 ;
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)="FEP"
GOTO HDR
+5 ;
+6 IF $LENGTH(XMRG)'=17
DO ERR("Header line has incorrect length.")
+7 IF FBERR
GOTO END
+8 ;
+9 ; extract data from header line
+10 ; station number
SET FBHL(1)=$$TRIM^XLFSTR($EXTRACT(XMRG,1,6),"R")
+11 ; date YYYYMMDD
SET FBHL(2)=$EXTRACT(XMRG,7,14)
+12 ; processing stage (P)
SET FBHL(3)=$EXTRACT(XMRG,15)
+13 ; payment type (3, 5, 9, or T)
SET FBHL(4)=$EXTRACT(XMRG,16)
+14 ; delimiter ($)
SET FBHL(5)=$EXTRACT(XMRG,17)
+15 ;
+16 ; validate header data
+17 IF FBHL(3)'="P"
DO ERR("Processing stage ("_FBHL(3)_") is invalid.")
+18 IF "^3^5^9^T^"'[("^"_FBHL(4)_"^")
DO ERR("Payment type ("_FBHL(4)_") is invalid.")
+19 IF FBERR
GOTO END
+20 ;
+21 ; determine batch type
+22 IF FBHL(4)="T"
SET FBTYPE="B2"
+23 IF FBHL(4)
SET FBTYPE="B"_FBHL(4)
+24 ;
+25 ; process line rejects
+26 ; loop thru detail lines in message
+27 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="NNNN")
QUIT
IF XMRG]""
Begin DoDot:1
+28 NEW FBI,FBIEN,FBIENS,FBJ,FBN,FBRCA,FBX
+29 ; determine the reject codes for the line item
+30 ; init number of reject codes for line item
SET FBJ=0
+31 ; loop thru the five data elements that can hold a reject code
+32 FOR FBI=1:1:5
Begin DoDot:2
+33 NEW FBP
+34 ; calc data element starting position
SET FBP=47+((FBI-1)*4)
+35 SET FBX=$$TRIM^XLFSTR($EXTRACT(XMRG,FBP,FBP+3))
+36 ; add to array
IF FBX'=""
SET FBJ=FBJ+1
SET FBRCA(FBJ)=FBX
End DoDot:2
+37 ;
+38 ; determine the IENs for the line item
+39 ; IEN string
SET FBX=$EXTRACT(XMRG,17,46)
+40 IF FBTYPE="B2"
Begin DoDot:2
+41 SET FBIEN(1)=+$PIECE(FBX,U)
SET FBIEN=+$PIECE(FBX,U,2)
+42 ; if line item not found then check if moved
+43 IF '$DATA(^FBAAC(FBIEN(1),3,FBIEN,0))
Begin DoDot:3
+44 NEW FBPROG
+45 SET FBPROG="T"
+46 DO CHKMOVE^FBPAID1
End DoDot:3
+47 SET FBIENS=FBIEN_","_FBIEN(1)_","
+48 ; batch IEN
SET FBN=$$GET1^DIQ(162.04,FBIENS,1,"I")
End DoDot:2
+49 ;
+50 IF FBTYPE="B3"
Begin DoDot:2
+51 SET FBIEN(3)=+$PIECE(FBX,U)
SET FBIEN(2)=+$PIECE(FBX,U,2)
+52 SET FBIEN(1)=+$PIECE(FBX,U,3)
SET FBIEN=+$PIECE(FBX,U,4)
+53 ; if line item not found then check if moved
+54 IF '$DATA(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0))
Begin DoDot:3
+55 NEW FBPROG
+56 SET FBPROG=3
+57 DO CHKMOVE^FBPAID1
End DoDot:3
+58 SET FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
+59 ; batch IEN
SET FBN=$$GET1^DIQ(162.03,FBIENS,7,"I")
End DoDot:2
+60 ;
+61 IF FBTYPE="B5"
Begin DoDot:2
+62 SET FBIEN(1)=+$PIECE(FBX,U)
SET FBIEN=+$PIECE(FBX,U,2)
+63 SET FBIENS=FBIEN_","_FBIEN(1)_","
+64 ; batch IEN
SET FBN=$$GET1^DIQ(162.11,FBIENS,13,"I")
End DoDot:2
+65 ;
+66 IF FBTYPE="B9"
Begin DoDot:2
+67 SET FBIEN=+FBX
+68 SET FBIENS=FBIEN_","
+69 ; batch IEN
SET FBN=$$GET1^DIQ(162.5,FBIENS,20,"I")
End DoDot:2
+70 ;
+71 ; call to reject the line item
+72 DO REJLN
End DoDot:1
+73 ;
+74 ; update obligation for rejected lines posted by batch (if any)
+75 IF $ORDER(FBBATCH(0))
Begin DoDot:1
+76 NEW FBBAMT,FBN
+77 ; loop thru batch
+78 SET FBN=0
FOR
SET FBN=$ORDER(FBBATCH(FBN))
if 'FBN
QUIT
Begin DoDot:2
+79 NEW FBX
+80 SET FBBAMT=FBBATCH(FBN)
+81 if FBBAMT'>0
QUIT
+82 SET FBX=$$POSTBAT^FB1358(FBN,FBBAMT,"R",1)
+83 IF 'FBX
Begin DoDot:3
+84 DO ERR("Error posting to 1358 for batch")
+85 DO ERR(" "_$PIECE(FBX,"^",2))
End DoDot:3
End DoDot:2
End DoDot:1
+86 ;
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^FBSVBR("for post voucher rejects")
+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 FBX=1
+3 ;
+4 ; verify batch data (note: null batch value is handled by $$SETREJ)
+5 IF FBN
Begin DoDot:1
+6 NEW FBNUM,FBSN,FBSTAT
+7 ;
+8 ; obtain batch data
+9 ; batch number
SET FBNUM=$$GET1^DIQ(161.7,FBN_",",.01)
+10 ; status (internal)
SET FBSTAT=$$GET1^DIQ(161.7,FBN_",",11,"I")
+11 ; station number (3 digit)
SET FBSN=$$GET1^DIQ(161.7,FBN_",",16)
+12 ;
+13 ; verify batch values
+14 IF FBSN'=$EXTRACT(FBHL(1),1,3)
SET FBX="0^Station number in message is not consistent with batch "_FBNUM_"."
QUIT
+15 IF FBSTAT'="V"
SET FBX="0^Batch "_FBNUM_" status is not VOUCHERED."
QUIT
End DoDot:1
+16 ;
+17 ; if batch OK then set reject flag for line
+18 IF FBX
SET FBX=$$SETREJ^FBAAVR4(FBN,FBTYPE,FBIENS,1,,.FBRCA)
+19 ;
+20 ; if problem
+21 IF 'FBX
Begin DoDot:1
+22 DO ERR("Error rejecting line with IENS "_FBIENS)
+23 DO ERR(" "_$PIECE(FBX,"^",2))
End DoDot:1
+24 ;
+25 ; if success
+26 IF FBX
Begin DoDot:1
+27 NEW FBN,FBPBYINV
+28 ; batch IEN
SET FBN=$PIECE(FBX,"^",2)
+29 ;
+30 ; determine if 1358 posted by invoice or batch
+31 SET FBPBYINV=0
+32 IF FBTYPE="B9"
IF $$GET1^DIQ(162.5,FBIENS,4,"I")'["FB583"
SET FBPBYINV=1
+33 ;
+34 ; if by batch then accumulate amount for later posting
+35 IF 'FBPBYINV
SET FBBATCH(FBN)=$GET(FBBATCH(FBN))+$PIECE(FBX,"^",3)
+36 ;
+37 ; if by B9 invoice then post it now
+38 IF FBPBYINV
Begin DoDot:2
+39 NEW FBX1
+40 SET FBX1=$$POSTINV^FB1358(FBN,+FBIENS,"R",1)
+41 IF 'FBX1
Begin DoDot:3
+42 DO ERR("Error posting invoice "_+FBIENS_" to 1358")
+43 DO ERR(" "_$PIECE(FBX,"^",2))
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
+45 ;
+46 ;FBSVPR
