- 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 Feb 18, 2025@23:23:28 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