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 Oct 16, 2024@18:01:42 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
