FBSVVA ;ISW/SAB - VOUCHER BATCH ACKNOWLEDGEMENT MESSAGE SERVER ;4/23/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 FBERR,FBHDR,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)="FEV" G HDR ; skip initial line if just envelope data
;
I $L(XMRG)'=25,$L(XMRG)'=26 D ERR("Header line has incorrect length.") ;FB*3.5*158
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 (A)
S FBHL(4)=$E(XMRG,16) ; payment type (3, 5, 9, or T)
;FB*3.5*158
S FBNEW=$S($L(XMRG)=25:0,1:1)
;
I FBNEW D
. S FBHL(5)=+$E(XMRG,17,23) ; batch number
. S FBHL(6)=$E(XMRG,24,25) ; status (AA or AE)
. S FBHL(7)=$E(XMRG,26) ; delimiter ($)
E D
. S FBHL(5)=+$E(XMRG,17,22) ; batch number
. S FBHL(6)=$E(XMRG,23,24) ; status (AA or AE)
. S FBHL(7)=$E(XMRG,25) ; delimiter ($)
;
; validate header data
I FBHL(3)'="A" D ERR("Processing stage ("_FBHL(3)_") is invalid.")
I "^3^5^9^T^"'[("^"_FBHL(4)_"^") D ERR("Payment type ("_FBHL(4)_") is invalid.")
I "^AA^AE^"'[("^"_FBHL(6)_"^") D ERR("Acknowledgement status ("_FBHL(6)_") 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'="V" D ERR("Current batch status is not VOUCHERED.")
I FBERR G END
;
; loop thru detail lines (errors and warnings) in message
S FBHDR=1
F X XMREC Q:XMER<0!($E(XMRG,1,4)="NNNN") I XMRG]"" D
. N FBDL
. ;
. S FBDL(6)=$E(XMRG,$S(FBNEW:24,1:23),$S(FBNEW:24,1:23)) ; severity (E or W)
. S FBDL(7)=$$TRIM^XLFSTR($E(XMRG,$S(FBNEW:25,1:24),$S(FBNEW:28,1:27))) ; message code
. S FBDL(8)=$$TRIM^XLFSTR($E(XMRG,$S(FBNEW:29,1:28),$S(FBNEW:98,1:97))) ; message text
. ;
. I FBHDR D MSG("Messages from Central Fee follow") S FBHDR=0
. D MSG(" ("_FBDL(6)_") "_FBDL(8))
;
; update batch
I FBN D
. N DIERR,FBFDA,FBX
. ; set VOUCHER MSG ACK STATUS to A or E
. S FBFDA(161.7,FBN_",",22)=$S(FBHL(6)="AA":"A",1:"E")
. 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^FBSVBR("for batch "_$G(FBHL(5))_" voucher ack.")
. ;
. ; forward served message to G.FEE
. N XMDUZ,XMY,XMZ
. S XMY("G.FEE")=""
. S XMZ=XQMSG
. D ENT1^XMD
;
; if no VistA error, but Central Fee sent a warning or error
I 'FBERR,'FBHDR D
. ; send bulletin
. D SNDBUL^FBSVBR("for batch "_$G(FBHL(5))_" voucher ack.")
;
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
;
MSG(FBTXT) ; set save text for inclusion in bulletin
N FBL
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
;
;FBSVVA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBSVVA 4517 printed Apr 09, 2024@21:03:57 Page 2
FBSVVA ;ISW/SAB - VOUCHER BATCH ACKNOWLEDGEMENT MESSAGE SERVER ;4/23/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 FBERR,FBHDR,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)="FEV"
GOTO HDR
+5 ;
+6 ;FB*3.5*158
IF $LENGTH(XMRG)'=25
IF $LENGTH(XMRG)'=26
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 (A)
SET FBHL(3)=$EXTRACT(XMRG,15)
+13 ; payment type (3, 5, 9, or T)
SET FBHL(4)=$EXTRACT(XMRG,16)
+14 ;FB*3.5*158
+15 SET FBNEW=$SELECT($LENGTH(XMRG)=25:0,1:1)
+16 ;
+17 IF FBNEW
Begin DoDot:1
+18 ; batch number
SET FBHL(5)=+$EXTRACT(XMRG,17,23)
+19 ; status (AA or AE)
SET FBHL(6)=$EXTRACT(XMRG,24,25)
+20 ; delimiter ($)
SET FBHL(7)=$EXTRACT(XMRG,26)
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 ; batch number
SET FBHL(5)=+$EXTRACT(XMRG,17,22)
+23 ; status (AA or AE)
SET FBHL(6)=$EXTRACT(XMRG,23,24)
+24 ; delimiter ($)
SET FBHL(7)=$EXTRACT(XMRG,25)
End DoDot:1
+25 ;
+26 ; validate header data
+27 IF FBHL(3)'="A"
DO ERR("Processing stage ("_FBHL(3)_") is invalid.")
+28 IF "^3^5^9^T^"'[("^"_FBHL(4)_"^")
DO ERR("Payment type ("_FBHL(4)_") is invalid.")
+29 IF "^AA^AE^"'[("^"_FBHL(6)_"^")
DO ERR("Acknowledgement status ("_FBHL(6)_") is invalid.")
+30 IF FBERR
GOTO END
+31 ;
+32 ; determine batch IEN
+33 SET FBN=$ORDER(^FBAA(161.7,"B",FBHL(5),0))
+34 IF 'FBN
DO ERR("Could not locate record for batch "_FBHL(5)_".")
+35 IF FBERR
GOTO END
+36 ;
+37 ; obtain batch data
+38 ; type (internal)
SET FBTYPE=$$GET1^DIQ(161.7,FBN_",",2,"I")
+39 ; status (internal)
SET FBSTAT=$$GET1^DIQ(161.7,FBN_",",11,"I")
+40 ; station number (3 digit)
SET FBSN=$$GET1^DIQ(161.7,FBN_",",16)
+41 ;
+42 ; verify batch values
+43 IF FBHL(4)="T"
IF FBTYPE'="B2"
DO ERR("Payment Type in message is not consistent with the batch type.")
+44 IF FBHL(4)
IF FBHL(4)'=$EXTRACT(FBTYPE,2)
DO ERR("Payment Type in message is not consistent with the batch type.")
+45 IF FBSN'=$EXTRACT(FBHL(1),1,3)
DO ERR("Station number in message is not consistent with the batch station number.")
+46 IF FBSTAT'="V"
DO ERR("Current batch status is not VOUCHERED.")
+47 IF FBERR
GOTO END
+48 ;
+49 ; loop thru detail lines (errors and warnings) in message
+50 SET FBHDR=1
+51 FOR
XECUTE XMREC
if XMER<0!($EXTRACT(XMRG,1,4)="NNNN")
QUIT
IF XMRG]""
Begin DoDot:1
+52 NEW FBDL
+53 ;
+54 ; severity (E or W)
SET FBDL(6)=$EXTRACT(XMRG,$SELECT(FBNEW:24,1:23),$SELECT(FBNEW:24,1:23))
+55 ; message code
SET FBDL(7)=$$TRIM^XLFSTR($EXTRACT(XMRG,$SELECT(FBNEW:25,1:24),$SELECT(FBNEW:28,1:27)))
+56 ; message text
SET FBDL(8)=$$TRIM^XLFSTR($EXTRACT(XMRG,$SELECT(FBNEW:29,1:28),$SELECT(FBNEW:98,1:97)))
+57 ;
+58 IF FBHDR
DO MSG("Messages from Central Fee follow")
SET FBHDR=0
+59 DO MSG(" ("_FBDL(6)_") "_FBDL(8))
End DoDot:1
+60 ;
+61 ; update batch
+62 IF FBN
Begin DoDot:1
+63 NEW DIERR,FBFDA,FBX
+64 ; set VOUCHER MSG ACK STATUS to A or E
+65 SET FBFDA(161.7,FBN_",",22)=$SELECT(FBHL(6)="AA":"A",1:"E")
+66 DO FILE^DIE("","FBFDA")
+67 DO CLEAN^DILF
End DoDot:1
+68 ;
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 batch "_$GET(FBHL(5))_" voucher ack.")
+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 ; if no VistA error, but Central Fee sent a warning or error
+23 IF 'FBERR
IF 'FBHDR
Begin DoDot:1
+24 ; send bulletin
+25 DO SNDBUL^FBSVBR("for batch "_$GET(FBHL(5))_" voucher ack.")
End DoDot:1
+26 ;
+27 KILL XQSTXT
+28 QUIT
+29 ;
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 ;
MSG(FBTXT) ; set save text for inclusion in bulletin
+1 NEW FBL
+2 SET FBL=$PIECE($GET(XQSTXT(0)),"^",4)
+3 SET FBL=FBL+1
+4 SET XQSTXT(FBL)=$GET(FBTXT)
+5 SET $PIECE(XQSTXT(0),"^",3,4)=FBL_"^"_FBL
+6 QUIT
+7 ;
+8 ;FBSVVA
