FHPRO6 ; HISC/REL - Storeroom Requisition ;4/25/93 15:59
;;5.5;DIETETICS;**3**;Jan 28, 2005
;RVD 5/23/05 - as part of AFP project.
S OLD="",R2="" I $P(FHPAR,"^",6)'="Y" S PG=0 D HDR
S1 S R2=$O(^TMP($J,"FH","S",R2)) I R2="" W ! Q
F X1=0:0 S X1=$O(^TMP($J,"FH","S",R2,X1)) Q:X1<1 D S2
G S1
S2 S Y(0)=$G(^FHING(X1,0)),UNT=$P(Y(0),"^",16),(FLG,TOT)=0
I $P(FHPAR,"^",6)="Y",OLD'=$E(R2,1,2) S OLD=$E(R2,1,2),PG=0 D HDR
S R1="" F K4=0:0 S R1=$O(^TMP($J,"FH","S",R2,X1,R1)) Q:R1="" F K1=0:0 S K1=$O(^TMP($J,"FH","S",R2,X1,R1,K1)) Q:K1<1 S TOT=TOT+^(K1)
S R1="" F K4=0:0 S R1=$O(^TMP($J,"FH","S",R2,X1,R1)) Q:R1="" F K1=0:0 S K1=$O(^TMP($J,"FH","S",R2,X1,R1,K1)) Q:K1<1 S Y=^(K1) D S4
Q
S4 D:$Y>(IOSL-7) HDR W ! G:FLG S5 W !,$P(Y(0),"^",1) S FLG=1 I $P(FHPAR,"^",6)'="Y",$E(R2,1,2)'=99 S Z=$P(Y(0),"^",12) S:Z Z=$P($G(^FH(113.1,Z,0)),"^",2) W:Z'="" " (",Z,")"
S I2=$P(Y(0),"^",17) G:'I2 S5 S I1=TOT/I2
S I1=$S(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1) W ?60,I1," ",$P(Y(0),"^",6)
S5 D EN2^FHREC1 W ?80,$P($G(^FH(114,K1,0)),"^",1),?112,$E(Y,1,19) Q
HDR S PG=PG+1 W @IOF,!,DTP,?45,"S T O R E R O O M R E Q U I S I T I O N",?125,"Page ",PG
W !,FHRETYP,?(131-$L(FHP6)),FHP6
W ! D:$P(FHPAR,"^",6)="Y" STO W ?(132-$L(TIM)\2),TIM
W !!,"Ingredient",?60,"Storeroom Amount",?80,"Recipe",?112,"Quantity"
W ! F K=1:1:131 W "-"
Q
STO S K=$P(Y(0),"^",12) S:K K=$P($G(^FH(113.1,K,0)),"^",1)
W:K'="" K Q
;
AFP ;print advance food prep storeroom requesition (grand total)
D Q1,AS0
Q
;
Q1 ; sets Storeroom scratch global for AFP
K R S K4="" F K=0:0 S K4=$O(^TMP($J,"AFP","T",K4)) Q:K4="" F L1=0:0 S L1=$O(^TMP($J,"AFP","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)
S:$D(^TMP($J,"AFP","I",S1,K1))#2=0 ^TMP($J,"AFP","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 P5
Q
P4 S X1=+Y,Q=$P(Y,"^",2)*MUL
S Y0=$G(^FHING(X1,0))
S FHSTR="MISCELLANEOUS"
I $P(Y0,"^",12) S FHSTR=$P($G(^FH(113.1,$P(Y0,"^",12),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,"AFP","I",S1,K1,S2,X1)) ^TMP($J,"AFP","I",S1,K1,S2,X1)=0 S ^(X1)=^(X1)+Q
P5 ;Q:FHP4'="Y"
S:'$D(^TMP($J,"AFP","S",FHSTR,S2,X1,S1,K1)) ^TMP($J,"AFP","S",FHSTR,S2,X1,S1,K1)=0 S ^(K1)=^(K1)+Q
Q
;prints
AS0 S (FH1,R2)="",PG=0
AST F S FH1=$O(^TMP($J,"AFP","S",FH1)) Q:FH1="" S FH2="" F S FH2=$O(^TMP($J,"AFP","S",FH1,FH2)) Q:FH2="" D:'$G(PG) AHDR D
.F FH3=0:0 S FH3=$O(^TMP($J,"AFP","S",FH1,FH2,FH3)) Q:FH3'>0 D AS2
Q
;
AS1 S R2=$O(^TMP($J,"AFP","S",R2)) I R2="" G AST
F X1=0:0 S X1=$O(^TMP($J,"AFP","S",FHS1,R2,X1)) Q:X1'>0 D AS2
G AS1
;
AS2 S Y(0)=$G(^FHING(FH3,0)),UNT=$P(Y(0),"^",16),(FLG,TOT)=0
;I $P(FHPAR,"^",6)="Y",OLD'=$E(R2,1,2) S OLD=$E(R2,1,2),PG=0 D AHDR
S R1="" F K4=0:0 S R1=$O(^TMP($J,"AFP","S",FH1,FH2,FH3,R1)) Q:R1="" F K1=0:0 S K1=$O(^TMP($J,"AFP","S",FH1,FH2,FH3,R1,K1)) Q:K1'>0 S TOT=TOT+^(K1)
S R1="" F K4=0:0 S R1=$O(^TMP($J,"AFP","S",FH1,FH2,FH3,R1)) Q:R1="" F K1=0:0 S K1=$O(^TMP($J,"AFP","S",FH1,FH2,FH3,R1,K1)) Q:K1'>0 S Y=^(K1) D AS4
Q
AS4 D:$Y>(IOSL-7) AHDR W ! G:FLG AS5 W !,$P(Y(0),"^",1) S FLG=1 ;I $P(FHPAR,"^",6)'="Y",$E(R2,1,2)'=99 S Z=$P(Y(0),"^",12) S:Z Z=$P($G(^FH(113.1,Z,0)),"^",2) W:Z'="" " (",Z,")"
;S Z=$P(Y(0),"^",12) S:Z Z=$P($G(^FH(113.1,Z,0)),"^",2) W:Z'="" " (",Z,")"
S I2=$P(Y(0),"^",17) G:'I2 AS5 S I1=TOT/I2
S I1=$S(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1)
S I1=+$J(I1,0,1)
S I1=$S($L(I1)=1:" "_I1,$L(I1)=2:" "_I1,$L(I1)=3:" "_I1,$L(I1)=4:" "_I1,$L(I1)=5:" "_I1,$L(I1)=6:" "_I1,1:I1)
W ?51,I1," ",$P(Y(0),"^",6)
AS5 D EN2^FHREC1
S FHYQU=$P(Y," ",1),FHYQUNA=$E(Y,$L(FHYQU)+1,$L(Y))
W ?76,$P($G(^FH(114,K1,0)),"^",1)
W ?105,$J(FHYQU,6,0),?111,FHYQUNA
;W ?80,$P($G(^FH(114,K1,0)),"^",1),?112,$E(Y,1,19) Q
Q
;
AHDR S PG=PG+1 W @IOF,!,DTP,?40,"A F P S T O R E R O O M R E Q U I S I T I O N",?125,"Page ",PG
W !,FHRETYP,?(131-$L(FHP6)),FHP6
W !,FH1
;W ! D:$P(FHPAR,"^",6)="Y" STO W ?(132-$L(TIM)\2),TIM
W ?(132-$L(TIMAFP)\2),TIMAFP
W !!,"Ingredient",?56,"Storeroom Amount",?76,"Recipe",?108,"Quantity"
W ! F K=1:1:131 W "-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRO6 4534 printed Dec 13, 2024@01:54:40 Page 2
FHPRO6 ; HISC/REL - Storeroom Requisition ;4/25/93 15:59
+1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
+2 ;RVD 5/23/05 - as part of AFP project.
+3 SET OLD=""
SET R2=""
IF $PIECE(FHPAR,"^",6)'="Y"
SET PG=0
DO HDR
S1 SET R2=$ORDER(^TMP($JOB,"FH","S",R2))
IF R2=""
WRITE !
QUIT
+1 FOR X1=0:0
SET X1=$ORDER(^TMP($JOB,"FH","S",R2,X1))
if X1<1
QUIT
DO S2
+2 GOTO S1
S2 SET Y(0)=$GET(^FHING(X1,0))
SET UNT=$PIECE(Y(0),"^",16)
SET (FLG,TOT)=0
+1 IF $PIECE(FHPAR,"^",6)="Y"
IF OLD'=$EXTRACT(R2,1,2)
SET OLD=$EXTRACT(R2,1,2)
SET PG=0
DO HDR
+2 SET R1=""
FOR K4=0:0
SET R1=$ORDER(^TMP($JOB,"FH","S",R2,X1,R1))
if R1=""
QUIT
FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"FH","S",R2,X1,R1,K1))
if K1<1
QUIT
SET TOT=TOT+^(K1)
+3 SET R1=""
FOR K4=0:0
SET R1=$ORDER(^TMP($JOB,"FH","S",R2,X1,R1))
if R1=""
QUIT
FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"FH","S",R2,X1,R1,K1))
if K1<1
QUIT
SET Y=^(K1)
DO S4
+4 QUIT
S4 if $Y>(IOSL-7)
DO HDR
WRITE !
if FLG
GOTO S5
WRITE !,$PIECE(Y(0),"^",1)
SET FLG=1
IF $PIECE(FHPAR,"^",6)'="Y"
IF $EXTRACT(R2,1,2)'=99
SET Z=$PIECE(Y(0),"^",12)
if Z
SET Z=$PIECE($GET(^FH(113.1,Z,0)),"^",2)
if Z'=""
WRITE " (",Z,")"
+1 SET I2=$PIECE(Y(0),"^",17)
if 'I2
GOTO S5
SET I1=TOT/I2
+2 SET I1=$SELECT(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1)
WRITE ?60,I1," ",$PIECE(Y(0),"^",6)
S5 DO EN2^FHREC1
WRITE ?80,$PIECE($GET(^FH(114,K1,0)),"^",1),?112,$EXTRACT(Y,1,19)
QUIT
HDR SET PG=PG+1
WRITE @IOF,!,DTP,?45,"S T O R E R O O M R E Q U I S I T I O N",?125,"Page ",PG
+1 WRITE !,FHRETYP,?(131-$LENGTH(FHP6)),FHP6
+2 WRITE !
if $PIECE(FHPAR,"^",6)="Y"
DO STO
WRITE ?(132-$LENGTH(TIM)\2),TIM
+3 WRITE !!,"Ingredient",?60,"Storeroom Amount",?80,"Recipe",?112,"Quantity"
+4 WRITE !
FOR K=1:1:131
WRITE "-"
+5 QUIT
STO SET K=$PIECE(Y(0),"^",12)
if K
SET K=$PIECE($GET(^FH(113.1,K,0)),"^",1)
+1 if K'=""
WRITE K
QUIT
+2 ;
AFP ;print advance food prep storeroom requesition (grand total)
+1 DO Q1
DO AS0
+2 QUIT
+3 ;
Q1 ; sets Storeroom scratch global for AFP
+1 KILL R
SET K4=""
FOR K=0:0
SET K4=$ORDER(^TMP($JOB,"AFP","T",K4))
if K4=""
QUIT
FOR L1=0:0
SET L1=$ORDER(^TMP($JOB,"AFP","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 $DATA(^TMP($JOB,"AFP","I",S1,K1))#2=0
SET ^TMP($JOB,"AFP","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 P5
+6 QUIT
P4 SET X1=+Y
SET Q=$PIECE(Y,"^",2)*MUL
+1 SET Y0=$GET(^FHING(X1,0))
+2 SET FHSTR="MISCELLANEOUS"
+3 IF $PIECE(Y0,"^",12)
SET FHSTR=$PIECE($GET(^FH(113.1,$PIECE(Y0,"^",12),0)),"^")
+4 SET S2=$PIECE(Y0,"^",12)
if S2
SET S2=$PIECE($GET(^FH(113.1,S2,0)),"^",3)
+5 ;G:FHP3'="Y" P5
SET S2=$SELECT(S2<1:99,S2<10:"0"_S2,1:S2)_$EXTRACT($PIECE(Y0,"^",1),1,28)
+6 if '$DATA(^TMP($JOB,"AFP","I",S1,K1,S2,X1))
SET ^TMP($JOB,"AFP","I",S1,K1,S2,X1)=0
SET ^(X1)=^(X1)+Q
P5 ;Q:FHP4'="Y"
+1 if '$DATA(^TMP($JOB,"AFP","S",FHSTR,S2,X1,S1,K1))
SET ^TMP($JOB,"AFP","S",FHSTR,S2,X1,S1,K1)=0
SET ^(K1)=^(K1)+Q
+2 QUIT
+3 ;prints
AS0 SET (FH1,R2)=""
SET PG=0
AST FOR
SET FH1=$ORDER(^TMP($JOB,"AFP","S",FH1))
if FH1=""
QUIT
SET FH2=""
FOR
SET FH2=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2))
if FH2=""
QUIT
if '$GET(PG)
DO AHDR
Begin DoDot:1
+1 FOR FH3=0:0
SET FH3=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2,FH3))
if FH3'>0
QUIT
DO AS2
End DoDot:1
+2 QUIT
+3 ;
AS1 SET R2=$ORDER(^TMP($JOB,"AFP","S",R2))
IF R2=""
GOTO AST
+1 FOR X1=0:0
SET X1=$ORDER(^TMP($JOB,"AFP","S",FHS1,R2,X1))
if X1'>0
QUIT
DO AS2
+2 GOTO AS1
+3 ;
AS2 SET Y(0)=$GET(^FHING(FH3,0))
SET UNT=$PIECE(Y(0),"^",16)
SET (FLG,TOT)=0
+1 ;I $P(FHPAR,"^",6)="Y",OLD'=$E(R2,1,2) S OLD=$E(R2,1,2),PG=0 D AHDR
+2 SET R1=""
FOR K4=0:0
SET R1=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2,FH3,R1))
if R1=""
QUIT
FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2,FH3,R1,K1))
if K1'>0
QUIT
SET TOT=TOT+^(K1)
+3 SET R1=""
FOR K4=0:0
SET R1=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2,FH3,R1))
if R1=""
QUIT
FOR K1=0:0
SET K1=$ORDER(^TMP($JOB,"AFP","S",FH1,FH2,FH3,R1,K1))
if K1'>0
QUIT
SET Y=^(K1)
DO AS4
+4 QUIT
AS4 ;I $P(FHPAR,"^",6)'="Y",$E(R2,1,2)'=99 S Z=$P(Y(0),"^",12) S:Z Z=$P($G(^FH(113.1,Z,0)),"^",2) W:Z'="" " (",Z,")"
if $Y>(IOSL-7)
DO AHDR
WRITE !
if FLG
GOTO AS5
WRITE !,$PIECE(Y(0),"^",1)
SET FLG=1
+1 ;S Z=$P(Y(0),"^",12) S:Z Z=$P($G(^FH(113.1,Z,0)),"^",2) W:Z'="" " (",Z,")"
+2 SET I2=$PIECE(Y(0),"^",17)
if 'I2
GOTO AS5
SET I1=TOT/I2
+3 SET I1=$SELECT(I1<1:1,I1#1<.1:I1\1,1:I1+.9\1)
+4 SET I1=+$JUSTIFY(I1,0,1)
+5 SET I1=$SELECT($LENGTH(I1)=1:" "_I1,$LENGTH(I1)=2:" "_I1,$LENGTH(I1)=3:" "_I1,$LENGTH(I1)=4:" "_I1,$LENGTH(I1)=5:" "_I1,$LENGTH(I1)=6:" "_I1,1:I1)
+6 WRITE ?51,I1," ",$PIECE(Y(0),"^",6)
AS5 DO EN2^FHREC1
+1 SET FHYQU=$PIECE(Y," ",1)
SET FHYQUNA=$EXTRACT(Y,$LENGTH(FHYQU)+1,$LENGTH(Y))
+2 WRITE ?76,$PIECE($GET(^FH(114,K1,0)),"^",1)
+3 WRITE ?105,$JUSTIFY(FHYQU,6,0),?111,FHYQUNA
+4 ;W ?80,$P($G(^FH(114,K1,0)),"^",1),?112,$E(Y,1,19) Q
+5 QUIT
+6 ;
AHDR SET PG=PG+1
WRITE @IOF,!,DTP,?40,"A F P S T O R E R O O M R E Q U I S I T I O N",?125,"Page ",PG
+1 WRITE !,FHRETYP,?(131-$LENGTH(FHP6)),FHP6
+2 WRITE !,FH1
+3 ;W ! D:$P(FHPAR,"^",6)="Y" STO W ?(132-$L(TIM)\2),TIM
+4 WRITE ?(132-$LENGTH(TIMAFP)\2),TIMAFP
+5 WRITE !!,"Ingredient",?56,"Storeroom Amount",?76,"Recipe",?108,"Quantity"
+6 WRITE !
FOR K=1:1:131
WRITE "-"
+7 QUIT
