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