FHPRI2 ; HISC/REL/NCA - Ingredient Lists ;3/6/95 16:04
;;5.5;DIETETICS;;Jan 28, 2005
LIS1 ; List Ingredients - Recipe data
S FHX1=1 G L0
LIS2 ; List Ingredients - Purchasing data
S FHX1=2 G L0
LIS3 ; List Ingredients - Nutrient data
S FHX1=3 G L0
L0 R !!,"Sort: (A=Alphabetically F=Food Group V=Vendor) F// ",FHX2:DTIME G:'$T!(FHX2="^") KIL S:FHX2="" FHX2="F" I "afv"[FHX2 S X=FHX2 D TR^FH S FHX2=X
I FHX2'?1U!("AFV"'[FHX2) W *7," Enter A, F or V" G L0
L1 W !!,"The list requires a 132 column printer.",!
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^FHPRI2",FHLST="FHX1^FHX2" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; List Ingredients
D NOW^%DTC S DTP=% D DTP^FH I FHX2'="A" G Q2
S PG=0 D HDR
S NX="" F K=0:0 S NX=$O(^FHING("B",NX)) Q:NX="" F D0=0:0 S D0=$O(^FHING("B",NX,D0)) Q:D0<1 D P0
W ! Q
Q2 S PG=0,OLD="" K ^TMP($J)
F K=0:0 S K=$O(^FHING(K)) Q:K<1 S X=^(K,0) D Q3
S GRP="" F K=0:0 S GRP=$O(^TMP($J,GRP)) Q:GRP="" S NAM="" F NX=0:0 S NAM=$O(^TMP($J,GRP,NAM)) Q:NAM="" F D0=0:0 S D0=$O(^TMP($J,GRP,NAM,D0)) Q:D0<1 D:GRP'=OLD H0 D P0
W ! Q
Q3 S NAM=$P(X,"^",1) I FHX2="F" S GRP=$P(X,"^",13) S:GRP<1 GRP=9
E S GRP=$P(X,"^",4) S:GRP GRP=$P($G(^FH(113.2,GRP,0)),"^",1) S:GRP="" GRP="~~~"
S ^TMP($J,GRP,$E(NAM,1,30),K)="" Q
P0 D:$Y>(IOSL-8) HDR S X=$G(^FHING(D0,0))
G P1:FHX1=1,P2:FHX1=2,P3:FHX1=3 Q
P1 W !,$P(X,"^",1) S Y=$P(X,"^",3),Y=$E(Y,$L(Y)-3,16) W:Y'="" ?53,Y
S Y=$P(X,"^",12),Y=$S(Y="":Y,$D(^FH(113.1,Y,0))#2:$P(^(0),"^",2),1:Y) W:Y'="" ?61,Y
W ?70,$P(X,"^",20),?75,$P(X,"^",5) S Y=$P(X,"^",8) W:Y'="" ?81,$J(+Y,10)
S Y=$P(X,"^",6) S Y=$S(Y="":Y,$D(^FH(119.1,Y,0))#2:$P(^(0),"^",1),1:Y) W:Y'="" ?94,$E(Y,1,15)
S Y=$P(X,"^",17) W:Y'="" ?113,$J(+Y,10)
S Y=$P(X,"^",16) W:Y'="" ?126,Y Q
P2 W !,$E($P(X,"^",1),1,49),?50,$P(X,"^",2),?73,$P(X,"^",3),?92,$P(X,"^",13)
S Y=$P(X,"^",4) S Y=$S(Y="":Y,$D(^FH(113.2,Y,0))#2:$P(^(0),"^",1),1:Y) W:Y'="" ?95,$E(Y,1,17)
W ?114,$P(X,"^",5)
S Y=$P(X,"^",7) W:Y'="" ?117,$J(Y,6,0)
S Y=$P(X,"^",9) W:Y'="" ?123,$J(Y,8,3) Q
P3 W !,$E($P(X,"^",1),1,50) S Y=$P(X,"^",21),Y=$S(Y="":Y,$D(^FHNU(Y,0))#2:$E($P(^(0),"^",1),1,40),1:Y) W:Y'="" ?53,Y
S Y=$P(X,"^",16) W:Y'="" ?110,Y
S Y=$P(X,"^",22) W:Y'="" ?120,$J(Y,7,3) Q
H0 S OLD=GRP
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 G H1:FHX1=1,H2:FHX1=2,H3:FHX1=3 Q
H1 W !,DTP,?44,"I N G R E D I E N T R E C I P E D A T A",?124,"Page ",PG
D:FHX2'="A" H5
W !!,"NAME",?53,"STOCK",?60,"LOC'N",?68,"THAW",?75,"U/P",?85,"ISS/UP",?94,"ISSUE",?116,"REC/ISS",?126,"REC" G H4
H2 W !,DTP,?40,"I N G R E D I E N T P U R C H A S I N G D A T A",?124,"Page ",PG
D:FHX2'="A" H5
W !!,"NAME",?50,"SUPPLY DESCRIPTION",?73,"STOCK NUMBER",?91,"GRP VENDOR",?114,"U/P",?119,"MULT",?126,"PRICE" G H4
H3 W !,DTP,?42,"I N G R E D I E N T N U T R I E N T D A T A",?124,"Page ",PG
D:FHX2'="A" H5
W !!,"NAME",?53,"NUTRIENT DATA REFERENCE",?108,"REC UNIT",?119,"WT IN LBS."
H4 W !,"-----------------------------------------------------------------------------------------------------------------------------------",! Q
H5 I FHX2="F" S Y="Food Group: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^^^UNCLASSIFIED","^",GRP)
E S Y="Vendor: "_$S(GRP'="~~~":GRP,1:"Unknown")
W !!?(131-$L(Y)\2),Y Q
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRI2 3440 printed Dec 13, 2024@01:54:31 Page 2
FHPRI2 ; HISC/REL/NCA - Ingredient Lists ;3/6/95 16:04
+1 ;;5.5;DIETETICS;;Jan 28, 2005
LIS1 ; List Ingredients - Recipe data
+1 SET FHX1=1
GOTO L0
LIS2 ; List Ingredients - Purchasing data
+1 SET FHX1=2
GOTO L0
LIS3 ; List Ingredients - Nutrient data
+1 SET FHX1=3
GOTO L0
L0 READ !!,"Sort: (A=Alphabetically F=Food Group V=Vendor) F// ",FHX2:DTIME
if '$TEST!(FHX2="^")
GOTO KIL
if FHX2=""
SET FHX2="F"
IF "afv"[FHX2
SET X=FHX2
DO TR^FH
SET FHX2=X
+1 IF FHX2'?1U!("AFV"'[FHX2)
WRITE *7," Enter A, F or V"
GOTO L0
L1 WRITE !!,"The list requires a 132 column printer.",!
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHPRI2"
SET FHLST="FHX1^FHX2"
DO EN2^FH
GOTO KIL
+3 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; List Ingredients
+1 DO NOW^%DTC
SET DTP=%
DO DTP^FH
IF FHX2'="A"
GOTO Q2
+2 SET PG=0
DO HDR
+3 SET NX=""
FOR K=0:0
SET NX=$ORDER(^FHING("B",NX))
if NX=""
QUIT
FOR D0=0:0
SET D0=$ORDER(^FHING("B",NX,D0))
if D0<1
QUIT
DO P0
+4 WRITE !
QUIT
Q2 SET PG=0
SET OLD=""
KILL ^TMP($JOB)
+1 FOR K=0:0
SET K=$ORDER(^FHING(K))
if K<1
QUIT
SET X=^(K,0)
DO Q3
+2 SET GRP=""
FOR K=0:0
SET GRP=$ORDER(^TMP($JOB,GRP))
if GRP=""
QUIT
SET NAM=""
FOR NX=0:0
SET NAM=$ORDER(^TMP($JOB,GRP,NAM))
if NAM=""
QUIT
FOR D0=0:0
SET D0=$ORDER(^TMP($JOB,GRP,NAM,D0))
if D0<1
QUIT
if GRP'=OLD
DO H0
DO P0
+3 WRITE !
QUIT
Q3 SET NAM=$PIECE(X,"^",1)
IF FHX2="F"
SET GRP=$PIECE(X,"^",13)
if GRP<1
SET GRP=9
+1 IF '$TEST
SET GRP=$PIECE(X,"^",4)
if GRP
SET GRP=$PIECE($GET(^FH(113.2,GRP,0)),"^",1)
if GRP=""
SET GRP="~~~"
+2 SET ^TMP($JOB,GRP,$EXTRACT(NAM,1,30),K)=""
QUIT
P0 if $Y>(IOSL-8)
DO HDR
SET X=$GET(^FHING(D0,0))
+1 if FHX1=1
GOTO P1
if FHX1=2
GOTO P2
if FHX1=3
GOTO P3
QUIT
P1 WRITE !,$PIECE(X,"^",1)
SET Y=$PIECE(X,"^",3)
SET Y=$EXTRACT(Y,$LENGTH(Y)-3,16)
if Y'=""
WRITE ?53,Y
+1 SET Y=$PIECE(X,"^",12)
SET Y=$SELECT(Y="":Y,$DATA(^FH(113.1,Y,0))#2:$PIECE(^(0),"^",2),1:Y)
if Y'=""
WRITE ?61,Y
+2 WRITE ?70,$PIECE(X,"^",20),?75,$PIECE(X,"^",5)
SET Y=$PIECE(X,"^",8)
if Y'=""
WRITE ?81,$JUSTIFY(+Y,10)
+3 SET Y=$PIECE(X,"^",6)
SET Y=$SELECT(Y="":Y,$DATA(^FH(119.1,Y,0))#2:$PIECE(^(0),"^",1),1:Y)
if Y'=""
WRITE ?94,$EXTRACT(Y,1,15)
+4 SET Y=$PIECE(X,"^",17)
if Y'=""
WRITE ?113,$JUSTIFY(+Y,10)
+5 SET Y=$PIECE(X,"^",16)
if Y'=""
WRITE ?126,Y
QUIT
P2 WRITE !,$EXTRACT($PIECE(X,"^",1),1,49),?50,$PIECE(X,"^",2),?73,$PIECE(X,"^",3),?92,$PIECE(X,"^",13)
+1 SET Y=$PIECE(X,"^",4)
SET Y=$SELECT(Y="":Y,$DATA(^FH(113.2,Y,0))#2:$PIECE(^(0),"^",1),1:Y)
if Y'=""
WRITE ?95,$EXTRACT(Y,1,17)
+2 WRITE ?114,$PIECE(X,"^",5)
+3 SET Y=$PIECE(X,"^",7)
if Y'=""
WRITE ?117,$JUSTIFY(Y,6,0)
+4 SET Y=$PIECE(X,"^",9)
if Y'=""
WRITE ?123,$JUSTIFY(Y,8,3)
QUIT
P3 WRITE !,$EXTRACT($PIECE(X,"^",1),1,50)
SET Y=$PIECE(X,"^",21)
SET Y=$SELECT(Y="":Y,$DATA(^FHNU(Y,0))#2:$EXTRACT($PIECE(^(0),"^",1),1,40),1:Y)
if Y'=""
WRITE ?53,Y
+1 SET Y=$PIECE(X,"^",16)
if Y'=""
WRITE ?110,Y
+2 SET Y=$PIECE(X,"^",22)
if Y'=""
WRITE ?120,$JUSTIFY(Y,7,3)
QUIT
H0 SET OLD=GRP
HDR if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
if FHX1=1
GOTO H1
if FHX1=2
GOTO H2
if FHX1=3
GOTO H3
QUIT
H1 WRITE !,DTP,?44,"I N G R E D I E N T R E C I P E D A T A",?124,"Page ",PG
+1 if FHX2'="A"
DO H5
+2 WRITE !!,"NAME",?53,"STOCK",?60,"LOC'N",?68,"THAW",?75,"U/P",?85,"ISS/UP",?94,"ISSUE",?116,"REC/ISS",?126,"REC"
GOTO H4
H2 WRITE !,DTP,?40,"I N G R E D I E N T P U R C H A S I N G D A T A",?124,"Page ",PG
+1 if FHX2'="A"
DO H5
+2 WRITE !!,"NAME",?50,"SUPPLY DESCRIPTION",?73,"STOCK NUMBER",?91,"GRP VENDOR",?114,"U/P",?119,"MULT",?126,"PRICE"
GOTO H4
H3 WRITE !,DTP,?42,"I N G R E D I E N T N U T R I E N T D A T A",?124,"Page ",PG
+1 if FHX2'="A"
DO H5
+2 WRITE !!,"NAME",?53,"NUTRIENT DATA REFERENCE",?108,"REC UNIT",?119,"WT IN LBS."
H4 WRITE !,"-----------------------------------------------------------------------------------------------------------------------------------",!
QUIT
H5 IF FHX2="F"
SET Y="Food Group: "_$PIECE("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^^^UNCLASSIFIED","^",GRP)
+1 IF '$TEST
SET Y="Vendor: "_$SELECT(GRP'="~~~":GRP,1:"Unknown")
+2 WRITE !!?(131-$LENGTH(Y)\2),Y
QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
