FHPRO4 ; HISC/REL/RVD - Production/Meal Service Summary ;4/13/95 15:28
;;5.5;DIETETICS;**3**;Jan 28, 2005
;RVD 5/23/05 - as part of AFP project.
S FHPAR=^FH(119.71,FHP,0) D:FHP1="Y" Q1 D:FHP2="Y" Q2 G ^FHPRO5
Q1 D SES S P0=0,OLD="" I $P(FHPAR,"^",7)'="Y" S PG=0 D HDR1
S K4="" F LL=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 N1=^(L1),Y0=^FH(114,L1,0) D S1
D HDR3 D:$P(FHPAR,"^",5)="Y" ^FHPRO4A K P Q
S1 I $P(FHPAR,"^",7)="Y",OLD'=$E(K4,1,2) S OLD=$E(K4,1,2),PG=0 D HDR1
D:$Y>(IOSL-6) HDR1 W !!,$P(Y0,"^",1)
I $P(FHPAR,"^",7)'="Y" S Z=$P(Y0,"^",12) S:Z Z=$P(^FH(114.2,Z,0),"^",2) W:Z'="" " (",Z,")"
W ?40,$P(Y0,"^",3) S X=$P(Y0,"^",6) S:X X=$G(^FH(114.3,X,0)) W ?50,X,?62
F K=1:1:N S P0=P(K),X=$G(^TMP($J,"FH","T",K4,L1,P0)) W $J($S('X:"",1:X),6)," "
W ?S2,$J(^TMP($J,"FH","T",K4,L1),6) Q
HDR1 S PG=PG+1 W @IOF,!,DTP,?(S1-35\2),"P R O D U C T I O N S U M M A R Y",?(S1-6),"Page ",PG
W !,FHRETYP,?(S1-$L(FHP6)),FHP6
W ! D:$P(FHPAR,"^",7)="Y" PRE W ?(S1-$L(TIM)\2),TIM
W !!,"Recipe",?40,"Portion",?50,"Utensil",?62,PD," TOTAL"
S LN="",$P(LN,"-",S1+1)="" W !,LN Q
PRE S Z=$P(Y0,"^",12) S:Z Z=$P($G(^FH(114.2,Z,0)),"^",1)
W:Z'="" Z Q
SES K N,P,S S PD="",N=0
F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 S Y=$P(^FH(119.72,P0,0),"^",4) S:Y="" Y=$E($P(^(0),"^",1),1,6) S S(Y_"~"_P0)=""
S Y="" F S Y=$O(S(Y)) Q:Y="" S N=N+1,P(N)=$P(Y,"~",2),PD=PD_$J($P(Y,"~",1),6)_" "
K S S S2=62+$L(PD),S1=S2+6 Q
Q2 F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 D M1
Q
M1 D SET Q:NX="" S PG=0
M2 S PD=$E(NX,1,53) Q:PD="" S NX=$E(NX,55,999),S2=59+$L(PD),S1=S2+17 D HDR2
S K4="" F LL=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 N1=$G(^TMP($J,"FH","T",K4,L1,P0)) D:N1 M3
D HDR3 G M2
M3 S Y0=^FH(114,L1,0),Z=$J("",$L(PD)) D:$Y>(IOSL-6) HDR2
S K=$O(^FH(116.1,FHX1,"RE","B",L1,0))
F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",+K,"R",CAT)) Q:CAT<1 S FHPD=$P($G(^(CAT,0)),"^",2) D
.F KK=1:1 S FHX2=$P(FHPD," ",KK) Q:FHX2="" S X=$P(FHX2,";",1),X1=$F(PD,X) I X1>2 S Z=$E(Z,1,X1-3)_X_$E(Z,X1,999)
.Q
S X1=$P(Y0,"^",6) S:X1 X1=$G(^FH(114.3,X1,0))
W !!,$P(Y0,"^",1),?32,$P(Y0,"^",3),?44,X1,?56,Z,?S2,$J(N1,5) Q
HDR2 S PG=PG+1 W @IOF,!,DTP,?(S1-39\2),"M E A L S E R V I C E S U M M A R Y",?(S1-6),"Page ",PG
W !,FHRETYP,?(S1-$L(FHP6)),FHP6
S X=$P(^FH(119.72,P0,0),"^",1) W !?(S1-$L(X)\2),X,!!?(S1-$L(TIM)\2),TIM
W !!,"Recipe",?32,"Portion",?44,"Utensil",?56,PD,?S2,"Total"
S LN="",$P(LN,"-",S1+1)="" W !,LN Q
HDR3 W !!!,"*** Note: Does NOT include add-ons and specials!",! Q
SET K N F K=0:0 S K=$O(^TMP($J,"FH",P0,K)) Q:K<1 S X=$P($G(^FH(116.2,K,0)),"^",6) S:X<1 X=99 S N(X)=K
S NX="" F K=0:0 S K=$O(N(K)) Q:K<1 S C0=$P($G(^FH(116.2,+N(K),0)),"^",2) S:C0="" C0="**" S NX=NX_C0_" "
K N Q
T1 S K1=$O(^FH(116.2,"C",C0,0)) Q:K1<1 S X=$P(^FH(116.2,K1,0),"^",6)
S:X<1 X=99 S N(X)=C0 Q
;
DATE ;get all the meals for the date range and set-up AFP heading.
I MEAL="A" S FHMEALHE="for ALL MEALS" D ALL Q
S FHMEAL1=$P(MEAL,"-",1),FHMEAL2=$P(MEAL,"-",2)
S FHMEALR1=$S(FHMEAL1="B":1,FHMEAL1="N":2,FHMEAL1="E":3,1:0)
S FHMEALR2=$S(FHMEAL2="B":1,FHMEAL2="N":2,FHMEAL2="E":3,1:0)
S FHMEAL1N=$S(FHMEAL1="B":"BREAKFAST",FHMEAL1="N":"NOON",FHMEAL1="E":"EVENING",1:"")
S FHMEAL2N=$S(FHMEAL2="B":"BREAKFAST",FHMEAL2="N":"NOON",FHMEAL2="E":"EVENING",1:"")
I '$G(FHMEALR2) S FHMEALHE=FHMEAL1N_" only"
E S FHMEALHE=FHMEAL1N_" to "_FHMEAL2N
I (FHMEALR1>FHMEALR2),(FHMEALR2'=0) S FHMEALHE=FHMEAL2N_" to "_FHMEAL1N
I FHMEAL2N="" D ONE Q
F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
.S FHDAMEAL=FHDODAY(FHI)
.I (FHI=1),(FHNUMDAY=1) D Q
..I (FHMEAL1="B"),(FHMEAL2="N") S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
..I (FHMEAL1="B"),(FHMEAL2="E") S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
..I (FHMEAL1="N"),(FHMEAL2="E") S FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
..I (FHMEAL1="N"),(FHMEAL2="B") S FHMEALAR("N",FHDAMEAL)="",FHMEALAR("B",FHDAMEAL)=""
..I FHMEAL2="" S FHMEALAR(FHMEAL1,FHDAMEAL)=""
..I (FHMEAL1="E"),(FHMEAL2="B") S FHMEALAR("E",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("B",FHDAMEAL)=""
..I (FHMEAL1="E"),(FHMEAL2="N") S FHMEALAR("E",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
.I FHI=FHNUMDAY D Q
..I FHMEAL2="B" S FHMEALAR("B",FHDAMEAL)=""
..I FHMEAL2="N" S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
..I FHMEAL2="E" S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
.I FHI=1 D Q
..S:FHMEALR1=1 FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
..S:FHMEALR1=2 FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
..S:FHMEALR1=3 FHMEALAR("E",FHDAMEAL)=""
.S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
Q
ALL F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
.S FHDAMEAL=FHDODAY(FHI)
.S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
Q
ONE F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
.S FHDAMEAL=FHDODAY(FHI)
.S FHMEALAR(FHMEAL1,FHDAMEAL)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRO4 5151 printed Sep 23, 2025@19:30:36 Page 2
FHPRO4 ; HISC/REL/RVD - Production/Meal Service Summary ;4/13/95 15:28
+1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
+2 ;RVD 5/23/05 - as part of AFP project.
+3 SET FHPAR=^FH(119.71,FHP,0)
if FHP1="Y"
DO Q1
if FHP2="Y"
DO Q2
GOTO ^FHPRO5
Q1 DO SES
SET P0=0
SET OLD=""
IF $PIECE(FHPAR,"^",7)'="Y"
SET PG=0
DO HDR1
+1 SET K4=""
FOR LL=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
SET N1=^(L1)
SET Y0=^FH(114,L1,0)
DO S1
+2 DO HDR3
if $PIECE(FHPAR,"^",5)="Y"
DO ^FHPRO4A
KILL P
QUIT
S1 IF $PIECE(FHPAR,"^",7)="Y"
IF OLD'=$EXTRACT(K4,1,2)
SET OLD=$EXTRACT(K4,1,2)
SET PG=0
DO HDR1
+1 if $Y>(IOSL-6)
DO HDR1
WRITE !!,$PIECE(Y0,"^",1)
+2 IF $PIECE(FHPAR,"^",7)'="Y"
SET Z=$PIECE(Y0,"^",12)
if Z
SET Z=$PIECE(^FH(114.2,Z,0),"^",2)
if Z'=""
WRITE " (",Z,")"
+3 WRITE ?40,$PIECE(Y0,"^",3)
SET X=$PIECE(Y0,"^",6)
if X
SET X=$GET(^FH(114.3,X,0))
WRITE ?50,X,?62
+4 FOR K=1:1:N
SET P0=P(K)
SET X=$GET(^TMP($JOB,"FH","T",K4,L1,P0))
WRITE $JUSTIFY($SELECT('X:"",1:X),6)," "
+5 WRITE ?S2,$JUSTIFY(^TMP($JOB,"FH","T",K4,L1),6)
QUIT
HDR1 SET PG=PG+1
WRITE @IOF,!,DTP,?(S1-35\2),"P R O D U C T I O N S U M M A R Y",?(S1-6),"Page ",PG
+1 WRITE !,FHRETYP,?(S1-$LENGTH(FHP6)),FHP6
+2 WRITE !
if $PIECE(FHPAR,"^",7)="Y"
DO PRE
WRITE ?(S1-$LENGTH(TIM)\2),TIM
+3 WRITE !!,"Recipe",?40,"Portion",?50,"Utensil",?62,PD," TOTAL"
+4 SET LN=""
SET $PIECE(LN,"-",S1+1)=""
WRITE !,LN
QUIT
PRE SET Z=$PIECE(Y0,"^",12)
if Z
SET Z=$PIECE($GET(^FH(114.2,Z,0)),"^",1)
+1 if Z'=""
WRITE Z
QUIT
SES KILL N,P,S
SET PD=""
SET N=0
+1 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,"FH",P0))
if P0<1
QUIT
SET Y=$PIECE(^FH(119.72,P0,0),"^",4)
if Y=""
SET Y=$EXTRACT($PIECE(^(0),"^",1),1,6)
SET S(Y_"~"_P0)=""
+2 SET Y=""
FOR
SET Y=$ORDER(S(Y))
if Y=""
QUIT
SET N=N+1
SET P(N)=$PIECE(Y,"~",2)
SET PD=PD_$JUSTIFY($PIECE(Y,"~",1),6)_" "
+3 KILL S
SET S2=62+$LENGTH(PD)
SET S1=S2+6
QUIT
Q2 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,"FH",P0))
if P0<1
QUIT
DO M1
+1 QUIT
M1 DO SET
if NX=""
QUIT
SET PG=0
M2 SET PD=$EXTRACT(NX,1,53)
if PD=""
QUIT
SET NX=$EXTRACT(NX,55,999)
SET S2=59+$LENGTH(PD)
SET S1=S2+17
DO HDR2
+1 SET K4=""
FOR LL=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
SET N1=$GET(^TMP($JOB,"FH","T",K4,L1,P0))
if N1
DO M3
+2 DO HDR3
GOTO M2
M3 SET Y0=^FH(114,L1,0)
SET Z=$JUSTIFY("",$LENGTH(PD))
if $Y>(IOSL-6)
DO HDR2
+1 SET K=$ORDER(^FH(116.1,FHX1,"RE","B",L1,0))
+2 FOR CAT=0:0
SET CAT=$ORDER(^FH(116.1,FHX1,"RE",+K,"R",CAT))
if CAT<1
QUIT
SET FHPD=$PIECE($GET(^(CAT,0)),"^",2)
Begin DoDot:1
+3 FOR KK=1:1
SET FHX2=$PIECE(FHPD," ",KK)
if FHX2=""
QUIT
SET X=$PIECE(FHX2,";",1)
SET X1=$FIND(PD,X)
IF X1>2
SET Z=$EXTRACT(Z,1,X1-3)_X_$EXTRACT(Z,X1,999)
+4 QUIT
End DoDot:1
+5 SET X1=$PIECE(Y0,"^",6)
if X1
SET X1=$GET(^FH(114.3,X1,0))
+6 WRITE !!,$PIECE(Y0,"^",1),?32,$PIECE(Y0,"^",3),?44,X1,?56,Z,?S2,$JUSTIFY(N1,5)
QUIT
HDR2 SET PG=PG+1
WRITE @IOF,!,DTP,?(S1-39\2),"M E A L S E R V I C E S U M M A R Y",?(S1-6),"Page ",PG
+1 WRITE !,FHRETYP,?(S1-$LENGTH(FHP6)),FHP6
+2 SET X=$PIECE(^FH(119.72,P0,0),"^",1)
WRITE !?(S1-$LENGTH(X)\2),X,!!?(S1-$LENGTH(TIM)\2),TIM
+3 WRITE !!,"Recipe",?32,"Portion",?44,"Utensil",?56,PD,?S2,"Total"
+4 SET LN=""
SET $PIECE(LN,"-",S1+1)=""
WRITE !,LN
QUIT
HDR3 WRITE !!!,"*** Note: Does NOT include add-ons and specials!",!
QUIT
SET KILL N
FOR K=0:0
SET K=$ORDER(^TMP($JOB,"FH",P0,K))
if K<1
QUIT
SET X=$PIECE($GET(^FH(116.2,K,0)),"^",6)
if X<1
SET X=99
SET N(X)=K
+1 SET NX=""
FOR K=0:0
SET K=$ORDER(N(K))
if K<1
QUIT
SET C0=$PIECE($GET(^FH(116.2,+N(K),0)),"^",2)
if C0=""
SET C0="**"
SET NX=NX_C0_" "
+2 KILL N
QUIT
T1 SET K1=$ORDER(^FH(116.2,"C",C0,0))
if K1<1
QUIT
SET X=$PIECE(^FH(116.2,K1,0),"^",6)
+1 if X<1
SET X=99
SET N(X)=C0
QUIT
+2 ;
DATE ;get all the meals for the date range and set-up AFP heading.
+1 IF MEAL="A"
SET FHMEALHE="for ALL MEALS"
DO ALL
QUIT
+2 SET FHMEAL1=$PIECE(MEAL,"-",1)
SET FHMEAL2=$PIECE(MEAL,"-",2)
+3 SET FHMEALR1=$SELECT(FHMEAL1="B":1,FHMEAL1="N":2,FHMEAL1="E":3,1:0)
+4 SET FHMEALR2=$SELECT(FHMEAL2="B":1,FHMEAL2="N":2,FHMEAL2="E":3,1:0)
+5 SET FHMEAL1N=$SELECT(FHMEAL1="B":"BREAKFAST",FHMEAL1="N":"NOON",FHMEAL1="E":"EVENING",1:"")
+6 SET FHMEAL2N=$SELECT(FHMEAL2="B":"BREAKFAST",FHMEAL2="N":"NOON",FHMEAL2="E":"EVENING",1:"")
+7 IF '$GET(FHMEALR2)
SET FHMEALHE=FHMEAL1N_" only"
+8 IF '$TEST
SET FHMEALHE=FHMEAL1N_" to "_FHMEAL2N
+9 IF (FHMEALR1>FHMEALR2)
IF (FHMEALR2'=0)
SET FHMEALHE=FHMEAL2N_" to "_FHMEAL1N
+10 IF FHMEAL2N=""
DO ONE
QUIT
+11 FOR FHI=0:0
SET FHI=$ORDER(FHDODAY(FHI))
if FHI'>0
QUIT
Begin DoDot:1
+12 SET FHDAMEAL=FHDODAY(FHI)
+13 IF (FHI=1)
IF (FHNUMDAY=1)
Begin DoDot:2
+14 IF (FHMEAL1="B")
IF (FHMEAL2="N")
SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
+15 IF (FHMEAL1="B")
IF (FHMEAL2="E")
SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
+16 IF (FHMEAL1="N")
IF (FHMEAL2="E")
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
+17 IF (FHMEAL1="N")
IF (FHMEAL2="B")
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("B",FHDAMEAL)=""
+18 IF FHMEAL2=""
SET FHMEALAR(FHMEAL1,FHDAMEAL)=""
+19 IF (FHMEAL1="E")
IF (FHMEAL2="B")
SET FHMEALAR("E",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("B",FHDAMEAL)=""
+20 IF (FHMEAL1="E")
IF (FHMEAL2="N")
SET FHMEALAR("E",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
End DoDot:2
QUIT
+21 IF FHI=FHNUMDAY
Begin DoDot:2
+22 IF FHMEAL2="B"
SET FHMEALAR("B",FHDAMEAL)=""
+23 IF FHMEAL2="N"
SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
+24 IF FHMEAL2="E"
SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
End DoDot:2
QUIT
+25 IF FHI=1
Begin DoDot:2
+26 if FHMEALR1=1
SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
+27 if FHMEALR1=2
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
+28 if FHMEALR1=3
SET FHMEALAR("E",FHDAMEAL)=""
End DoDot:2
QUIT
+29 SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
End DoDot:1
+30 QUIT
ALL FOR FHI=0:0
SET FHI=$ORDER(FHDODAY(FHI))
if FHI'>0
QUIT
Begin DoDot:1
+1 SET FHDAMEAL=FHDODAY(FHI)
+2 SET FHMEALAR("B",FHDAMEAL)=""
SET FHMEALAR("N",FHDAMEAL)=""
SET FHMEALAR("E",FHDAMEAL)=""
End DoDot:1
+3 QUIT
ONE FOR FHI=0:0
SET FHI=$ORDER(FHDODAY(FHI))
if FHI'>0
QUIT
Begin DoDot:1
+1 SET FHDAMEAL=FHDODAY(FHI)
+2 SET FHMEALAR(FHMEAL1,FHDAMEAL)=""
End DoDot:1
+3 QUIT
