| 1 | FHPRC1 ; HISC/REL/NCA - Menu Cycle Utilities ;3/28/95 08:16
|
|---|
| 2 | ;;5.5;DIETETICS;;Jan 28, 2005
|
|---|
| 3 | EN1 ; Find current cycle & day
|
|---|
| 4 | S %DT="X",X="T" D ^%DT S X1=+Y K %DT
|
|---|
| 5 | E1 ; Find based upon X1 date
|
|---|
| 6 | 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
|
|---|
| 7 | Q:FHCY<1 S Y=^FH(116,FHCY,0),K1=$P(Y,"^",2) D ^%DTC K %T,%Y
|
|---|
| 8 | S FHDA=X+1#K1 S:'FHDA FHDA=K1 Q
|
|---|
| 9 | EN2 ; Check validity of Production Code string in Menu
|
|---|
| 10 | D TR^FH I $E(X,$L(X))=" " S X=$E(X,1,$L(X)-1)
|
|---|
| 11 | S (X9,XX)="" I $E(X,1,3)="ALL" D V3 G KIL
|
|---|
| 12 | 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
|
|---|
| 13 | KIL D SRT S X=XX K:X="" X K X1,X2,X3,X4,X5,X6,X8,X9,XX Q
|
|---|
| 14 | V1 I X1="" S X6=1 Q
|
|---|
| 15 | 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
|
|---|
| 16 | I X9[X2 W *7,!?5,X2," code used more than once" S X6=1
|
|---|
| 17 | 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
|
|---|
| 18 | Q:$P(X1,";",X5,99)="" W *7,!?5,"Extra specifications in ",X1 S X6=1 Q
|
|---|
| 19 | V2 S X3=$E(X2,1) I X3=""!("CT"'[X3) W *7,!?5,"Illegal Tray/Cafe specification in ",X1 S X6=1
|
|---|
| 20 | I X8=X3 W *7,!?5,X3," Tray/Cafe used more than once" S X6=1
|
|---|
| 21 | S X8=X3,X3=$E(X2,2,99)
|
|---|
| 22 | I +X3'=X3!(X3>999)!(X3<0)!(X3?.E1"."2N.N) W *7,!?5,"Illegal percentage in ",X1 S X6=1
|
|---|
| 23 | Q
|
|---|
| 24 | V3 I $E(X,4)="+" G ALL
|
|---|
| 25 | I $E(X,5)="" S XX="" W !?5,"No + after ALL" Q
|
|---|
| 26 | I $E(X,5)="+" G ALL
|
|---|
| 27 | W !?5,"Invalid ALL statement" S XX="" Q
|
|---|
| 28 | ALL S (FHPD,XX)=""
|
|---|
| 29 | 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
|
|---|
| 30 | K LP,FHPD
|
|---|
| 31 | Q
|
|---|
| 32 | SRT ; Sort and store Production Diet Code in print order
|
|---|
| 33 | 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
|
|---|
| 34 | .S Z1=$P($G(^FH(116.2,+Z,0)),"^",6),Z1=$S(Z1<1:99,Z1<10:"0"_Z1,1:Z1)
|
|---|
| 35 | .S:'$D(SR(Z1_"~"_PD)) SR(Z1_"~"_PD)=CODE Q
|
|---|
| 36 | 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
|
|---|
| 37 | S XX=$S(PD'="":PD,1:"") K CODE,LP,PD,SR,Z,Z1,ZZ
|
|---|
| 38 | Q
|
|---|
| 39 | EN3 ; Help Prompt for Production String
|
|---|
| 40 | W !!,"List Production Diet Codes separated by a single space"
|
|---|
| 41 | W !!,"Example: LS;C25;T30 RG ME;T20.1 CR;C50"
|
|---|
| 42 | W !," -- Production Diet Code"
|
|---|
| 43 | W !," - T = Tray or C = Cafeteria"
|
|---|
| 44 | W !," -- % of T or C census receiving recipe (max. 1 dec. place)"
|
|---|
| 45 | W !!,"Production Diets listed without a specification (e.g., RG)"
|
|---|
| 46 | W !,"are assumed to be 100% of census.",!
|
|---|
| 47 | W !,"ALL + will add all production diet codes.",! Q
|
|---|
