- FHNU4 ; HISC/REL - Edit Menu ;11/16/93 09:52
- ;;5.5;DIETETICS;;Jan 28, 2005
- GET W ! K DIC S DIC="^FHUM(",DIC(0)="AEQLMZ",DIC("S")="I '$P(^(0),U,5)",DIC("DR")=".01",DLAYGO=112.6 D ^DIC K DLAYGO G KIL:U[X!$D(DTOUT),GET:Y<1 S MENU=+Y,MNAM=$P(Y,U,2)
- S NEW=$P(Y,U,3),DIE=DIC K DIC S DA=MENU,DR=$S(NEW:".6",1:".01"),DIDEL=112.6 D ^DIE K DIDEL G KIL:'$D(^FHUM(MENU)) I NEW S %DT="X",X="T" D ^%DT S $P(^FHUM(MENU,0),U,3,4)=Y_"^"_DUZ
- S TYP=$P(^FHUM(MENU,0),U,2)
- SEL S (DAY,MEAL)=0 K DIC I '$D(^FHUM(MENU,1,0)) S ^FHUM(MENU,1,0)="^112.61^^"
- S1 S DIC="^FHUM(MENU,1,",DIC(0)="AEQLM",DIC("DR")="",DA(1)=MENU,DIC("A")="Select DAY #: ",DLAYGO=112.6 D ^DIC K DLAYGO G KIL:U[X!$D(DTOUT),S1:Y<1 S (DAY,DA)=+Y
- K DR I '$D(^FHUM(MENU,1,DAY,1,0)) S ^FHUM(MENU,1,DAY,1,0)="^112.62^^"
- S2 S DIC="^FHUM(MENU,1,DAY,1,",DIC("A")="Select MEAL #: " D ^DIC G KIL:U[X!$D(DTOUT),S2:Y<1 S MEAL=+Y K DIC I $P(Y,U,3) S ^FHUM(MENU,1,DAY,1,MEAL,1,0)="^112.63P^^" K FHM G E5
- ED D LIS R !!,"Do you wish to EDIT this list? NO// ",YN:DTIME G:'$T!(YN["^") KIL S:YN="" YN="N" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G ED
- I YN?1"N".E W ! G SEL
- E0 G:'NM E5 R !!,"Do you wish to change any amounts? NO// ",YN:DTIME G:'$T!(YN["^") KIL S:YN="" YN="N" S X=YN D TR^FH S YN=X
- I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7,!," Answer YES or NO" G E0
- G E2:YN?1"N".E
- E1 R !,"Change item # : ",X:DTIME G KIL:'$T,E2:X="",ED:X["^" I X'?1N.N!(X<1)!(X>NM) W *7," ??" G E1
- S X=$P(XT,",",X) I TYP="C" S UNIT=$P(FHM(X),",",2),WT=$P(FHM(X),",",3)
- W *7," from ",(+FHM(X))," ",UNIT," to: " R Y:DTIME G KIL:'$T,E1:Y["^" I Y'?.N.1".".N!(Y'>0)!(Y>99999) W " ??" G E1
- W " ",UNIT S Y=+Y,$P(FHM(X),",",1)=Y
- S $P(^FHUM(MENU,1,DAY,1,MEAL,1,X,0),"^",2)=Y G E1
- E2 R !!,"Do you wish to delete any items? NO// ",YN:DTIME G:'$T!(YN["^") KIL S:YN="" YN="N" S X=YN D TR^FH S YN=X
- I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7,!," Answer YES or NO" G E2
- G E4:YN?1"N".E
- E3 R !,"Delete item # : ",X:DTIME G KIL:'$T,E4:X="",ED:X["^" I X'?1N.N!(X<1)!(X>NM) W *7," ??" G E3
- S X=$P(XT,",",X) K FHM(X),^FHUM(MENU,1,DAY,1,MEAL,1,X,0) W " ... deleted"
- S $P(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)=$P(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)-1 G E3
- E4 R !!,"Do you wish to add more food items? NO// ",YN:DTIME G:'$T!(YN["^") KIL S:YN="" YN="N" S X=YN D TR^FH S YN=X
- I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7,!," Answer YES or NO" G E4
- G E6:YN?1"N".E
- E5 D ^FHNU7 I FFN="" G E6
- I $D(^FHUM(MENU,1,DAY,1,MEAL,1,FFN,0)) S $P(^(0),"^",2)=AMT G E5
- S $P(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,3,4)=FFN_"^"_($P(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)+1)
- S ^FHUM(MENU,1,DAY,1,MEAL,1,FFN,0)=FFN_"^"_AMT G E5
- E6 I $O(^FHUM(MENU,1,DAY,1,MEAL,1,0))>0 G ED
- K ^FHUM(MENU,1,DAY,1,MEAL) W !!?5,"No Items Remain - Meal Deleted!"
- S $P(^FHUM(MENU,1,DAY,1,0),U,4)=$P(^FHUM(MENU,1,DAY,1,0),U,4)-1
- I $O(^FHUM(MENU,1,DAY,1,0))>0 W ! G SEL
- K ^FHUM(MENU,1,DAY) W !?5,"No Meals Remain - Day Deleted!"
- S $P(^FHUM(MENU,1,0),U,4)=$P(^FHUM(MENU,1,0),U,4)-1 W ! G SEL
- KIL G KILL^XUSCLEAN
- LIS W @IOF,!!,"Current Food List for Menu: ",MNAM," Day: ",DAY," Meal: ",MEAL,! S (NX,NM)=0,XT="",UNIT="gm." K FHM
- L1 S NX=$O(^FHUM(MENU,1,DAY,1,MEAL,1,NX)) I NX="" W:'NM !?5,"No items selected." Q
- S AMT=$P(^FHUM(MENU,1,DAY,1,MEAL,1,NX,0),"^",2),X=^FHNU(NX,0),NM=NM+1 I TYP="C" S UNIT=$P(X,"^",3),WT=$P(X,"^",4) D UNT
- S XT=XT_NX_",",FHM(NX)=AMT I TYP="C" S FHM(NX)=FHM(NX)_","_UNIT_","_WT
- W !,$J(NM,4,0)," ",$P(X,"^",1)," - ",AMT," ",UNIT G L1
- UNT I AMT'>1,UNIT'["." S L=$L(UNIT)-1,L=$S($E(UNIT,L)'="e":L,"hos"'[$E(UNIT,L-1):L,1:L-1),UNIT=$E(UNIT,1,L) I $E(UNIT,L-1,L)="ie" S UNIT=$E(UNIT,1,L-2)_"y"
- Q
- FHNU4 ; HISC/REL - Edit Menu ;11/16/93 09:52
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- GET WRITE !
- KILL DIC
- SET DIC="^FHUM("
- SET DIC(0)="AEQLMZ"
- SET DIC("S")="I '$P(^(0),U,5)"
- SET DIC("DR")=".01"
- SET DLAYGO=112.6
- DO ^DIC
- KILL DLAYGO
- IF U[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO GET
- SET MENU=+Y
- SET MNAM=$PIECE(Y,U,2)
- +1 SET NEW=$PIECE(Y,U,3)
- SET DIE=DIC
- KILL DIC
- SET DA=MENU
- SET DR=$SELECT(NEW:".6",1:".01")
- SET DIDEL=112.6
- DO ^DIE
- KILL DIDEL
- IF '$DATA(^FHUM(MENU))
- GOTO KIL
- IF NEW
- SET %DT="X"
- SET X="T"
- DO ^%DT
- SET $PIECE(^FHUM(MENU,0),U,3,4)=Y_"^"_DUZ
- +2 SET TYP=$PIECE(^FHUM(MENU,0),U,2)
- SEL SET (DAY,MEAL)=0
- KILL DIC
- IF '$DATA(^FHUM(MENU,1,0))
- SET ^FHUM(MENU,1,0)="^112.61^^"
- S1 SET DIC="^FHUM(MENU,1,"
- SET DIC(0)="AEQLM"
- SET DIC("DR")=""
- SET DA(1)=MENU
- SET DIC("A")="Select DAY #: "
- SET DLAYGO=112.6
- DO ^DIC
- KILL DLAYGO
- IF U[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO S1
- SET (DAY,DA)=+Y
- +1 KILL DR
- IF '$DATA(^FHUM(MENU,1,DAY,1,0))
- SET ^FHUM(MENU,1,DAY,1,0)="^112.62^^"
- S2 SET DIC="^FHUM(MENU,1,DAY,1,"
- SET DIC("A")="Select MEAL #: "
- DO ^DIC
- IF U[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO S2
- SET MEAL=+Y
- KILL DIC
- IF $PIECE(Y,U,3)
- SET ^FHUM(MENU,1,DAY,1,MEAL,1,0)="^112.63P^^"
- KILL FHM
- GOTO E5
- ED DO LIS
- READ !!,"Do you wish to EDIT this list? NO// ",YN:DTIME
- IF '$TEST!(YN["^")
- GOTO KIL
- IF YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO ED
- +1 IF YN?1"N".E
- WRITE !
- GOTO SEL
- E0 IF 'NM
- GOTO E5
- READ !!,"Do you wish to change any amounts? NO// ",YN:DTIME
- IF '$TEST!(YN["^")
- GOTO KIL
- IF YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- +1 IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7,!," Answer YES or NO"
- GOTO E0
- +2 IF YN?1"N".E
- GOTO E2
- E1 READ !,"Change item # : ",X:DTIME
- IF '$TEST
- GOTO KIL
- IF X=""
- GOTO E2
- IF X["^"
- GOTO ED
- IF X'?1N.N!(X<1)!(X>NM)
- WRITE *7," ??"
- GOTO E1
- +1 SET X=$PIECE(XT,",",X)
- IF TYP="C"
- SET UNIT=$PIECE(FHM(X),",",2)
- SET WT=$PIECE(FHM(X),",",3)
- +2 WRITE *7," from ",(+FHM(X))," ",UNIT," to: "
- READ Y:DTIME
- IF '$TEST
- GOTO KIL
- IF Y["^"
- GOTO E1
- IF Y'?.N.1".".N!(Y'>0)!(Y>99999)
- WRITE " ??"
- GOTO E1
- +3 WRITE " ",UNIT
- SET Y=+Y
- SET $PIECE(FHM(X),",",1)=Y
- +4 SET $PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,X,0),"^",2)=Y
- GOTO E1
- E2 READ !!,"Do you wish to delete any items? NO// ",YN:DTIME
- IF '$TEST!(YN["^")
- GOTO KIL
- IF YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- +1 IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7,!," Answer YES or NO"
- GOTO E2
- +2 IF YN?1"N".E
- GOTO E4
- E3 READ !,"Delete item # : ",X:DTIME
- IF '$TEST
- GOTO KIL
- IF X=""
- GOTO E4
- IF X["^"
- GOTO ED
- IF X'?1N.N!(X<1)!(X>NM)
- WRITE *7," ??"
- GOTO E3
- +1 SET X=$PIECE(XT,",",X)
- KILL FHM(X),^FHUM(MENU,1,DAY,1,MEAL,1,X,0)
- WRITE " ... deleted"
- +2 SET $PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)=$PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)-1
- GOTO E3
- E4 READ !!,"Do you wish to add more food items? NO// ",YN:DTIME
- IF '$TEST!(YN["^")
- GOTO KIL
- IF YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- +1 IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7,!," Answer YES or NO"
- GOTO E4
- +2 IF YN?1"N".E
- GOTO E6
- E5 DO ^FHNU7
- IF FFN=""
- GOTO E6
- +1 IF $DATA(^FHUM(MENU,1,DAY,1,MEAL,1,FFN,0))
- SET $PIECE(^(0),"^",2)=AMT
- GOTO E5
- +2 SET $PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,3,4)=FFN_"^"_($PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,0),U,4)+1)
- +3 SET ^FHUM(MENU,1,DAY,1,MEAL,1,FFN,0)=FFN_"^"_AMT
- GOTO E5
- E6 IF $ORDER(^FHUM(MENU,1,DAY,1,MEAL,1,0))>0
- GOTO ED
- +1 KILL ^FHUM(MENU,1,DAY,1,MEAL)
- WRITE !!?5,"No Items Remain - Meal Deleted!"
- +2 SET $PIECE(^FHUM(MENU,1,DAY,1,0),U,4)=$PIECE(^FHUM(MENU,1,DAY,1,0),U,4)-1
- +3 IF $ORDER(^FHUM(MENU,1,DAY,1,0))>0
- WRITE !
- GOTO SEL
- +4 KILL ^FHUM(MENU,1,DAY)
- WRITE !?5,"No Meals Remain - Day Deleted!"
- +5 SET $PIECE(^FHUM(MENU,1,0),U,4)=$PIECE(^FHUM(MENU,1,0),U,4)-1
- WRITE !
- GOTO SEL
- KIL GOTO KILL^XUSCLEAN
- LIS WRITE @IOF,!!,"Current Food List for Menu: ",MNAM," Day: ",DAY," Meal: ",MEAL,!
- SET (NX,NM)=0
- SET XT=""
- SET UNIT="gm."
- KILL FHM
- L1 SET NX=$ORDER(^FHUM(MENU,1,DAY,1,MEAL,1,NX))
- IF NX=""
- IF 'NM
- WRITE !?5,"No items selected."
- QUIT
- +1 SET AMT=$PIECE(^FHUM(MENU,1,DAY,1,MEAL,1,NX,0),"^",2)
- SET X=^FHNU(NX,0)
- SET NM=NM+1
- IF TYP="C"
- SET UNIT=$PIECE(X,"^",3)
- SET WT=$PIECE(X,"^",4)
- DO UNT
- +2 SET XT=XT_NX_","
- SET FHM(NX)=AMT
- IF TYP="C"
- SET FHM(NX)=FHM(NX)_","_UNIT_","_WT
- +3 WRITE !,$JUSTIFY(NM,4,0)," ",$PIECE(X,"^",1)," - ",AMT," ",UNIT
- GOTO L1
- UNT IF AMT'>1
- IF UNIT'["."
- SET L=$LENGTH(UNIT)-1
- SET L=$SELECT($EXTRACT(UNIT,L)'="e":L,"hos"'[$EXTRACT(UNIT,L-1):L,1:L-1)
- SET UNIT=$EXTRACT(UNIT,1,L)
- IF $EXTRACT(UNIT,L-1,L)="ie"
- SET UNIT=$EXTRACT(UNIT,1,L-2)_"y"
- +1 QUIT
