FBMRASV2 ;AISC/TET - Server routine (Cont'd) ;2/29/2012
;;3.5;FEE BASIS;**9,132**;JAN 30, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
EXIT S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
K I,XMER,XMRG,FBI,FBID,FBER,FBERR,FBSITE,FBPOP,FBSN,FBAASN,FBJ,FBRT,FBAC,FBSTN,FBVID,FBCHAIN,FBFEEO,FBVNAME,FBADD1,FBADD2,FBCITY,FBST,FBZIP,FBMRC,FBCC,FBPC,FBTID,FB1099,FBVT,FBICN,FBSC,FBPART,FBSTATE,FBICN1,K,DIE,DA,DR,X,DLAYGO
K FBOGN,DIC,FBNGN,%X,%Y,DIK,FBTMP,FBMRA,FBCNT,FBATOT,FBCTOT,FBFTOT,FBQTOT,FBZIP1,FBCHK,FBOUT,XMSER,XMZ,^TMP("FBMRA",$J),^TMP("FBER",$J)
Q
EDIT ;edit check if fbac=q
;INPUT: FBAC = action code; should only come here if = 'Q'
; FBVID = vendor tax id number
; FBCHAIN = chain store (optional - only if pharmacy record type)
; FBICN = internal control number
; FBVNAME = vendor name from autsin transmission
;OUTPUT: FBAC may be changed from 'Q' to 'C' if id's have not changed,
; or if venid exists on file and austin name matches FBVNAME
; to avoid leaving duplicate vendors in site's vendor file.
;VAR: FBI = internal entry of vendor in vendor file with same id as FBVID
; FBVC = internal entry of vendor in vendor correction file (with station number stripped)
N FBI,FBVCI S FBI=0,FBVCI=$E(FBICN,4,$L(FBICN))
S:FBVID=$P($G(^FBAAV(+FBVCI,0)),U,2) FBAC="C" I FBAC="Q" S FBI=$O(^FBAAV("C",FBVID,0)) I FBI,FBVNAME=$P($G(^FBAAV(FBI,"AMS")),U) S FBAC="C"
Q
TRAP ;trap error, have bulletin message record error, send server message to group and reset trap to server error trap and exit.
D @^%ZOSF("ERRTN")
S XQSTXT(0)=""
S XQSTXT(1)="*** Error detected by FEE while processing the above server message. ***"
S XQSTXT(2)="Details recorded in the Kernel error trap."
S XQSTXT(3)="Please contact your IRM representative immediately."
S XQSTXT(4)="",XQSTXT(5)="The above message # has been forwarded to the FEE mail group."
S XQSTXT(6)="Once the problem has been identified AND corrected, forward the server message"
S XQSTXT(7)=" to S."_$G(XQSOP)_" server to complete processing."
;S %ZTERLGR=$$LGR^%ZOSV D ^%ZTER
;S X="ERROR^XQSRV2",@^%ZOSF("TRAP")
; generate FBAA SERVER bulletin for selected server options
I "^FBAA BATCH SERVER^FBAA VOUCHER SERVER^FBAA REJECT SERVER^"[("^"_$G(XQSOP)_"^") D SNDBUL^FBSVBR("of Trapped Error")
SEND ; send served message to G.FEE
D
. N XMDUZ,XMY,XMZ
. S XMY("G.FEE")=""
. S XMZ=XQMSG
. D ENT1^XMD
D EXIT
Q
MSG ;set up server bulletin upon successful completion of processing
S XQSTXT(0)="",XQSTXT(1)="Total Vendor MRA's Received: "_(FBATOT+FBCTOT+FBFTOT+FBQTOT)_" Processed: "_FBCNT_" Errors: "_FBER
S XQSTXT(2)="ADDS: "_FBATOT,XQSTXT(3)="CHANGES: "_FBCTOT,XQSTXT(4)="UNSOLICITED ADDS: "_FBQTOT,XQSTXT(5)="FPDS-ONLY CHANGES: "_FBFTOT
I +FBER S XQSTXT(6)="",XQSTXT(7)="*** "_FBER_" Error"_$S(FBER>1:"s",1:"")_" detected by FEE while processing the above server message. ***",XQSTXT(8)="" D
.N EC,QCT
.S QCT=8,EC="" F S EC=$O(^TMP("FBER",$J,EC)) Q:EC']"" D S QCT=QCT+1,XQSTXT(QCT)=""
..N I,DATA
..S QCT=QCT+1,XQSTXT(QCT)="ERROR CODE "_EC_": "
..I EC<4 S XQSTXT(QCT)=XQSTXT(QCT)_$S(EC=1:"Invalid Vendor ID",EC=2:"Invalid Record Length",EC=3:"Invalid Station Number",1:"")
..I EC'<4 S XQSTXT(QCT)=XQSTXT(QCT)_$S(EC=4:"Vendor names do not match",EC=4.1:"Vendor not found in file or vendor in delete status",EC=5:"Vendor change already processed",1:"")
..S XQSTXT(QCT)=" ===> "_XQSTXT(QCT)
..S QCT=QCT+1,XQSTXT(QCT)=" "_$S(EC<3:"Action necessary.",EC=3:"Action may be necessary.",1:"Information only.")_" Refer to the Vendor Error Code documentation."
..S QCT=QCT+1,XQSTXT(QCT)="",I=0 F S I=$O(^TMP("FBER",$J,EC,I)) Q:'I S DATA=^(I),QCT=QCT+1,XQSTXT(QCT)=DATA
G EXIT
ER(EC,J,FBER) ;set error & error count
;INPUT: EC = error code
; 1 = invalid vendor id (action needed)
; 2 = invalid record length (action needed)
; 3 = invalid station number (action may be necessary)
; 4 = vendor names do not match (ignore)
; 4.1 = vendor not found or in delete status (ignore)
; 5 = record already processed (ignore)
; J = data string from message/mra record
; FBER = error count
;OUTPUT: FBER updated
I $S($G(FBER)']"":1,J']"":1,'+$G(EC):1,1:0) Q
N FBCHAIN,FBRT,FBVID,FBVNAME
I EC'=2 S FBRT=$E(J,1),FBVID=$S(FBRT=1:$E(J,9,19),1:$E(J,9,17)),FBVNAME=$S(FBRT=1:$E(J,27,56),1:$E(J,23,52)),FBCHAIN=$S(FBRT=1:"",1:" "_$E(J,18,21))
S FBER=FBER+1,^TMP("FBER",$J,EC,FBER)=$S(EC=2:J,1:FBVNAME_" "_FBVID_FBCHAIN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBMRASV2 4654 printed Dec 13, 2024@01:58:39 Page 2
FBMRASV2 ;AISC/TET - Server routine (Cont'd) ;2/29/2012
+1 ;;3.5;FEE BASIS;**9,132**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
EXIT SET XMSER="S."_XQSOP
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+1 KILL I,XMER,XMRG,FBI,FBID,FBER,FBERR,FBSITE,FBPOP,FBSN,FBAASN,FBJ,FBRT,FBAC,FBSTN,FBVID,FBCHAIN,FBFEEO,FBVNAME,FBADD1,FBADD2,FBCITY,FBST,FBZIP,FBMRC,FBCC,FBPC,FBTID,FB1099,FBVT,FBICN,FBSC,FBPART,FBSTATE,FBICN1,K,DIE,DA,DR,X,DLAYGO
+2 KILL FBOGN,DIC,FBNGN,%X,%Y,DIK,FBTMP,FBMRA,FBCNT,FBATOT,FBCTOT,FBFTOT,FBQTOT,FBZIP1,FBCHK,FBOUT,XMSER,XMZ,^TMP("FBMRA",$JOB),^TMP("FBER",$JOB)
+3 QUIT
EDIT ;edit check if fbac=q
+1 ;INPUT: FBAC = action code; should only come here if = 'Q'
+2 ; FBVID = vendor tax id number
+3 ; FBCHAIN = chain store (optional - only if pharmacy record type)
+4 ; FBICN = internal control number
+5 ; FBVNAME = vendor name from autsin transmission
+6 ;OUTPUT: FBAC may be changed from 'Q' to 'C' if id's have not changed,
+7 ; or if venid exists on file and austin name matches FBVNAME
+8 ; to avoid leaving duplicate vendors in site's vendor file.
+9 ;VAR: FBI = internal entry of vendor in vendor file with same id as FBVID
+10 ; FBVC = internal entry of vendor in vendor correction file (with station number stripped)
+11 NEW FBI,FBVCI
SET FBI=0
SET FBVCI=$EXTRACT(FBICN,4,$LENGTH(FBICN))
+12 if FBVID=$PIECE($GET(^FBAAV(+FBVCI,0)),U,2)
SET FBAC="C"
IF FBAC="Q"
SET FBI=$ORDER(^FBAAV("C",FBVID,0))
IF FBI
IF FBVNAME=$PIECE($GET(^FBAAV(FBI,"AMS")),U)
SET FBAC="C"
+13 QUIT
TRAP ;trap error, have bulletin message record error, send server message to group and reset trap to server error trap and exit.
+1 DO @^%ZOSF("ERRTN")
+2 SET XQSTXT(0)=""
+3 SET XQSTXT(1)="*** Error detected by FEE while processing the above server message. ***"
+4 SET XQSTXT(2)="Details recorded in the Kernel error trap."
+5 SET XQSTXT(3)="Please contact your IRM representative immediately."
+6 SET XQSTXT(4)=""
SET XQSTXT(5)="The above message # has been forwarded to the FEE mail group."
+7 SET XQSTXT(6)="Once the problem has been identified AND corrected, forward the server message"
+8 SET XQSTXT(7)=" to S."_$GET(XQSOP)_" server to complete processing."
+9 ;S %ZTERLGR=$$LGR^%ZOSV D ^%ZTER
+10 ;S X="ERROR^XQSRV2",@^%ZOSF("TRAP")
+11 ; generate FBAA SERVER bulletin for selected server options
+12 IF "^FBAA BATCH SERVER^FBAA VOUCHER SERVER^FBAA REJECT SERVER^"[("^"_$GET(XQSOP)_"^")
DO SNDBUL^FBSVBR("of Trapped Error")
SEND ; send served message to G.FEE
+1 Begin DoDot:1
+2 NEW XMDUZ,XMY,XMZ
+3 SET XMY("G.FEE")=""
+4 SET XMZ=XQMSG
+5 DO ENT1^XMD
End DoDot:1
+6 DO EXIT
+7 QUIT
MSG ;set up server bulletin upon successful completion of processing
+1 SET XQSTXT(0)=""
SET XQSTXT(1)="Total Vendor MRA's Received: "_(FBATOT+FBCTOT+FBFTOT+FBQTOT)_" Processed: "_FBCNT_" Errors: "_FBER
+2 SET XQSTXT(2)="ADDS: "_FBATOT
SET XQSTXT(3)="CHANGES: "_FBCTOT
SET XQSTXT(4)="UNSOLICITED ADDS: "_FBQTOT
SET XQSTXT(5)="FPDS-ONLY CHANGES: "_FBFTOT
+3 IF +FBER
SET XQSTXT(6)=""
SET XQSTXT(7)="*** "_FBER_" Error"_$SELECT(FBER>1:"s",1:"")_" detected by FEE while processing the above server message. ***"
SET XQSTXT(8)=""
Begin DoDot:1
+4 NEW EC,QCT
+5 SET QCT=8
SET EC=""
FOR
SET EC=$ORDER(^TMP("FBER",$JOB,EC))
if EC']""
QUIT
Begin DoDot:2
+6 NEW I,DATA
+7 SET QCT=QCT+1
SET XQSTXT(QCT)="ERROR CODE "_EC_": "
+8 IF EC<4
SET XQSTXT(QCT)=XQSTXT(QCT)_$SELECT(EC=1:"Invalid Vendor ID",EC=2:"Invalid Record Length",EC=3:"Invalid Station Number",1:"")
+9 IF EC'<4
SET XQSTXT(QCT)=XQSTXT(QCT)_$SELECT(EC=4:"Vendor names do not match",EC=4.1:"Vendor not found in file or vendor in delete status",EC=5:"Vendor change already processed",1:"")
+10 SET XQSTXT(QCT)=" ===> "_XQSTXT(QCT)
+11 SET QCT=QCT+1
SET XQSTXT(QCT)=" "_$SELECT(EC<3:"Action necessary.",EC=3:"Action may be necessary.",1:"Information only.")_" Refer to the Vendor Error Code documentation."
+12 SET QCT=QCT+1
SET XQSTXT(QCT)=""
SET I=0
FOR
SET I=$ORDER(^TMP("FBER",$JOB,EC,I))
if 'I
QUIT
SET DATA=^(I)
SET QCT=QCT+1
SET XQSTXT(QCT)=DATA
End DoDot:2
SET QCT=QCT+1
SET XQSTXT(QCT)=""
End DoDot:1
+13 GOTO EXIT
ER(EC,J,FBER) ;set error & error count
+1 ;INPUT: EC = error code
+2 ; 1 = invalid vendor id (action needed)
+3 ; 2 = invalid record length (action needed)
+4 ; 3 = invalid station number (action may be necessary)
+5 ; 4 = vendor names do not match (ignore)
+6 ; 4.1 = vendor not found or in delete status (ignore)
+7 ; 5 = record already processed (ignore)
+8 ; J = data string from message/mra record
+9 ; FBER = error count
+10 ;OUTPUT: FBER updated
+11 IF $SELECT($GET(FBER)']"":1,J']"":1,'+$GET(EC):1,1:0)
QUIT
+12 NEW FBCHAIN,FBRT,FBVID,FBVNAME
+13 IF EC'=2
SET FBRT=$EXTRACT(J,1)
SET FBVID=$SELECT(FBRT=1:$EXTRACT(J,9,19),1:$EXTRACT(J,9,17))
SET FBVNAME=$SELECT(FBRT=1:$EXTRACT(J,27,56),1:$EXTRACT(J,23,52))
SET FBCHAIN=$SELECT(FBRT=1:"",1:" "_$EXTRACT(J,18,21))
+14 SET FBER=FBER+1
SET ^TMP("FBER",$JOB,EC,FBER)=$SELECT(EC=2:J,1:FBVNAME_" "_FBVID_FBCHAIN)
+15 QUIT
