- 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 Jan 18, 2025@02:59:51 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