FBAAVD ;AISC/DMK-DISPLAY/EDIT VENDOR DEMOGRAPHICS ; 8/28/09 12:35pm
;;3.5;FEE BASIS;**9,98,111,122**;JAN 30, 1995;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;FBTEMP set = 1 if called from input template
RDV ;ask vendor
W ! K DFN,FBRATE S FEEO="",DIC="^FBAAV(",DIC(0)="AEQLM",DLAYGO=161.2,DIC("DR")="1;6;7;8" D ^DIC K DIC,DLAYGO G Q:$D(DTOUT)!(X="")!($D(DUOUT)),RDV:Y<0 S DA=+Y
D NEW:$P(Y,U,3)=1 D EN1
I $G(DA) W ! I $D(^XUSEC("FBAA ESTABLISH VENDOR",DUZ)) S DIR(0)="Y",DIR("B")="No",DIR("A")="Want to edit data" D ^DIR K DIR I $G(Y) D EDITV
Q:$G(FBTEMP)
G RDV
;
EN1 ;display vendor demographics
;DA = IEN of vendor in file 161.2
;
N C,I
Q:'$G(DA)
S Z=$G(^FBAAV(DA,0)),V=$G(^(1)),T=$G(^("AMS")),A=$G(^("ADEL")),FBNPI=$P($G(^(3)),U,2),FBTXC=$P($G(^(3)),U,3)
F X=1:1:17 S Z(X)=$P(Z,U,X)
S FBDEL=$S($P(A,U)="Y":1,1:0),FBAAPN=$P(V,U),FBAAFN=$P(V,U,9)
;Z=zero node,V=one node,T=ams node,A=adel node
;
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS W @IOF K IOP
I +$G(DFN)>0 W !,"Patient Name: ",$P($G(^DPT(DFN,0)),U),?48,"Pt.ID: ",$$SSN^FBAAUTL(DFN),!
W !?22,"*** VENDOR DEMOGRAPHICS ***" D
.I FBDEL W !?19,"==> FLAGGED FOR DELETION <==" Q
.I $$CKVEN^FBAADV(DA) W !?20,"==> AWAITING AUSTIN APPROVAL <=="
W !!,$J("Name:",13),?15,$E(Z(1),1,30),?47,"ID Number: ",Z(2)
W !?40,"Billing Prov NPI: ",FBNPI
W !?31,"Billing Prov Taxonomy code: ",FBTXC ;FB*3.5*122
W !,$J("Address:",13),?15,Z(3),?47,"Specialty: ",$E($P($G(^FBAA(161.6,+Z(8),0)),U),1,20)
I Z(14)]"" W !,$J("Address [2]:",13),?15,Z(14)
W !,$J("City:",13),?15,Z(4),?52,"Type:",?58,$P($P(^DD(161.2,6,0),Z(7)_":",2),";")
;
W !,$J("State:",13),?15,$P($G(^DIC(5,+Z(5),0)),U),?38,"Participation Code:",?58,$S($D(^FBAA(161.81,+Z(9),0)):$E($P(^(0),U),1,21),1:"UNKNOWN")
W !,$J("ZIP:",13),?15,Z(6),?38,"Medicare ID Number:",?59,Z(17)
W !,$J("County:",13),?15,$P($G(^DIC(5,+Z(5),1,+Z(13),0)),U)
W ?51,"Chain: ",Z(10)
W !,$J("Phone:",13),?15,FBAAPN,!,$J("Fax:",13),?15,FBAAFN
W:$P(T,U,2)="Y" ?44,"Pricer Exempt: Yes"
W !,$J("Type (FPDS):",13),?15,$$EXTERNAL^DILFD(161.2,24,"",$P(V,U,10))
S (C,I)=0 F S I=$O(^FBAAV(DA,2,I)) Q:'I D
. S X=$P($G(^FBAAV(DA,2,I,0)),U) Q:'X
. S X=$$GET1^DIQ(420.6,X,1) Q:X=""
. S C=C+1
. I '(C#2) W !,$J("Group (FPDS):",13),?15,$E(X,1,21)
. I (C#2) W ?44,"Group (FPDS):",?59,$E(X,1,21)
W !,$J("Austin Name:",13),?15,$P(T,U)
W !,$J("Last Change ",13),?43,"Last Change" I $P(A,U,5)]"" W " by ",$S($P(A,U,5)="000":"Non-Fee User",1:"Station "_$P(A,U,5))
W !,$J("TO Austin:",13),?15,$$DATX^FBAAUTL($P(A,U,2))
W ?45,"FROM Austin: ",$$DATX^FBAAUTL($P(A,U,4))
;
I Z(9)=5 D ^FBAAVD1
K A,T,V,Z,FBAAFN
Q
;
NEW ;called when adding a new vendor
Q:'$G(DA)
S FBT="N",DIE="^FBAAV(",DR="[FBAA NEW VENDOR]" D ^DIE S Y=$G(^FBAAV(DA,0)) S FBOVEN="" D I +FBOVEN K FBOVEN W ! S DR="3;4;5;5.5" D ^DIE K DIE,DR D CHKVEN Q:'$G(DA)
.I $P(Y,U,4)']"" S FBOVEN=1
.I '$P(Y,U,5) S FBOVEN=$S(+FBOVEN:FBOVEN_"^"_2,1:2)
.I $P(Y,U,6)']"" S FBOVEN=$S(+FBOVEN:FBOVEN_"^"_3,1:3)
.I $P(Y,U,13)']"" S FBOVEN=$S(+FBOVEN:FBOVEN_"^"_4,1:4)
.I +FBOVEN D K XX,X
..W !!?9,"The following data must be entered when adding a new vendor:",!
..W !?28,">>> W A R N I N G <<<",!?14,"Entering an '^' at this point will delete vendor!",!
..F XX=1:1 S X=$P(FBOVEN,U,XX) Q:'X D
...W !?8,$P($T(ERROR+X),";;",2)
D SETGL
S FBVIEN=DA D CONTR^FBAAVD2 S DA=FBVIEN Q
;
EDITV ;called when editing an existing vendor
N FBHDA Q:'$G(DA)
N FBAAOUT G:$G(FBT)="N" EDITV1 I $D(^FBAA(161.25,DA,0))!($D(^FBAA(161.25,"AF",DA))) W !!?5,*7,"Current Vendor information is pending Austin processing. Changing Vendor" D I $G(FBAAOUT) K FBAAOUT Q
.W !?5,"information at this time may jeopardize the processing of the existing",!?5,"Master Record Adjustment!",! D
..S DIR(0)="Y",DIR("A")="Do you wish to continue editing this Vendor",DIR("B")="No" D ^DIR K DIR S:$D(DIRUT)!('Y) FBAAOUT=1
EDITV1 D ^FBAAVD2 K FBCIEN,FBR,FBT
Q
;
SETGL ;called to file an entry in 161.25 (vendor correction file)
I $S('$G(DA):1,$G(FBT)="C"&('$D(FBIEN1)):1,1:0) Q
S Z1=$G(^FBAAV(DA,0)),FBTOV=$S($P(Z1,U,7)=3:"P",1:"O")
I $G(FBT)="N"!($G(FBT)="R") S DIE="^FBAAV(",DR="9///@;13///@" D ^DIE K DIE
I '$D(^FBAA(161.25,DA,0)) F L +^FBAA(161.25,DA):$G(DILOCKTM,3) Q:$T W:'$D(ZTQUEUED) !,"Unable to setup SG MRA transaction. Trying again."
K DD,DO S (X,DINUM)=DA,DIC="^FBAA(161.25,",DIC(0)="L",DLAYGO=161.25 D FILE^DICN K DLAYGO L -^FBAA(161.25,DA) Q:Y<0
NEXT L +^FBAA(161.25,DA):$G(DILOCKTM,3) I '$T W:'$D(ZTQUEUED) !,"Unable to setup NEXT MRA transaction. Trying again.",! G NEXT
S DIE="^FBAA(161.25,",DR="[FBAA VENDOR MRA]" D ^DIE L -^FBAA(161.25,DA)
K DIE,DIC,Y
Q
;
Q K DA,DR,DIC,DIE,DIRUT,DTOUT,DUOUT,A,D,FBX,FBOUT,X2,FY,FBAAPN,FEEO,FBDEL,FBPARCD,FBT,FBTOV,FBTV,X,Y,Z0,Z1,Z2,ZZ,FBCNUM,FBID,FBVIEN,FBLIEN,FBAAFN
Q
ERROR ;edit check text when adding a new vendor
;;CITY
;;STATE
;;ZIP CODE
;;COUNTY CODE
CHKVEN ;check if fields 3,4,5,5.5 have been answered. If not delete vendor
S Y=$G(^FBAAV(DA,0))
F X=4,5,6,13 I $P(Y,U,X)']"" D Q
.S DIK="^FBAAV(" D ^DIK K DIK,DA W !?3,$C(7),".... Vendor deleted",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAVD 5190 printed Sep 23, 2025@19:33:07 Page 2
FBAAVD ;AISC/DMK-DISPLAY/EDIT VENDOR DEMOGRAPHICS ; 8/28/09 12:35pm
+1 ;;3.5;FEE BASIS;**9,98,111,122**;JAN 30, 1995;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;FBTEMP set = 1 if called from input template
RDV ;ask vendor
+1 WRITE !
KILL DFN,FBRATE
SET FEEO=""
SET DIC="^FBAAV("
SET DIC(0)="AEQLM"
SET DLAYGO=161.2
SET DIC("DR")="1;6;7;8"
DO ^DIC
KILL DIC,DLAYGO
if $DATA(DTOUT)!(X="")!($DATA(DUOUT))
GOTO Q
if Y<0
GOTO RDV
SET DA=+Y
+2 if $PIECE(Y,U,3)=1
DO NEW
DO EN1
+3 IF $GET(DA)
WRITE !
IF $DATA(^XUSEC("FBAA ESTABLISH VENDOR",DUZ))
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Want to edit data"
DO ^DIR
KILL DIR
IF $GET(Y)
DO EDITV
+4 if $GET(FBTEMP)
QUIT
+5 GOTO RDV
+6 ;
EN1 ;display vendor demographics
+1 ;DA = IEN of vendor in file 161.2
+2 ;
+3 NEW C,I
+4 if '$GET(DA)
QUIT
+5 SET Z=$GET(^FBAAV(DA,0))
SET V=$GET(^(1))
SET T=$GET(^("AMS"))
SET A=$GET(^("ADEL"))
SET FBNPI=$PIECE($GET(^(3)),U,2)
SET FBTXC=$PIECE($GET(^(3)),U,3)
+6 FOR X=1:1:17
SET Z(X)=$PIECE(Z,U,X)
+7 SET FBDEL=$SELECT($PIECE(A,U)="Y":1,1:0)
SET FBAAPN=$PIECE(V,U)
SET FBAAFN=$PIECE(V,U,9)
+8 ;Z=zero node,V=one node,T=ams node,A=adel node
+9 ;
+10 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
WRITE @IOF
KILL IOP
+11 IF +$GET(DFN)>0
WRITE !,"Patient Name: ",$PIECE($GET(^DPT(DFN,0)),U),?48,"Pt.ID: ",$$SSN^FBAAUTL(DFN),!
+12 WRITE !?22,"*** VENDOR DEMOGRAPHICS ***"
Begin DoDot:1
+13 IF FBDEL
WRITE !?19,"==> FLAGGED FOR DELETION <=="
QUIT
+14 IF $$CKVEN^FBAADV(DA)
WRITE !?20,"==> AWAITING AUSTIN APPROVAL <=="
End DoDot:1
+15 WRITE !!,$JUSTIFY("Name:",13),?15,$EXTRACT(Z(1),1,30),?47,"ID Number: ",Z(2)
+16 WRITE !?40,"Billing Prov NPI: ",FBNPI
+17 ;FB*3.5*122
WRITE !?31,"Billing Prov Taxonomy code: ",FBTXC
+18 WRITE !,$JUSTIFY("Address:",13),?15,Z(3),?47,"Specialty: ",$EXTRACT($PIECE($GET(^FBAA(161.6,+Z(8),0)),U),1,20)
+19 IF Z(14)]""
WRITE !,$JUSTIFY("Address [2]:",13),?15,Z(14)
+20 WRITE !,$JUSTIFY("City:",13),?15,Z(4),?52,"Type:",?58,$PIECE($PIECE(^DD(161.2,6,0),Z(7)_":",2),";")
+21 ;
+22 WRITE !,$JUSTIFY("State:",13),?15,$PIECE($GET(^DIC(5,+Z(5),0)),U),?38,"Participation Code:",?58,$SELECT($DATA(^FBAA(161.81,+Z(9),0)):$EXTRACT($PIECE(^(0),U),1,21),1:"UNKNOWN")
+23 WRITE !,$JUSTIFY("ZIP:",13),?15,Z(6),?38,"Medicare ID Number:",?59,Z(17)
+24 WRITE !,$JUSTIFY("County:",13),?15,$PIECE($GET(^DIC(5,+Z(5),1,+Z(13),0)),U)
+25 WRITE ?51,"Chain: ",Z(10)
+26 WRITE !,$JUSTIFY("Phone:",13),?15,FBAAPN,!,$JUSTIFY("Fax:",13),?15,FBAAFN
+27 if $PIECE(T,U,2)="Y"
WRITE ?44,"Pricer Exempt: Yes"
+28 WRITE !,$JUSTIFY("Type (FPDS):",13),?15,$$EXTERNAL^DILFD(161.2,24,"",$PIECE(V,U,10))
+29 SET (C,I)=0
FOR
SET I=$ORDER(^FBAAV(DA,2,I))
if 'I
QUIT
Begin DoDot:1
+30 SET X=$PIECE($GET(^FBAAV(DA,2,I,0)),U)
if 'X
QUIT
+31 SET X=$$GET1^DIQ(420.6,X,1)
if X=""
QUIT
+32 SET C=C+1
+33 IF '(C#2)
WRITE !,$JUSTIFY("Group (FPDS):",13),?15,$EXTRACT(X,1,21)
+34 IF (C#2)
WRITE ?44,"Group (FPDS):",?59,$EXTRACT(X,1,21)
End DoDot:1
+35 WRITE !,$JUSTIFY("Austin Name:",13),?15,$PIECE(T,U)
+36 WRITE !,$JUSTIFY("Last Change ",13),?43,"Last Change"
IF $PIECE(A,U,5)]""
WRITE " by ",$SELECT($PIECE(A,U,5)="000":"Non-Fee User",1:"Station "_$PIECE(A,U,5))
+37 WRITE !,$JUSTIFY("TO Austin:",13),?15,$$DATX^FBAAUTL($PIECE(A,U,2))
+38 WRITE ?45,"FROM Austin: ",$$DATX^FBAAUTL($PIECE(A,U,4))
+39 ;
+40 IF Z(9)=5
DO ^FBAAVD1
+41 KILL A,T,V,Z,FBAAFN
+42 QUIT
+43 ;
NEW ;called when adding a new vendor
+1 if '$GET(DA)
QUIT
+2 SET FBT="N"
SET DIE="^FBAAV("
SET DR="[FBAA NEW VENDOR]"
DO ^DIE
SET Y=$GET(^FBAAV(DA,0))
SET FBOVEN=""
Begin DoDot:1
+3 IF $PIECE(Y,U,4)']""
SET FBOVEN=1
+4 IF '$PIECE(Y,U,5)
SET FBOVEN=$SELECT(+FBOVEN:FBOVEN_"^"_2,1:2)
+5 IF $PIECE(Y,U,6)']""
SET FBOVEN=$SELECT(+FBOVEN:FBOVEN_"^"_3,1:3)
+6 IF $PIECE(Y,U,13)']""
SET FBOVEN=$SELECT(+FBOVEN:FBOVEN_"^"_4,1:4)
+7 IF +FBOVEN
Begin DoDot:2
+8 WRITE !!?9,"The following data must be entered when adding a new vendor:",!
+9 WRITE !?28,">>> W A R N I N G <<<",!?14,"Entering an '^' at this point will delete vendor!",!
+10 FOR XX=1:1
SET X=$PIECE(FBOVEN,U,XX)
if 'X
QUIT
Begin DoDot:3
+11 WRITE !?8,$PIECE($TEXT(ERROR+X),";;",2)
End DoDot:3
End DoDot:2
KILL XX,X
End DoDot:1
IF +FBOVEN
KILL FBOVEN
WRITE !
SET DR="3;4;5;5.5"
DO ^DIE
KILL DIE,DR
DO CHKVEN
if '$GET(DA)
QUIT
+12 DO SETGL
+13 SET FBVIEN=DA
DO CONTR^FBAAVD2
SET DA=FBVIEN
QUIT
+14 ;
EDITV ;called when editing an existing vendor
+1 NEW FBHDA
if '$GET(DA)
QUIT
+2 NEW FBAAOUT
if $GET(FBT)="N"
GOTO EDITV1
IF $DATA(^FBAA(161.25,DA,0))!($DATA(^FBAA(161.25,"AF",DA)))
WRITE !!?5,*7,"Current Vendor information is pending Austin processing. Changing Vendor"
Begin DoDot:1
+3 WRITE !?5,"information at this time may jeopardize the processing of the existing",!?5,"Master Record Adjustment!",!
Begin DoDot:2
+4 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue editing this Vendor"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
SET FBAAOUT=1
End DoDot:2
End DoDot:1
IF $GET(FBAAOUT)
KILL FBAAOUT
QUIT
EDITV1 DO ^FBAAVD2
KILL FBCIEN,FBR,FBT
+1 QUIT
+2 ;
SETGL ;called to file an entry in 161.25 (vendor correction file)
+1 IF $SELECT('$GET(DA):1,$GET(FBT)="C"&('$DATA(FBIEN1)):1,1:0)
QUIT
+2 SET Z1=$GET(^FBAAV(DA,0))
SET FBTOV=$SELECT($PIECE(Z1,U,7)=3:"P",1:"O")
+3 IF $GET(FBT)="N"!($GET(FBT)="R")
SET DIE="^FBAAV("
SET DR="9///@;13///@"
DO ^DIE
KILL DIE
+4 IF '$DATA(^FBAA(161.25,DA,0))
FOR
LOCK +^FBAA(161.25,DA):$GET(DILOCKTM,3)
if $TEST
QUIT
if '$DATA(ZTQUEUED)
WRITE !,"Unable to setup SG MRA transaction. Trying again."
+5 KILL DD,DO
SET (X,DINUM)=DA
SET DIC="^FBAA(161.25,"
SET DIC(0)="L"
SET DLAYGO=161.25
DO FILE^DICN
KILL DLAYGO
LOCK -^FBAA(161.25,DA)
if Y<0
QUIT
NEXT LOCK +^FBAA(161.25,DA):$GET(DILOCKTM,3)
IF '$TEST
if '$DATA(ZTQUEUED)
WRITE !,"Unable to setup NEXT MRA transaction. Trying again.",!
GOTO NEXT
+1 SET DIE="^FBAA(161.25,"
SET DR="[FBAA VENDOR MRA]"
DO ^DIE
LOCK -^FBAA(161.25,DA)
+2 KILL DIE,DIC,Y
+3 QUIT
+4 ;
Q KILL DA,DR,DIC,DIE,DIRUT,DTOUT,DUOUT,A,D,FBX,FBOUT,X2,FY,FBAAPN,FEEO,FBDEL,FBPARCD,FBT,FBTOV,FBTV,X,Y,Z0,Z1,Z2,ZZ,FBCNUM,FBID,FBVIEN,FBLIEN,FBAAFN
+1 QUIT
ERROR ;edit check text when adding a new vendor
+1 ;;CITY
+2 ;;STATE
+3 ;;ZIP CODE
+4 ;;COUNTY CODE
CHKVEN ;check if fields 3,4,5,5.5 have been answered. If not delete vendor
+1 SET Y=$GET(^FBAAV(DA,0))
+2 FOR X=4,5,6,13
IF $PIECE(Y,U,X)']""
Begin DoDot:1
+3 SET DIK="^FBAAV("
DO ^DIK
KILL DIK,DA
WRITE !?3,$CHAR(7),".... Vendor deleted",!
End DoDot:1
QUIT
+4 QUIT
