source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHPRO4.m@ 949

Last change on this file since 949 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1FHPRO4 ; HISC/REL/RVD - Production/Meal Service Summary ;4/13/95 15:28
2 ;;5.5;DIETETICS;**3**;Jan 28, 2005
3 ;RVD 5/23/05 - as part of AFP project.
4 S FHPAR=^FH(119.71,FHP,0) D:FHP1="Y" Q1 D:FHP2="Y" Q2 G ^FHPRO5
5Q1 D SES S P0=0,OLD="" I $P(FHPAR,"^",7)'="Y" S PG=0 D HDR1
6 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
7 D HDR3 D:$P(FHPAR,"^",5)="Y" ^FHPRO4A K P Q
8S1 I $P(FHPAR,"^",7)="Y",OLD'=$E(K4,1,2) S OLD=$E(K4,1,2),PG=0 D HDR1
9 D:$Y>(IOSL-6) HDR1 W !!,$P(Y0,"^",1)
10 I $P(FHPAR,"^",7)'="Y" S Z=$P(Y0,"^",12) S:Z Z=$P(^FH(114.2,Z,0),"^",2) W:Z'="" " (",Z,")"
11 W ?40,$P(Y0,"^",3) S X=$P(Y0,"^",6) S:X X=$G(^FH(114.3,X,0)) W ?50,X,?62
12 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)," "
13 W ?S2,$J(^TMP($J,"FH","T",K4,L1),6) Q
14HDR1 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
15 W !,FHRETYP,?(S1-$L(FHP6)),FHP6
16 W ! D:$P(FHPAR,"^",7)="Y" PRE W ?(S1-$L(TIM)\2),TIM
17 W !!,"Recipe",?40,"Portion",?50,"Utensil",?62,PD," TOTAL"
18 S LN="",$P(LN,"-",S1+1)="" W !,LN Q
19PRE S Z=$P(Y0,"^",12) S:Z Z=$P($G(^FH(114.2,Z,0)),"^",1)
20 W:Z'="" Z Q
21SES K N,P,S S PD="",N=0
22 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)=""
23 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)_" "
24 K S S S2=62+$L(PD),S1=S2+6 Q
25Q2 F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 D M1
26 Q
27M1 D SET Q:NX="" S PG=0
28M2 S PD=$E(NX,1,53) Q:PD="" S NX=$E(NX,55,999),S2=59+$L(PD),S1=S2+17 D HDR2
29 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
30 D HDR3 G M2
31M3 S Y0=^FH(114,L1,0),Z=$J("",$L(PD)) D:$Y>(IOSL-6) HDR2
32 S K=$O(^FH(116.1,FHX1,"RE","B",L1,0))
33 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
34 .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)
35 .Q
36 S X1=$P(Y0,"^",6) S:X1 X1=$G(^FH(114.3,X1,0))
37 W !!,$P(Y0,"^",1),?32,$P(Y0,"^",3),?44,X1,?56,Z,?S2,$J(N1,5) Q
38HDR2 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
39 W !,FHRETYP,?(S1-$L(FHP6)),FHP6
40 S X=$P(^FH(119.72,P0,0),"^",1) W !?(S1-$L(X)\2),X,!!?(S1-$L(TIM)\2),TIM
41 W !!,"Recipe",?32,"Portion",?44,"Utensil",?56,PD,?S2,"Total"
42 S LN="",$P(LN,"-",S1+1)="" W !,LN Q
43HDR3 W !!!,"*** Note: Does NOT include add-ons and specials!",! Q
44SET 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
45 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_" "
46 K N Q
47T1 S K1=$O(^FH(116.2,"C",C0,0)) Q:K1<1 S X=$P(^FH(116.2,K1,0),"^",6)
48 S:X<1 X=99 S N(X)=C0 Q
49 ;
50DATE ;get all the meals for the date range and set-up AFP heading.
51 I MEAL="A" S FHMEALHE="for ALL MEALS" D ALL Q
52 S FHMEAL1=$P(MEAL,"-",1),FHMEAL2=$P(MEAL,"-",2)
53 S FHMEALR1=$S(FHMEAL1="B":1,FHMEAL1="N":2,FHMEAL1="E":3,1:0)
54 S FHMEALR2=$S(FHMEAL2="B":1,FHMEAL2="N":2,FHMEAL2="E":3,1:0)
55 S FHMEAL1N=$S(FHMEAL1="B":"BREAKFAST",FHMEAL1="N":"NOON",FHMEAL1="E":"EVENING",1:"")
56 S FHMEAL2N=$S(FHMEAL2="B":"BREAKFAST",FHMEAL2="N":"NOON",FHMEAL2="E":"EVENING",1:"")
57 I '$G(FHMEALR2) S FHMEALHE=FHMEAL1N_" only"
58 E S FHMEALHE=FHMEAL1N_" to "_FHMEAL2N
59 I (FHMEALR1>FHMEALR2),(FHMEALR2'=0) S FHMEALHE=FHMEAL2N_" to "_FHMEAL1N
60 I FHMEAL2N="" D ONE Q
61 F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
62 .S FHDAMEAL=FHDODAY(FHI)
63 .I (FHI=1),(FHNUMDAY=1) D Q
64 ..I (FHMEAL1="B"),(FHMEAL2="N") S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
65 ..I (FHMEAL1="B"),(FHMEAL2="E") S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
66 ..I (FHMEAL1="N"),(FHMEAL2="E") S FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
67 ..I (FHMEAL1="N"),(FHMEAL2="B") S FHMEALAR("N",FHDAMEAL)="",FHMEALAR("B",FHDAMEAL)=""
68 ..I FHMEAL2="" S FHMEALAR(FHMEAL1,FHDAMEAL)=""
69 ..I (FHMEAL1="E"),(FHMEAL2="B") S FHMEALAR("E",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("B",FHDAMEAL)=""
70 ..I (FHMEAL1="E"),(FHMEAL2="N") S FHMEALAR("E",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
71 .I FHI=FHNUMDAY D Q
72 ..I FHMEAL2="B" S FHMEALAR("B",FHDAMEAL)=""
73 ..I FHMEAL2="N" S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)=""
74 ..I FHMEAL2="E" S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
75 .I FHI=1 D Q
76 ..S:FHMEALR1=1 FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
77 ..S:FHMEALR1=2 FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
78 ..S:FHMEALR1=3 FHMEALAR("E",FHDAMEAL)=""
79 .S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
80 Q
81ALL F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
82 .S FHDAMEAL=FHDODAY(FHI)
83 .S FHMEALAR("B",FHDAMEAL)="",FHMEALAR("N",FHDAMEAL)="",FHMEALAR("E",FHDAMEAL)=""
84 Q
85ONE F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 D
86 .S FHDAMEAL=FHDODAY(FHI)
87 .S FHMEALAR(FHMEAL1,FHDAMEAL)=""
88 Q
Note: See TracBrowser for help on using the repository browser.