FHPRO4A ; HISC/REL/RVD - Meal Distribution Report ;7/7/94 09:18
;;5.5;DIETETICS;**3**;Jan 28, 2005
;RVD 5/23/05 - as part of AFP project.
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
K P D HDR2 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 S P=$P(Y0,"^",3) 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 K Q S P=$P(P," ",1),UNT=$S(P["EA":"EACH",P["FL":"GAL",1:"LB"),TOT=0
S LL=41 F K=1:1:N S P0=P(K),N1=$G(^TMP($J,"FH","T",K4,L1,P0)),LL=LL+11 I N1 W ?LL,N1," por" S Q(K)=N1,TOT=TOT+N1
W ?S2,TOT," por",!
S LL=41 F K=1:1:N S LL=LL+11 I $G(Q(K)) S Y=P*Q(K) D UNT W ?LL,Y
S Y=P*TOT D UNT W ?S2,Y Q
UNT I UNT="EACH" S Y=$J(Y+.999\1,0,0)_" EA" Q
I UNT="LB" S P1=Y/16,U1="#" G:P1>.125 U1 S Y=P1*16+.5\1,U1="OZ" G U2
S P1=Y/128 F P0=1:1:5 S Z=$P("1,4,8,16,128",",",P0) Q:(P1*Z)>.875
S U1=$P("GL QT PT CP OZ"," ",P0),P1=Z*P1
U1 S Y="" S:P1#1>.875 P1=P1+1\1 S:P1'<1 Y=P1\1,P1=P1#1
I P1>.125 S:Y'="" Y=Y_"-" S Y=Y_$S(P1<.375:"1/4",P1<.625:"1/2",1:"3/4")
U2 S Y=Y_" "_U1 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=52+$L(PD),S1=S2+8 S:S1<73 S1=73 Q
HDR1 S PG=PG+1 W @IOF,!,DTP,?(S1-35\2),"M E A L D I S T R I B U T I O N R E P O R T",?(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",?52,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
HDR2 W !!!,"*** Note: Does NOT include add-ons and specials!",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRO4A 1974 printed Sep 23, 2025@19:30:37 Page 2
FHPRO4A ; HISC/REL/RVD - Meal Distribution Report ;7/7/94 09:18
+1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
+2 ;RVD 5/23/05 - as part of AFP project.
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 KILL P
DO HDR2
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
SET P=$PIECE(Y0,"^",3)
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,P
KILL Q
SET P=$PIECE(P," ",1)
SET UNT=$SELECT(P["EA":"EACH",P["FL":"GAL",1:"LB")
SET TOT=0
+4 SET LL=41
FOR K=1:1:N
SET P0=P(K)
SET N1=$GET(^TMP($JOB,"FH","T",K4,L1,P0))
SET LL=LL+11
IF N1
WRITE ?LL,N1," por"
SET Q(K)=N1
SET TOT=TOT+N1
+5 WRITE ?S2,TOT," por",!
+6 SET LL=41
FOR K=1:1:N
SET LL=LL+11
IF $GET(Q(K))
SET Y=P*Q(K)
DO UNT
WRITE ?LL,Y
+7 SET Y=P*TOT
DO UNT
WRITE ?S2,Y
QUIT
UNT IF UNT="EACH"
SET Y=$JUSTIFY(Y+.999\1,0,0)_" EA"
QUIT
+1 IF UNT="LB"
SET P1=Y/16
SET U1="#"
if P1>.125
GOTO U1
SET Y=P1*16+.5\1
SET U1="OZ"
GOTO U2
+2 SET P1=Y/128
FOR P0=1:1:5
SET Z=$PIECE("1,4,8,16,128",",",P0)
if (P1*Z)>.875
QUIT
+3 SET U1=$PIECE("GL QT PT CP OZ"," ",P0)
SET P1=Z*P1
U1 SET Y=""
if P1#1>.875
SET P1=P1+1\1
if P1'<1
SET Y=P1\1
SET P1=P1#1
+1 IF P1>.125
if Y'=""
SET Y=Y_"-"
SET Y=Y_$SELECT(P1<.375:"1/4",P1<.625:"1/2",1:"3/4")
U2 SET Y=Y_" "_U1
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=52+$LENGTH(PD)
SET S1=S2+8
if S1<73
SET S1=73
QUIT
HDR1 SET PG=PG+1
WRITE @IOF,!,DTP,?(S1-35\2),"M E A L D I S T R I B U T I O N R E P O R T",?(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",?52,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
HDR2 WRITE !!!,"*** Note: Does NOT include add-ons and specials!",!
QUIT
