FBMRASV1 ;AISC/CMR-Server Routine for MRA Messages Cont'd;4/1/93 ; 8/28/09 12:02pm
;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
CHANGE ;Process Austin Change Record
;if fbinc=fbinc1 then transaction was to update fms vendor file, nothing needs to be repointed, and since it is not a duplicate, vendor should not be deleted.
I FBSTN'=FBSN D
.N EC S (FBICN,FBOUT)=0,FBERR=1,EC="" D
..F S FBICN=$O(^FBAAV("C",FBVID,FBICN)) Q:'FBICN!(FBOUT) D
...Q:$P($G(^FBAAV(FBICN,"ADEL")),"^")="Y"
...S EC="" I FBRT=4 Q:$P(^FBAAV(FBICN,0),U,7)'=3 Q:$P(^FBAAV(FBICN,0),U,10)'=FBCHAIN
...I FBRT=1 Q:$P($G(^FBAAV(FBICN,0)),U,7)=3
...I $E(FBVNAME,1,5)'=$E($P($G(^FBAAV(FBICN,"AMS")),U),1,5),'+$P($G(^FBAAV(FBICN,"ADEL")),U,4) S EC=4 Q
...S FBCNT=FBCNT+1,FBOUT=1,FBERR=0 D FILEV^FBMRASVR
.I FBERR S:EC']"" EC=4.1 D ER^FBMRASV2(EC,FBJ,.FBER) S FBERR=0
Q:FBSTN'=FBSN
I FBSTN=FBSN D GET^FBMRASVR D:FBMRA']"" ER^FBMRASV2(5,FBJ,.FBER) Q:FBMRA']"" S FBICN1=FBICN,FBICN=$P(FBMRA,"^",6) I 'FBICN K FBICN1 Q
S FBCNT=FBCNT+1 D FILEV^FBMRASVR,DELMRA^FBMRASVR I FBICN']""!(FBICN=FBICN1) K FBICN1 Q
REPOINT ;Re-point pointers to appropriate vendor entry.
N DFN,DAT
I $D(^FBAAA("ACV",FBICN1)) S K=0 F S K=$O(^FBAAA("ACV",FBICN1,K)) Q:'K S FBJ=0 F S FBJ=$O(^FBAAA("ACV",FBICN1,K,FBJ)) Q:'FBJ S DIE="^FBAAA(K,1,",DA=FBJ,DA(1)=K,DR=".04////^S X=FBICN" D ^DIE K DIE
I $D(^FBAA(161.21,"C",FBICN1)) S FBJ=0 F S FBJ=$O(^FBAA(161.21,"C",FBICN1,FBJ)) Q:'FBJ S DIE="^FBAA(161.21,",DA=FBJ,DR=".04////^S X=FBICN" D ^DIE K DIE
I $D(^FBAAC("AB",FBICN1)) S FBK=0 F S FBK=$O(^FBAAC("AB",FBICN1,FBK)) Q:'FBK D
.F L +^FBAAC(FBK):$G(DILOCKTM,3) Q:$T W:'$D(ZTQUEUED) "Another user is editing this entry.",!
.S FBOGN=0
.I '$D(^FBAAC(FBK,1,FBICN,0)) S DIC="^FBAAC(FBK,1,",DA(1)=FBK,(X,DINUM)=FBICN,DIC(0)="" D FILE^DICN
.F S FBOGN=$O(^FBAAC(FBK,1,FBICN1,1,FBOGN)) Q:'FBOGN K DD,DO S DIC="^FBAAC(FBK,1,FBICN,1,",DA(1)=FBICN,DA(2)=FBK,DIC(0)="",DIC("P")="162.02DA",X=$P(^FBAAC(FBK,1,FBICN1,1,FBOGN,0),"^") D FILE^DICN I +$P(Y,U,3) S FBNGN=+Y D
..S %X="^FBAAC(FBK,1,FBICN1,1,FBOGN,",%Y="^FBAAC(FBK,1,FBICN,1,FBNGN," D %XY^%RCR
..S DIK="^FBAAC(FBK,1,FBICN,1,",DA(2)=FBK,DA(1)=FBICN,DA=FBNGN D IX1^DIK K DIK
.S DIK="^FBAAC(FBK,1,",DA(1)=FBK,DA=FBICN1 D ^DIK K DIK L -^FBAAC(FBK)
I $D(^FBAA(162.1,"AN",FBICN1)) S FBJ=0 F S FBJ=$O(^FBAA(162.1,"AN",FBICN1,FBJ)) Q:'FBJ S DIE="^FBAA(162.1,",DA=FBJ,DR="3////^S X=FBICN" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(162.1,DA)
.K DIE,FBLOCK
I $D(^FBAA(162.2,"C",FBICN1)) S FBJ=0 D
.F S FBJ=$O(^FBAA(162.2,"C",FBICN1,FBJ)) Q:'FBJ S DIE="^FBAA(162.2,",DA=FBJ,DR="1////^S X=FBICN" D
..D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(162.2,DA)
..K FBLOCK S DIE="^FBAA(161.5," D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(161.5,DA)
..K DIE,FBLOCK
I $D(^FBAACNH("AH",FBICN1)) S FBJ=0 F S FBJ=$O(^FBAACNH("AH",FBICN1,FBJ)) Q:'FBJ S DIE="^FBAACNH(",DA=FBJ,DR="8////^S X=FBICN" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D L -^FBAACNH(DA)
..D ^DIE
..I $D(^FBAACNH(DA,0)) S DAT=$P(^FBAACNH(DA,0),U),DFN=$P(^FBAACNH(DA,0),U,2) D
...I $D(^FBAACNH("AG",DFN,FBICN1,DAT,DA)) D
....K ^FBAACNH("AG",DFN,FBICN1,DAT,DA)
....S ^FBAACNH("AG",DFN,FBICN,DAT,DA)=""
.K DIE,FBLOCK
I $D(^FB7078("C",FBICN1_";FBAAV(")) S FBJ=0 D
.F S FBJ=$O(^FB7078("C",FBICN1_";FBAAV(",FBJ)) Q:'FBJ S DIE="^FB7078(",DA=FBJ,FBTMP=FBICN_";FBAAV(",DR="1////^S X=FBTMP" D
..D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FB7078(DA)
..K DIE,FBLOCK,FBTMP
I $D(^FBAAI("C",FBICN1)) S FBJ=0 F S FBJ=$O(^FBAAI("C",FBICN1,FBJ)) Q:'FBJ S DIE="^FBAAI(",DA=FBJ,DR="2////^S X=FBICN" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAAI(DA)
.K DIE,FBLOCK
I $D(^FB583("C",FBICN1)) S FBJ=0,FBCHK=";FBAAV(" F S FBJ=$O(^FB583("C",FBICN1,FBJ)) Q:'FBJ S DIE="^FB583(",DA=FBJ,DR="1////^S X=FBICN" S:$P($G(^FB583(FBJ,0)),"^",23)=(FBICN1_FBCHK) DR=DR_";23////^S X=FBICN_FBCHK" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FB583(DA)
.K DIE,FBLOCK
;Delete second vendor from vendor file.
K DIC,DA
S DIK="^FBAAV(",DA=FBICN1 D ^DIK K DIK,FBICN1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBMRASV1 4178 printed Jan 18, 2025@02:59:51 Page 2
FBMRASV1 ;AISC/CMR-Server Routine for MRA Messages Cont'd;4/1/93 ; 8/28/09 12:02pm
+1 ;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
CHANGE ;Process Austin Change Record
+1 ;if fbinc=fbinc1 then transaction was to update fms vendor file, nothing needs to be repointed, and since it is not a duplicate, vendor should not be deleted.
+2 IF FBSTN'=FBSN
Begin DoDot:1
+3 NEW EC
SET (FBICN,FBOUT)=0
SET FBERR=1
SET EC=""
Begin DoDot:2
+4 FOR
SET FBICN=$ORDER(^FBAAV("C",FBVID,FBICN))
if 'FBICN!(FBOUT)
QUIT
Begin DoDot:3
+5 if $PIECE($GET(^FBAAV(FBICN,"ADEL")),"^")="Y"
QUIT
+6 SET EC=""
IF FBRT=4
if $PIECE(^FBAAV(FBICN,0),U,7)'=3
QUIT
if $PIECE(^FBAAV(FBICN,0),U,10)'=FBCHAIN
QUIT
+7 IF FBRT=1
if $PIECE($GET(^FBAAV(FBICN,0)),U,7)=3
QUIT
+8 IF $EXTRACT(FBVNAME,1,5)'=$EXTRACT($PIECE($GET(^FBAAV(FBICN,"AMS")),U),1,5)
IF '+$PIECE($GET(^FBAAV(FBICN,"ADEL")),U,4)
SET EC=4
QUIT
+9 SET FBCNT=FBCNT+1
SET FBOUT=1
SET FBERR=0
DO FILEV^FBMRASVR
End DoDot:3
End DoDot:2
+10 IF FBERR
if EC']""
SET EC=4.1
DO ER^FBMRASV2(EC,FBJ,.FBER)
SET FBERR=0
End DoDot:1
+11 if FBSTN'=FBSN
QUIT
+12 IF FBSTN=FBSN
DO GET^FBMRASVR
if FBMRA']""
DO ER^FBMRASV2(5,FBJ,.FBER)
if FBMRA']""
QUIT
SET FBICN1=FBICN
SET FBICN=$PIECE(FBMRA,"^",6)
IF 'FBICN
KILL FBICN1
QUIT
+13 SET FBCNT=FBCNT+1
DO FILEV^FBMRASVR
DO DELMRA^FBMRASVR
IF FBICN']""!(FBICN=FBICN1)
KILL FBICN1
QUIT
REPOINT ;Re-point pointers to appropriate vendor entry.
+1 NEW DFN,DAT
+2 IF $DATA(^FBAAA("ACV",FBICN1))
SET K=0
FOR
SET K=$ORDER(^FBAAA("ACV",FBICN1,K))
if 'K
QUIT
SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAAA("ACV",FBICN1,K,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAAA(K,1,"
SET DA=FBJ
SET DA(1)=K
SET DR=".04////^S X=FBICN"
DO ^DIE
KILL DIE
+3 IF $DATA(^FBAA(161.21,"C",FBICN1))
SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAA(161.21,"C",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAA(161.21,"
SET DA=FBJ
SET DR=".04////^S X=FBICN"
DO ^DIE
KILL DIE
+4 IF $DATA(^FBAAC("AB",FBICN1))
SET FBK=0
FOR
SET FBK=$ORDER(^FBAAC("AB",FBICN1,FBK))
if 'FBK
QUIT
Begin DoDot:1
+5 FOR
LOCK +^FBAAC(FBK):$GET(DILOCKTM,3)
if $TEST
QUIT
if '$DATA(ZTQUEUED)
WRITE "Another user is editing this entry.",!
+6 SET FBOGN=0
+7 IF '$DATA(^FBAAC(FBK,1,FBICN,0))
SET DIC="^FBAAC(FBK,1,"
SET DA(1)=FBK
SET (X,DINUM)=FBICN
SET DIC(0)=""
DO FILE^DICN
+8 FOR
SET FBOGN=$ORDER(^FBAAC(FBK,1,FBICN1,1,FBOGN))
if 'FBOGN
QUIT
KILL DD,DO
SET DIC="^FBAAC(FBK,1,FBICN,1,"
SET DA(1)=FBICN
SET DA(2)=FBK
SET DIC(0)=""
SET DIC("P")="162.02DA"
SET X=$PIECE(^FBAAC(FBK,1,FBICN1,1,FBOGN,0),"^")
DO FILE^DICN
IF +$PIECE(Y,U,3)
SET FBNGN=+Y
Begin DoDot:2
+9 SET %X="^FBAAC(FBK,1,FBICN1,1,FBOGN,"
SET %Y="^FBAAC(FBK,1,FBICN,1,FBNGN,"
DO %XY^%RCR
+10 SET DIK="^FBAAC(FBK,1,FBICN,1,"
SET DA(2)=FBK
SET DA(1)=FBICN
SET DA=FBNGN
DO IX1^DIK
KILL DIK
End DoDot:2
+11 SET DIK="^FBAAC(FBK,1,"
SET DA(1)=FBK
SET DA=FBICN1
DO ^DIK
KILL DIK
LOCK -^FBAAC(FBK)
End DoDot:1
+12 IF $DATA(^FBAA(162.1,"AN",FBICN1))
SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAA(162.1,"AN",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAA(162.1,"
SET DA=FBJ
SET DR="3////^S X=FBICN"
Begin DoDot:1
+13 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAA(162.1,DA)
+14 KILL DIE,FBLOCK
End DoDot:1
+15 IF $DATA(^FBAA(162.2,"C",FBICN1))
SET FBJ=0
Begin DoDot:1
+16 FOR
SET FBJ=$ORDER(^FBAA(162.2,"C",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAA(162.2,"
SET DA=FBJ
SET DR="1////^S X=FBICN"
Begin DoDot:2
+17 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAA(162.2,DA)
+18 KILL FBLOCK
SET DIE="^FBAA(161.5,"
DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAA(161.5,DA)
+19 KILL DIE,FBLOCK
End DoDot:2
End DoDot:1
+20 IF $DATA(^FBAACNH("AH",FBICN1))
SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAACNH("AH",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAACNH("
SET DA=FBJ
SET DR="8////^S X=FBICN"
Begin DoDot:1
+21 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
Begin DoDot:2
+22 DO ^DIE
+23 IF $DATA(^FBAACNH(DA,0))
SET DAT=$PIECE(^FBAACNH(DA,0),U)
SET DFN=$PIECE(^FBAACNH(DA,0),U,2)
Begin DoDot:3
+24 IF $DATA(^FBAACNH("AG",DFN,FBICN1,DAT,DA))
Begin DoDot:4
+25 KILL ^FBAACNH("AG",DFN,FBICN1,DAT,DA)
+26 SET ^FBAACNH("AG",DFN,FBICN,DAT,DA)=""
End DoDot:4
End DoDot:3
End DoDot:2
LOCK -^FBAACNH(DA)
+27 KILL DIE,FBLOCK
End DoDot:1
+28 IF $DATA(^FB7078("C",FBICN1_";FBAAV("))
SET FBJ=0
Begin DoDot:1
+29 FOR
SET FBJ=$ORDER(^FB7078("C",FBICN1_";FBAAV(",FBJ))
if 'FBJ
QUIT
SET DIE="^FB7078("
SET DA=FBJ
SET FBTMP=FBICN_";FBAAV("
SET DR="1////^S X=FBTMP"
Begin DoDot:2
+30 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FB7078(DA)
+31 KILL DIE,FBLOCK,FBTMP
End DoDot:2
End DoDot:1
+32 IF $DATA(^FBAAI("C",FBICN1))
SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAAI("C",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FBAAI("
SET DA=FBJ
SET DR="2////^S X=FBICN"
Begin DoDot:1
+33 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAAI(DA)
+34 KILL DIE,FBLOCK
End DoDot:1
+35 IF $DATA(^FB583("C",FBICN1))
SET FBJ=0
SET FBCHK=";FBAAV("
FOR
SET FBJ=$ORDER(^FB583("C",FBICN1,FBJ))
if 'FBJ
QUIT
SET DIE="^FB583("
SET DA=FBJ
SET DR="1////^S X=FBICN"
if $PIECE($GET(^FB583(FBJ,0)),"^",23)=(FBICN1_FBCHK)
SET DR=DR_";23////^S X=FBICN_FBCHK"
Begin DoDot:1
+36 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FB583(DA)
+37 KILL DIE,FBLOCK
End DoDot:1
+38 ;Delete second vendor from vendor file.
+39 KILL DIC,DA
+40 SET DIK="^FBAAV("
SET DA=FBICN1
DO ^DIK
KILL DIK,FBICN1
+41 QUIT
