FHPRI3.m

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

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