FHPRI3 ; HISC/REL - List Vendors ;4/27/93 13:36
;;5.5;DIETETICS;;Jan 28, 2005
L1 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHPRI3",FHLST="" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Print Vendors List
D NOW^%DTC S DTP=% D DTP^FH S PG=0,Y="" D HDR
S NX="" F K=0:0 S NX=$O(^FH(113.2,"B",NX)) Q:NX=""!(Y="^") F D0=0:0 S D0=$O(^FH(113.2,"B",NX,D0)) Q:D0<1!(Y="^") D Q2
W ! Q
Q2 S X=$G(^FH(113.2,D0,0)) Q:X="" D:$Y>(IOSL-11) HDR Q:Y="^"
K A S N=0 F L=1:1:4 S A(L)="",Z=$P(X,"^",L+1) I Z'="" S N=N+1,A(N)=Z
S N=4 F L=5,6 S A(L)="",Z=$P(X,"^",L+1) I Z'="" S N=N+1,A(N)=Z
W !,$P(X,"^",1) W:A(1)'="" ?40,A(1)
I A(2)'=""!(A(5)'="") W ! W:A(5)'="" ?5,A(5) W:A(2)'="" ?40,A(2)
I A(3)'=""!(A(6)'="") W ! W:A(6)'="" ?5,A(6) W:A(3)'="" ?40,A(3)
W:A(4)'="" !?40,A(4) W ! Q
HDR I PG,IOST?1"C".E W *7 R Y:DTIME S:'$T Y="^" Q:Y="^"
W:'($E(IOST,1,2)'="C-"&'PG) @IOF
S PG=PG+1 W !,DTP,?29,"V E N D O R L I S T",?72,"Page ",PG
W !!,"NAME",?40,"ADDRESS"
W !,"-------------------------------------------------------------------------------",! Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRI3 1174 printed Apr 09, 2024@20:52:11 Page 2
FHPRI3 ; HISC/REL - List Vendors ;4/27/93 13:36
+1 ;;5.5;DIETETICS;;Jan 28, 2005
L1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHPRI3"
SET FHLST=""
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Print Vendors List
+1 DO NOW^%DTC
SET DTP=%
DO DTP^FH
SET PG=0
SET Y=""
DO HDR
+2 SET NX=""
FOR K=0:0
SET NX=$ORDER(^FH(113.2,"B",NX))
if NX=""!(Y="^")
QUIT
FOR D0=0:0
SET D0=$ORDER(^FH(113.2,"B",NX,D0))
if D0<1!(Y="^")
QUIT
DO Q2
+3 WRITE !
QUIT
Q2 SET X=$GET(^FH(113.2,D0,0))
if X=""
QUIT
if $Y>(IOSL-11)
DO HDR
if Y="^"
QUIT
+1 KILL A
SET N=0
FOR L=1:1:4
SET A(L)=""
SET Z=$PIECE(X,"^",L+1)
IF Z'=""
SET N=N+1
SET A(N)=Z
+2 SET N=4
FOR L=5,6
SET A(L)=""
SET Z=$PIECE(X,"^",L+1)
IF Z'=""
SET N=N+1
SET A(N)=Z
+3 WRITE !,$PIECE(X,"^",1)
if A(1)'=""
WRITE ?40,A(1)
+4 IF A(2)'=""!(A(5)'="")
WRITE !
if A(5)'=""
WRITE ?5,A(5)
if A(2)'=""
WRITE ?40,A(2)
+5 IF A(3)'=""!(A(6)'="")
WRITE !
if A(6)'=""
WRITE ?5,A(6)
if A(3)'=""
WRITE ?40,A(3)
+6 if A(4)'=""
WRITE !?40,A(4)
WRITE !
QUIT
HDR IF PG
IF IOST?1"C".E
WRITE *7
READ Y:DTIME
if '$TEST
SET Y="^"
if Y="^"
QUIT
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+2 SET PG=PG+1
WRITE !,DTP,?29,"V E N D O R L I S T",?72,"Page ",PG
+3 WRITE !!,"NAME",?40,"ADDRESS"
+4 WRITE !,"-------------------------------------------------------------------------------",!
QUIT
KIL GOTO KILL^XUSCLEAN
