- FBVDISP ;AISC/CMR-VENDOR DISPLAY IDENTIFIERS - APR 9, 1993
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- N FBT,FBVC,FBZ S FBT(0)=$G(^FBAAV(Y,0)) Q:FBT(0)']"" F FBT=2,3,4,5,6,9,10,14 S FBT(FBT)=$P(FBT(0),U,FBT)
- S FBT(99)=$P($G(^FBAAV(Y,1)),U),FBT(98)=$P($G(^FBAAV(Y,"ADEL")),U)
- W:FBT(2)]"" ?40,FBT(2)
- W:FBT(10) " CHAIN #: ",FBT(10)
- W:FBT(9)]"" " ",$E($P($G(^FBAA(161.81,+FBT(9),0)),U),1,15)
- W:FBT(3)]"" !?10,FBT(3) D
- .S FBZ=$$CKVEN^FBAADV(+Y) I FBZ W:FBT(3)']"" ! W ?40,"(Awaiting Austin Approval)"
- .I FBT(98)="Y" W:FBT(3)']""!(FBZ) ! W ?40,"(Vendor in Delete Status)"
- W:FBT(14)]"" !?10,FBT(14)
- W:FBT(4)]"" !?10,FBT(4)
- W:FBT(5)]"" ", ",$P($G(^DIC(5,+FBT(5),0)),U,2)
- W:FBT(6)]"" " ",FBT(6)
- W:FBT(99)]"" " TEL. #: ",FBT(99)
- W !?1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBVDISP 820 printed Feb 18, 2025@23:27:18 Page 2
- FBVDISP ;AISC/CMR-VENDOR DISPLAY IDENTIFIERS - APR 9, 1993
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 NEW FBT,FBVC,FBZ
- SET FBT(0)=$GET(^FBAAV(Y,0))
- if FBT(0)']""
- QUIT
- FOR FBT=2,3,4,5,6,9,10,14
- SET FBT(FBT)=$PIECE(FBT(0),U,FBT)
- +4 SET FBT(99)=$PIECE($GET(^FBAAV(Y,1)),U)
- SET FBT(98)=$PIECE($GET(^FBAAV(Y,"ADEL")),U)
- +5 if FBT(2)]""
- WRITE ?40,FBT(2)
- +6 if FBT(10)
- WRITE " CHAIN #: ",FBT(10)
- +7 if FBT(9)]""
- WRITE " ",$EXTRACT($PIECE($GET(^FBAA(161.81,+FBT(9),0)),U),1,15)
- +8 if FBT(3)]""
- WRITE !?10,FBT(3)
- Begin DoDot:1
- +9 SET FBZ=$$CKVEN^FBAADV(+Y)
- IF FBZ
- if FBT(3)']""
- WRITE !
- WRITE ?40,"(Awaiting Austin Approval)"
- +10 IF FBT(98)="Y"
- if FBT(3)']""!(FBZ)
- WRITE !
- WRITE ?40,"(Vendor in Delete Status)"
- End DoDot:1
- +11 if FBT(14)]""
- WRITE !?10,FBT(14)
- +12 if FBT(4)]""
- WRITE !?10,FBT(4)
- +13 if FBT(5)]""
- WRITE ", ",$PIECE($GET(^DIC(5,+FBT(5),0)),U,2)
- +14 if FBT(6)]""
- WRITE " ",FBT(6)
- +15 if FBT(99)]""
- WRITE " TEL. #: ",FBT(99)
- +16 WRITE !?1
