- 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
- 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
