FHPRO5 ; HISC/REL - Recipe Preparation ;7/18/94 16:39
;;5.5;DIETETICS;**3**;Jan 28, 2005
;RVD 5/23/05 0 - as part of AFP project.
I FHP3="Y"!(FHP4="Y") D Q1 D:FHP3="Y" Q2 D:FHP4="Y" ^FHPRO6
D:FHP5="Y" ^FHPRO7 Q
Q1 ; Set-up Recipe Prep and Storeroom scratch global
K R S K4="" F K=0:0 S K4=$O(^TMP($J,"FH","T",K4)) Q:K4="" F L1=0:0 S L1=$O(^TMP($J,"FH","T",K4,L1)) Q:L1<1 S:'$D(R(L1)) R(L1)=0 S R(L1)=R(L1)+^(L1)
G1 F K1=0:0 S K1=$O(R(K1)) Q:K1<1 D P3
G:$O(R(""))'="" G1
Q
P3 S X0=$G(^FH(114,K1,0)),P1=R(K1),MUL=$P(X0,"^",2) K R(K1) Q:'MUL S MUL=P1/MUL
S S1=$P(X0,"^",12) S:S1 S1=$P($G(^FH(114.2,S1,0)),"^",3)
S S1=$S(S1<1:99,S1<10:"0"_S1,1:S1)_$E($P(X0,"^",1),1,28)
I FHP3="Y" S:$D(^TMP($J,"FH","I",S1,K1))#2=0 ^TMP($J,"FH","I",S1,K1)=0 S ^(K1)=^(K1)+P1
F KK=0:0 S KK=$O(^FH(114,K1,"I",KK)) Q:KK<1 S Y=^(KK,0) D P4
F KK=0:0 S KK=$O(^FH(114,K1,"R",KK)) Q:KK<1 S Y=^(KK,0) D P6
Q
P4 S X1=+Y,Q=$P(Y,"^",2)*MUL
S Y0=$G(^FHING(X1,0))
S S2=$P(Y0,"^",12) S:S2 S2=$P($G(^FH(113.1,S2,0)),"^",3)
S S2=$S(S2<1:99,S2<10:"0"_S2,1:S2)_$E($P(Y0,"^",1),1,28) G:FHP3'="Y" P5
S:'$D(^TMP($J,"FH","I",S1,K1,S2,X1)) ^TMP($J,"FH","I",S1,K1,S2,X1)=0 S ^(X1)=^(X1)+Q
P5 Q:FHP4'="Y"
S:'$D(^TMP($J,"FH","S",S2,X1,S1,K1)) ^TMP($J,"FH","S",S2,X1,S1,K1)=0 S ^(K1)=^(K1)+Q Q
P6 S P1=$P(Y,"^",2)*MUL S:'$D(R(+Y)) R(+Y)=0 S R(+Y)=R(+Y)+P1 Q
Q2 ; Print Recipe Preparation
S OLD="",R1="" I $P(FHPAR,"^",4)'="Y" S PG=0 D HDR
S1 S R1=$O(^TMP($J,"FH","I",R1)) I R1="" W ! Q
F K1=0:0 S K1=$O(^TMP($J,"FH","I",R1,K1)) Q:K1<1 S TOT=^(K1),FLG=0,R2="",X0=^FH(114,K1,0) D S2
G S1
S2 I $P(FHPAR,"^",4)="Y",OLD'=$E(R1,1,2) S OLD=$E(R1,1,2),PG=0 D HDR
S3 S R2=$O(^TMP($J,"FH","I",R1,K1,R2)) Q:R2=""
F X1=0:0 S X1=$O(^TMP($J,"FH","I",R1,K1,R2,X1)) Q:X1<1 D S4
G S3
S4 D:$Y>(IOSL-7) HDR W ! G:FLG S5 W !,$P(X0,"^",1) S FLG=1
I $P(FHPAR,"^",4)'="Y" S Z=$P(X0,"^",12) S:Z Z=$P(^FH(114.2,Z,0),"^",2) W:Z'="" " (",Z,")"
W ?39,$J(TOT,5,0)
S5 S (Y,I1)=^TMP($J,"FH","I",R1,K1,R2,X1)
S Y(0)=$G(^FHING(X1,0)),UNT=$P(Y(0),"^",16) D EN2^FHREC1
W ?46,$E($P(Y(0),"^",1),1,42),?90,Y S I2=$P(Y(0),"^",17) Q:'I2 S I1=I1/I2 Q:'I1
S I1=+$J(I1,0,1) W ?113,I1," ",$P(Y(0),"^",6) Q
B0 S LAB=$P(FHPAR,"^",10),R2=LAB=2*5+32
F KK=0:0 S KK=$O(^TMP($J,"FH","I",KK)) Q:KK<1 F K1=0:0 S K1=$O(^TMP($J,"FH","I",KK,K1)) Q:K1<1 D B1
F X1=1:1:18 W !
Q
B1 F X1=0:0 S X1=$O(^TMP($J,"FH","I",KK,K1,X1)) Q:X1<1 S (Y,I1)=^(X1) D B2
Q
B2 S Y(0)=^FHING(X1,0),UNT=$P(Y(0),"^",16) D EN2^FHREC1
S I2=$P(Y(0),"^",17) Q:'I2 S I1=I1/I2
S I1=$S(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1)
W !,$E($P(Y(0),"^",1),1,R2),!!,I1," ",$P(Y(0),"^",6),!!,$E($P(^FH(114,K1,0),"^",1),1,R2),! Q
HDR S PG=PG+1 W @IOF,!,DTP,?48,"R E C I P E P R E P A R A T I O N",?125,"Page ",PG
W !,FHRETYP,?(131-$L(FHP6)),FHP6
W ! D:$P(FHPAR,"^",4)="Y" PRE W ?(132-$L(TIM)\2),TIM
W !!,"Recipe",?40,"Port. Ingredient",?90,"Quantity",?113,"Storeroom Amount"
W ! F K=1:1:131 W "-"
Q
PRE S K=$P(X0,"^",12) S:K K=$P($G(^FH(114.2,K,0)),"^",1)
W:K'="" K Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRO5 3029 printed Dec 13, 2024@01:54:39 Page 2
FHPRO5 ; HISC/REL - Recipe Preparation ;7/18/94 16:39
+1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
+2 ;RVD 5/23/05 0 - as part of AFP project.
+3 IF FHP3="Y"!(FHP4="Y")
DO Q1
if FHP3="Y"
DO Q2
if FHP4="Y"
DO ^FHPRO6
+4 if FHP5="Y"
DO ^FHPRO7
QUIT
Q1 ; Set-up Recipe Prep and Storeroom scratch global
+1 KILL R
SET K4=""
FOR K=0:0
SET K4=$ORDER(^TMP($JOB,"FH","T",K4))
if K4=""
QUIT
FOR L1=0:0
SET L1=$ORDER(^TMP($JOB,"FH","T",K4,L1))
if L1<1
QUIT
if '$DATA(R(L1))
SET R(L1)=0
SET R(L1)=R(L1)+^(L1)
G1 FOR K1=0:0
SET K1=$ORDER(R(K1))
if K1<1
QUIT
DO P3
+1 if $ORDER(R(""))'=""
GOTO G1
+2 QUIT
P3 SET X0=$GET(^FH(114,K1,0))
SET P1=R(K1)
SET MUL=$PIECE(X0,"^",2)
KILL R(K1)
if 'MUL
QUIT
SET MUL=P1/MUL
+1 SET S1=$PIECE(X0,"^",12)
if S1
SET S1=$PIECE($GET(^FH(114.2,S1,0)),"^",3)
+2 SET S1=$SELECT(S1<1:99,S1<10:"0"_S1,1:S1)_$EXTRACT($PIECE(X0,"^",1),1,28)
+3 IF FHP3="Y"
if $DATA(^TMP($JOB,"FH","I",S1,K1))#2=0
SET ^TMP($JOB,"FH","I",S1,K1)=0
SET ^(K1)=^(K1)+P1
+4 FOR KK=0:0
SET KK=$ORDER(^FH(114,K1,"I",KK))
if KK<1
QUIT
SET Y=^(KK,0)
DO P4
+5 FOR KK=0:0
SET KK=$ORDER(^FH(114,K1,"R",KK))
if KK<1
QUIT
SET Y=^(KK,0)
DO P6
+6 QUIT
P4 SET X1=+Y
SET Q=$PIECE(Y,"^",2)*MUL
+1 SET Y0=$GET(^FHING(X1,0))
+2 SET S2=$PIECE(Y0,"^",12)
if S2
SET S2=$PIECE($GET(^FH(113.1,S2,0)),"^",3)
+3 SET S2=$SELECT(S2<1:99,S2<10:"0"_S2,1:S2)_$EXTRACT($PIECE(Y0,"^",1),1,28)
if FHP3'="Y"
GOTO P5
+4 if '$DATA(^TMP($JOB,"FH","I",S1,K1,S2,X1))
SET ^TMP($JOB,"FH","I",S1,K1,S2,X1)=0
SET ^(X1)=^(X1)+Q
P5 if FHP4'="Y"
QUIT
+1 if '$DATA(^TMP($JOB,"FH","S",S2,X1,S1,K1))
SET ^TMP($JOB,"FH","S",S2,X1,S1,K1)=0
SET ^(K1)=^(K1)+Q
QUIT
P6 SET P1=$PIECE(Y,"^",2)*MUL
if '$DATA(R(+Y))
SET R(+Y)=0
SET R(+Y)=R(+Y)+P1
QUIT
Q2 ; Print Recipe Preparation
+1 SET OLD=""
SET R1=""
IF $PIECE(FHPAR,"^",4)'="Y"
SET PG=0
DO HDR
S1 SET R1=$ORDER(^TMP($JOB,"FH","I",R1))
IF R1=""
WRITE !
QUIT
+1 FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"FH","I",R1,K1))
if K1<1
QUIT
SET TOT=^(K1)
SET FLG=0
SET R2=""
SET X0=^FH(114,K1,0)
DO S2
+2 GOTO S1
S2 IF $PIECE(FHPAR,"^",4)="Y"
IF OLD'=$EXTRACT(R1,1,2)
SET OLD=$EXTRACT(R1,1,2)
SET PG=0
DO HDR
S3 SET R2=$ORDER(^TMP($JOB,"FH","I",R1,K1,R2))
if R2=""
QUIT
+1 FOR X1=0:0
SET X1=$ORDER(^TMP($JOB,"FH","I",R1,K1,R2,X1))
if X1<1
QUIT
DO S4
+2 GOTO S3
S4 if $Y>(IOSL-7)
DO HDR
WRITE !
if FLG
GOTO S5
WRITE !,$PIECE(X0,"^",1)
SET FLG=1
+1 IF $PIECE(FHPAR,"^",4)'="Y"
SET Z=$PIECE(X0,"^",12)
if Z
SET Z=$PIECE(^FH(114.2,Z,0),"^",2)
if Z'=""
WRITE " (",Z,")"
+2 WRITE ?39,$JUSTIFY(TOT,5,0)
S5 SET (Y,I1)=^TMP($JOB,"FH","I",R1,K1,R2,X1)
+1 SET Y(0)=$GET(^FHING(X1,0))
SET UNT=$PIECE(Y(0),"^",16)
DO EN2^FHREC1
+2 WRITE ?46,$EXTRACT($PIECE(Y(0),"^",1),1,42),?90,Y
SET I2=$PIECE(Y(0),"^",17)
if 'I2
QUIT
SET I1=I1/I2
if 'I1
QUIT
+3 SET I1=+$JUSTIFY(I1,0,1)
WRITE ?113,I1," ",$PIECE(Y(0),"^",6)
QUIT
B0 SET LAB=$PIECE(FHPAR,"^",10)
SET R2=LAB=2*5+32
+1 FOR KK=0:0
SET KK=$ORDER(^TMP($JOB,"FH","I",KK))
if KK<1
QUIT
FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"FH","I",KK,K1))
if K1<1
QUIT
DO B1
+2 FOR X1=1:1:18
WRITE !
+3 QUIT
B1 FOR X1=0:0
SET X1=$ORDER(^TMP($JOB,"FH","I",KK,K1,X1))
if X1<1
QUIT
SET (Y,I1)=^(X1)
DO B2
+1 QUIT
B2 SET Y(0)=^FHING(X1,0)
SET UNT=$PIECE(Y(0),"^",16)
DO EN2^FHREC1
+1 SET I2=$PIECE(Y(0),"^",17)
if 'I2
QUIT
SET I1=I1/I2
+2 SET I1=$SELECT(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1)
+3 WRITE !,$EXTRACT($PIECE(Y(0),"^",1),1,R2),!!,I1," ",$PIECE(Y(0),"^",6),!!,$EXTRACT($PIECE(^FH(114,K1,0),"^",1),1,R2),!
QUIT
HDR SET PG=PG+1
WRITE @IOF,!,DTP,?48,"R E C I P E P R E P A R A T I O N",?125,"Page ",PG
+1 WRITE !,FHRETYP,?(131-$LENGTH(FHP6)),FHP6
+2 WRITE !
if $PIECE(FHPAR,"^",4)="Y"
DO PRE
WRITE ?(132-$LENGTH(TIM)\2),TIM
+3 WRITE !!,"Recipe",?40,"Port. Ingredient",?90,"Quantity",?113,"Storeroom Amount"
+4 WRITE !
FOR K=1:1:131
WRITE "-"
+5 QUIT
PRE SET K=$PIECE(X0,"^",12)
if K
SET K=$PIECE($GET(^FH(114.2,K,0)),"^",1)
+1 if K'=""
WRITE K
QUIT
