- 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 Feb 18, 2025@23:20:59 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
