- FHNU7 ; HISC/REL - Food Item Search ;5/17/93 08:50
- ;;5.5;DIETETICS;;Jan 28, 2005
- S NOD="AQ",(FFN,NAM,AMT)=""
- R !!?2,"Select Food Item: ",Y:DTIME G:'$T!("^"[Y)!(Y?1",".E)!(Y'?.ANP)!($L(Y)>30) END S X=Y D TR^FH S Y=X
- I Y["?" W !,"Enter first few characters of food name, e.g., MILK" G FHNU7
- F0 S NM=0,XT="",L=$P(Y,",",1),F=$P(Y,",",2) S:$E(F,1)=" " F=$E(F,2,99)
- S NX=L,J=$L(L),K=$L(F) I $D(^FHNU(NOD,NX)) S FFN=0 G S1
- S0 S NX=$O(^FHNU(NOD,NX)) G:NX=""!($P(NX,L,1)'="") SD I K G:$E($P(NX,", ",2),1,K)'=F S0
- S FFN=0
- S1 S FFN=$O(^FHNU(NOD,NX,FFN)) G:FFN="" S0 S NM=NM+1,XT=XT_FFN_"," G S1:NM<18,TOO
- SD I 'NM G:NOD="AQ" NX W !!?2,"Food item not found " G FHNU7
- TOO W ! F LL=1:1:NM S X=^FHNU($P(XT,",",LL),0) W !,$J(LL,3,0),?6,$P(X,"^",1)
- S YN=NOD="AQ"!(NM=18) W !!?2,"Select Food Item #, '",$S(YN:"^",1:"RETURN"),"' to Quit" W:YN ",",!?2,"or 'RETURN' to continue list"
- R " => ",YN:DTIME I '$T!(YN["^") S FFN="" G END
- I YN="",NM>17 S NM=0,XT="" G S1
- G:YN["^" FHNU7 I YN="" G NX:NOD="AQ",FHNU7
- I YN'?1N.N!(YN<1)!(YN>NM) W *7," ??" G TOO
- S FFN=$P(XT,",",YN) G OK
- OK S X=^FHNU(FFN,0),NAM=$P(X,"^",1),UNT=$P(X,"^",3),WT=$P(X,"^",4)
- I $D(FHM(FFN)) G ED
- S UNIT=$S(TYP="C":UNT,1:"gms.")
- D2 W !!?2,NAM,!?5,"Amount (",UNIT W:TYP="C" " at ",WT," gms" W ") => " R Y:DTIME I '$T!(Y["^") S FFN="" G END
- I Y=0 G FHNU7
- I Y'?.N.1".".N!(Y'>0)!(Y>99999) W *7,!," Enter amount of item. Enter 0 to delete;",!," otherwise enter a number greater than 0 but less than 99999." G D2
- I TYP="C" W " ... ",Y*WT," grams"
- I TYP="C",Y'>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"
- S FHM(FFN)=Y,AMT=Y S:TYP="C" FHM(FFN)=FHM(FFN)_","_UNIT_","_WT
- END K NOD,F,J,K,L,LL,NM,NX,XT,X,Y,YN Q
- NX S NOD="B",(FFN,NAM,AMT)="" G F0
- ED W !!?2,"You have already selected ",NAM
- I TYP="C" S UNIT=$P(FHM(FFN),",",2),WT=$P(FHM(FFN),",",3)
- E S UNIT="gms."
- E1 W !!?2,"Change amount from ",(+FHM(FFN))," ",UNIT," to: " R Y:DTIME I '$T!(Y["^") S FFN="" G END
- I Y'?.N.1".".N!(Y'>0)!(Y>99999) W *7,!," Enter an amount greater than 0 but less than 99999" G E1
- W " ",UNIT S (Y,AMT)=+Y,$P(FHM(FFN),",",1)=AMT G END
- FHNU7 ; HISC/REL - Food Item Search ;5/17/93 08:50
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET NOD="AQ"
- SET (FFN,NAM,AMT)=""
- +3 READ !!?2,"Select Food Item: ",Y:DTIME
- IF '$TEST!("^"[Y)!(Y?1",".E)!(Y'?.ANP)!($LENGTH(Y)>30)
- GOTO END
- SET X=Y
- DO TR^FH
- SET Y=X
- +4 IF Y["?"
- WRITE !,"Enter first few characters of food name, e.g., MILK"
- GOTO FHNU7
- F0 SET NM=0
- SET XT=""
- SET L=$PIECE(Y,",",1)
- SET F=$PIECE(Y,",",2)
- IF $EXTRACT(F,1)=" "
- SET F=$EXTRACT(F,2,99)
- +1 SET NX=L
- SET J=$LENGTH(L)
- SET K=$LENGTH(F)
- IF $DATA(^FHNU(NOD,NX))
- SET FFN=0
- GOTO S1
- S0 SET NX=$ORDER(^FHNU(NOD,NX))
- IF NX=""!($PIECE(NX,L,1)'="")
- GOTO SD
- IF K
- IF $EXTRACT($PIECE(NX,", ",2),1,K)'=F
- GOTO S0
- +1 SET FFN=0
- S1 SET FFN=$ORDER(^FHNU(NOD,NX,FFN))
- IF FFN=""
- GOTO S0
- SET NM=NM+1
- SET XT=XT_FFN_","
- IF NM<18
- GOTO S1
- GOTO TOO
- SD IF 'NM
- IF NOD="AQ"
- GOTO NX
- WRITE !!?2,"Food item not found "
- GOTO FHNU7
- TOO WRITE !
- FOR LL=1:1:NM
- SET X=^FHNU($PIECE(XT,",",LL),0)
- WRITE !,$JUSTIFY(LL,3,0),?6,$PIECE(X,"^",1)
- +1 SET YN=NOD="AQ"!(NM=18)
- WRITE !!?2,"Select Food Item #, '",$SELECT(YN:"^",1:"RETURN"),"' to Quit"
- IF YN
- WRITE ",",!?2,"or 'RETURN' to continue list"
- +2 READ " => ",YN:DTIME
- IF '$TEST!(YN["^")
- SET FFN=""
- GOTO END
- +3 IF YN=""
- IF NM>17
- SET NM=0
- SET XT=""
- GOTO S1
- +4 IF YN["^"
- GOTO FHNU7
- IF YN=""
- IF NOD="AQ"
- GOTO NX
- GOTO FHNU7
- +5 IF YN'?1N.N!(YN<1)!(YN>NM)
- WRITE *7," ??"
- GOTO TOO
- +6 SET FFN=$PIECE(XT,",",YN)
- GOTO OK
- OK SET X=^FHNU(FFN,0)
- SET NAM=$PIECE(X,"^",1)
- SET UNT=$PIECE(X,"^",3)
- SET WT=$PIECE(X,"^",4)
- +1 IF $DATA(FHM(FFN))
- GOTO ED
- +2 SET UNIT=$SELECT(TYP="C":UNT,1:"gms.")
- D2 WRITE !!?2,NAM,!?5,"Amount (",UNIT
- IF TYP="C"
- WRITE " at ",WT," gms"
- WRITE ") => "
- READ Y:DTIME
- IF '$TEST!(Y["^")
- SET FFN=""
- GOTO END
- +1 IF Y=0
- GOTO FHNU7
- +2 IF Y'?.N.1".".N!(Y'>0)!(Y>99999)
- WRITE *7,!," Enter amount of item. Enter 0 to delete;",!," otherwise enter a number greater than 0 but less than 99999."
- GOTO D2
- +3 IF TYP="C"
- WRITE " ... ",Y*WT," grams"
- +4 IF TYP="C"
- IF Y'>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"
- +5 SET FHM(FFN)=Y
- SET AMT=Y
- IF TYP="C"
- SET FHM(FFN)=FHM(FFN)_","_UNIT_","_WT
- END KILL NOD,F,J,K,L,LL,NM,NX,XT,X,Y,YN
- QUIT
- NX SET NOD="B"
- SET (FFN,NAM,AMT)=""
- GOTO F0
- ED WRITE !!?2,"You have already selected ",NAM
- +1 IF TYP="C"
- SET UNIT=$PIECE(FHM(FFN),",",2)
- SET WT=$PIECE(FHM(FFN),",",3)
- +2 IF '$TEST
- SET UNIT="gms."
- E1 WRITE !!?2,"Change amount from ",(+FHM(FFN))," ",UNIT," to: "
- READ Y:DTIME
- IF '$TEST!(Y["^")
- SET FFN=""
- GOTO END
- +1 IF Y'?.N.1".".N!(Y'>0)!(Y>99999)
- WRITE *7,!," Enter an amount greater than 0 but less than 99999"
- GOTO E1
- +2 WRITE " ",UNIT
- SET (Y,AMT)=+Y
- SET $PIECE(FHM(FFN),",",1)=AMT
- GOTO END
