FHPRC1 ; HISC/REL/NCA - Menu Cycle Utilities ;3/28/95 08:16
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Find current cycle & day
S %DT="X",X="T" D ^%DT S X1=+Y K %DT
E1 ; Find based upon X1 date
S FHCY=-1 F K=0:0 S K=$O(^FH(116,"AB",K)) Q:K<1!(K>X1) S FHCY=$O(^(K,0)),X2=K
Q:FHCY<1 S Y=^FH(116,FHCY,0),K1=$P(Y,"^",2) D ^%DTC K %T,%Y
S FHDA=X+1#K1 S:'FHDA FHDA=K1 Q
EN2 ; Check validity of Production Code string in Menu
D TR^FH I $E(X,$L(X))=" " S X=$E(X,1,$L(X)-1)
S (X9,XX)="" I $E(X,1,3)="ALL" D V3 G KIL
F X4=1:1 Q:$P(X," ",X4,99)="" S X6=0,X1=$P(X," ",X4) D V1 I 'X6 S:XX'="" XX=XX_" " S XX=XX_X1
KIL D SRT S X=XX K:X="" X K X1,X2,X3,X4,X5,X6,X8,X9,XX Q
V1 I X1="" S X6=1 Q
S X2=$P(X1,";",1) S:X2="" X2=";" I '$D(^FH(116.2,"C",X2)) W *7,!?5,X2," not a valid Production Diet code" S X6=1
I X9[X2 W *7,!?5,X2," code used more than once" S X6=1
S X9=X9_" "_X2,X8="*",X5=2,X2=$P(X1,";",X5) I X2'="" D V2 S X5=3,X2=$P(X1,";",X5) I X2'="" D V2 S X5=4
Q:$P(X1,";",X5,99)="" W *7,!?5,"Extra specifications in ",X1 S X6=1 Q
V2 S X3=$E(X2,1) I X3=""!("CT"'[X3) W *7,!?5,"Illegal Tray/Cafe specification in ",X1 S X6=1
I X8=X3 W *7,!?5,X3," Tray/Cafe used more than once" S X6=1
S X8=X3,X3=$E(X2,2,99)
I +X3'=X3!(X3>999)!(X3<0)!(X3?.E1"."2N.N) W *7,!?5,"Illegal percentage in ",X1 S X6=1
Q
V3 I $E(X,4)="+" G ALL
I $E(X,5)="" S XX="" W !?5,"No + after ALL" Q
I $E(X,5)="+" G ALL
W !?5,"Invalid ALL statement" S XX="" Q
ALL S (FHPD,XX)=""
F S FHPD=$O(^FH(116.2,"C",FHPD)) Q:FHPD="" F LP=0:0 S LP=$O(^FH(116.2,"C",FHPD,LP)) Q:LP<1 I '$D(^FH(116.2,LP,"I")) S:XX'="" XX=XX_" " S XX=XX_FHPD
K LP,FHPD
Q
SRT ; Sort and store Production Diet Code in print order
K SR F LP=1:1 S CODE=$P(XX," ",LP) Q:CODE="" S PD=$P(CODE,";",1) I PD'="" S Z=0,Z=$O(^FH(116.2,"C",PD,Z)) I Z D
.S Z1=$P($G(^FH(116.2,+Z,0)),"^",6),Z1=$S(Z1<1:99,Z1<10:"0"_Z1,1:Z1)
.S:'$D(SR(Z1_"~"_PD)) SR(Z1_"~"_PD)=CODE Q
S (PD,ZZ)="" F S ZZ=$O(SR(ZZ)) Q:ZZ="" S Z=$G(SR(ZZ)) I Z'="" Q:$L(PD_" "_Z)>200 S:PD'="" PD=PD_" " S PD=PD_Z
S XX=$S(PD'="":PD,1:"") K CODE,LP,PD,SR,Z,Z1,ZZ
Q
EN3 ; Help Prompt for Production String
W !!,"List Production Diet Codes separated by a single space"
W !!,"Example: LS;C25;T30 RG ME;T20.1 CR;C50"
W !," -- Production Diet Code"
W !," - T = Tray or C = Cafeteria"
W !," -- % of T or C census receiving recipe (max. 1 dec. place)"
W !!,"Production Diets listed without a specification (e.g., RG)"
W !,"are assumed to be 100% of census.",!
W !,"ALL + will add all production diet codes.",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC1 2622 printed Sep 23, 2025@19:30:11 Page 2
FHPRC1 ; HISC/REL/NCA - Menu Cycle Utilities ;3/28/95 08:16
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Find current cycle & day
+1 SET %DT="X"
SET X="T"
DO ^%DT
SET X1=+Y
KILL %DT
E1 ; Find based upon X1 date
+1 SET FHCY=-1
FOR K=0:0
SET K=$ORDER(^FH(116,"AB",K))
if K<1!(K>X1)
QUIT
SET FHCY=$ORDER(^(K,0))
SET X2=K
+2 if FHCY<1
QUIT
SET Y=^FH(116,FHCY,0)
SET K1=$PIECE(Y,"^",2)
DO ^%DTC
KILL %T,%Y
+3 SET FHDA=X+1#K1
if 'FHDA
SET FHDA=K1
QUIT
EN2 ; Check validity of Production Code string in Menu
+1 DO TR^FH
IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+2 SET (X9,XX)=""
IF $EXTRACT(X,1,3)="ALL"
DO V3
GOTO KIL
+3 FOR X4=1:1
if $PIECE(X," ",X4,99)=""
QUIT
SET X6=0
SET X1=$PIECE(X," ",X4)
DO V1
IF 'X6
if XX'=""
SET XX=XX_" "
SET XX=XX_X1
KIL DO SRT
SET X=XX
if X=""
KILL X
KILL X1,X2,X3,X4,X5,X6,X8,X9,XX
QUIT
V1 IF X1=""
SET X6=1
QUIT
+1 SET X2=$PIECE(X1,";",1)
if X2=""
SET X2=";"
IF '$DATA(^FH(116.2,"C",X2))
WRITE *7,!?5,X2," not a valid Production Diet code"
SET X6=1
+2 IF X9[X2
WRITE *7,!?5,X2," code used more than once"
SET X6=1
+3 SET X9=X9_" "_X2
SET X8="*"
SET X5=2
SET X2=$PIECE(X1,";",X5)
IF X2'=""
DO V2
SET X5=3
SET X2=$PIECE(X1,";",X5)
IF X2'=""
DO V2
SET X5=4
+4 if $PIECE(X1,";",X5,99)=""
QUIT
WRITE *7,!?5,"Extra specifications in ",X1
SET X6=1
QUIT
V2 SET X3=$EXTRACT(X2,1)
IF X3=""!("CT"'[X3)
WRITE *7,!?5,"Illegal Tray/Cafe specification in ",X1
SET X6=1
+1 IF X8=X3
WRITE *7,!?5,X3," Tray/Cafe used more than once"
SET X6=1
+2 SET X8=X3
SET X3=$EXTRACT(X2,2,99)
+3 IF +X3'=X3!(X3>999)!(X3<0)!(X3?.E1"."2N.N)
WRITE *7,!?5,"Illegal percentage in ",X1
SET X6=1
+4 QUIT
V3 IF $EXTRACT(X,4)="+"
GOTO ALL
+1 IF $EXTRACT(X,5)=""
SET XX=""
WRITE !?5,"No + after ALL"
QUIT
+2 IF $EXTRACT(X,5)="+"
GOTO ALL
+3 WRITE !?5,"Invalid ALL statement"
SET XX=""
QUIT
ALL SET (FHPD,XX)=""
+1 FOR
SET FHPD=$ORDER(^FH(116.2,"C",FHPD))
if FHPD=""
QUIT
FOR LP=0:0
SET LP=$ORDER(^FH(116.2,"C",FHPD,LP))
if LP<1
QUIT
IF '$DATA(^FH(116.2,LP,"I"))
if XX'=""
SET XX=XX_" "
SET XX=XX_FHPD
+2 KILL LP,FHPD
+3 QUIT
SRT ; Sort and store Production Diet Code in print order
+1 KILL SR
FOR LP=1:1
SET CODE=$PIECE(XX," ",LP)
if CODE=""
QUIT
SET PD=$PIECE(CODE,";",1)
IF PD'=""
SET Z=0
SET Z=$ORDER(^FH(116.2,"C",PD,Z))
IF Z
Begin DoDot:1
+2 SET Z1=$PIECE($GET(^FH(116.2,+Z,0)),"^",6)
SET Z1=$SELECT(Z1<1:99,Z1<10:"0"_Z1,1:Z1)
+3 if '$DATA(SR(Z1_"~"_PD))
SET SR(Z1_"~"_PD)=CODE
QUIT
End DoDot:1
+4 SET (PD,ZZ)=""
FOR
SET ZZ=$ORDER(SR(ZZ))
if ZZ=""
QUIT
SET Z=$GET(SR(ZZ))
IF Z'=""
if $LENGTH(PD_" "_Z)>200
QUIT
if PD'=""
SET PD=PD_" "
SET PD=PD_Z
+5 SET XX=$SELECT(PD'="":PD,1:"")
KILL CODE,LP,PD,SR,Z,Z1,ZZ
+6 QUIT
EN3 ; Help Prompt for Production String
+1 WRITE !!,"List Production Diet Codes separated by a single space"
+2 WRITE !!,"Example: LS;C25;T30 RG ME;T20.1 CR;C50"
+3 WRITE !," -- Production Diet Code"
+4 WRITE !," - T = Tray or C = Cafeteria"
+5 WRITE !," -- % of T or C census receiving recipe (max. 1 dec. place)"
+6 WRITE !!,"Production Diets listed without a specification (e.g., RG)"
+7 WRITE !,"are assumed to be 100% of census.",!
+8 WRITE !,"ALL + will add all production diet codes.",!
QUIT
