FHIPST20 ; HISC/REL/NCA - Remove American Diet Products ;12/14/94 15:44
;;5.0;Dietetics;;Oct 11, 1995
STOR ; Store American Diet Products
K ^TMP($J,"FHITEM"),^TMP($J,"FHPROD") F K=5999:0 S K=$O(^FHNU(K)) Q:K<1 D
.S X=^(K,0),KL=0
.I X["AMDIETPROD" S KL=1
.I X["AMER.DIET" S KL=1
.I X["(VA)" S KL=1
.I X["AMHOSCO" S KL=1
.I KL S ^TMP($J,"FHPROD",K)=""
.Q
I '$D(^TMP($J,"FHPROD")) K K,X,KL Q
CHK ; Check existing pointers in file 113,114,and 112.6
W !!,"Checking Ingredient Default Nutrient in file 113 ..."
F K=0:0 S K=$O(^FHING(K)) Q:K<1 S Y=+$P(^(K,0),"^",21) I Y D
.I '$D(^FHNU(Y)) S $P(^FHING(K,0),"^",21)="" Q
.Q:'$D(^TMP($J,"FHPROD",Y))
.S $P(^FHING(K,0),"^",21)="" Q
W !!,"Checking Recipe Default Nut in 114 ..."
F L=0:0 S L=$O(^FH(114,L)) Q:L<1 F K=0:0 S K=$O(^FH(114,L,"I",K)) Q:K<1 S Y=+$P(^(K,0),"^",3) I Y D
.I '$D(^FHNU(Y)) S $P(^FH(114,L,"I",K,0),"^",3)="" Q
.Q:'$D(^TMP($J,"FHPROD",Y))
.S $P(^FH(114,L,"I",K,0),"^",3)="" Q
W !!,"Checking User Menu 112.6 ..."
F L=0:0 S L=$O(^FHUM(L)) Q:L<1 F M=0:0 S M=$O(^FHUM(L,1,M)) Q:M<1 F N=0:0 S N=$O(^FHUM(L,1,M,1,N)) Q:N<1 F K=0:0 S K=$O(^FHUM(L,1,M,1,N,1,K)) Q:K<1 S Y=+^(K,0) I Y D
.I '$D(^FHNU(Y)) S ^TMP($J,"FHITEM",L,M,N,K)="" Q
.Q:'$D(^TMP($J,"FHPROD",Y))
.S ^TMP($J,"FHITEM",L,M,N,K)="" Q
F L=0:0 S L=$O(^TMP($J,"FHITEM",L)) Q:L<1 F M=0:0 S M=$O(^TMP($J,"FHITEM",L,M)) Q:M<1 F N=0:0 S N=$O(^TMP($J,"FHITEM",L,M,N)) Q:N<1 F K=0:0 S K=$O(^TMP($J,"FHITEM",L,M,N,K)) Q:K<1 D
.K ^FHUM(L,1,M,1,N,1,K,0)
.S $P(^FHUM(L,1,M,1,N,1,0),"^",4)=$P(^FHUM(L,1,M,1,N,1,0),"^",4)-1 Q
REMV ; Remove American Diet Product entries
W !,"Remove American Diet Products From Food Nutrient File ..."
K DA,DIK F K=0:0 S K=$O(^TMP($J,"FHPROD",K)) Q:K<1 D
.S DA=K I DA S DIK="^FHNU(" D ^DIK
.Q
K ^TMP($J,"FHITEM"),^TMP($J,"FHPROD"),DA,DIK,K,KL,L,M,N,X,Y Q
FHIPST20 ; HISC/REL/NCA - Remove American Diet Products ;12/14/94 15:44
+1 ;;5.0;Dietetics;;Oct 11, 1995
STOR ; Store American Diet Products
+1 KILL ^TMP($JOB,"FHITEM"),^TMP($JOB,"FHPROD")
FOR K=5999:0
SET K=$ORDER(^FHNU(K))
IF K<1
QUIT
Begin DoDot:1
+2 SET X=^(K,0)
SET KL=0
+3 IF X["AMDIETPROD"
SET KL=1
+4 IF X["AMER.DIET"
SET KL=1
+5 IF X["(VA)"
SET KL=1
+6 IF X["AMHOSCO"
SET KL=1
+7 IF KL
SET ^TMP($JOB,"FHPROD",K)=""
+8 QUIT
End DoDot:1
+9 IF '$DATA(^TMP($JOB,"FHPROD"))
KILL K,X,KL
QUIT
CHK ; Check existing pointers in file 113,114,and 112.6
+1 WRITE !!,"Checking Ingredient Default Nutrient in file 113 ..."
+2 FOR K=0:0
SET K=$ORDER(^FHING(K))
IF K<1
QUIT
SET Y=+$PIECE(^(K,0),"^",21)
IF Y
Begin DoDot:1
+3 IF '$DATA(^FHNU(Y))
SET $PIECE(^FHING(K,0),"^",21)=""
QUIT
+4 IF '$DATA(^TMP($JOB,"FHPROD",Y))
QUIT
+5 SET $PIECE(^FHING(K,0),"^",21)=""
QUIT
End DoDot:1
+6 WRITE !!,"Checking Recipe Default Nut in 114 ..."
+7 FOR L=0:0
SET L=$ORDER(^FH(114,L))
IF L<1
QUIT
FOR K=0:0
SET K=$ORDER(^FH(114,L,"I",K))
IF K<1
QUIT
SET Y=+$PIECE(^(K,0),"^",3)
IF Y
Begin DoDot:1
+8 IF '$DATA(^FHNU(Y))
SET $PIECE(^FH(114,L,"I",K,0),"^",3)=""
QUIT
+9 IF '$DATA(^TMP($JOB,"FHPROD",Y))
QUIT
+10 SET $PIECE(^FH(114,L,"I",K,0),"^",3)=""
QUIT
End DoDot:1
+11 WRITE !!,"Checking User Menu 112.6 ..."
+12 FOR L=0:0
SET L=$ORDER(^FHUM(L))
IF L<1
QUIT
FOR M=0:0
SET M=$ORDER(^FHUM(L,1,M))
IF M<1
QUIT
FOR N=0:0
SET N=$ORDER(^FHUM(L,1,M,1,N))
IF N<1
QUIT
FOR K=0:0
SET K=$ORDER(^FHUM(L,1,M,1,N,1,K))
IF K<1
QUIT
SET Y=+^(K,0)
IF Y
Begin DoDot:1
+13 IF '$DATA(^FHNU(Y))
SET ^TMP($JOB,"FHITEM",L,M,N,K)=""
QUIT
+14 IF '$DATA(^TMP($JOB,"FHPROD",Y))
QUIT
+15 SET ^TMP($JOB,"FHITEM",L,M,N,K)=""
QUIT
End DoDot:1
+16 FOR L=0:0
SET L=$ORDER(^TMP($JOB,"FHITEM",L))
IF L<1
QUIT
FOR M=0:0
SET M=$ORDER(^TMP($JOB,"FHITEM",L,M))
IF M<1
QUIT
FOR N=0:0
SET N=$ORDER(^TMP($JOB,"FHITEM",L,M,N))
IF N<1
QUIT
FOR K=0:0
SET K=$ORDER(^TMP($JOB,"FHITEM",L,M,N,K))
IF K<1
QUIT
Begin DoDot:1
+17 KILL ^FHUM(L,1,M,1,N,1,K,0)
+18 SET $PIECE(^FHUM(L,1,M,1,N,1,0),"^",4)=$PIECE(^FHUM(L,1,M,1,N,1,0),"^",4)-1
QUIT
End DoDot:1
REMV ; Remove American Diet Product entries
+1 WRITE !,"Remove American Diet Products From Food Nutrient File ..."
+2 KILL DA,DIK
FOR K=0:0
SET K=$ORDER(^TMP($JOB,"FHPROD",K))
IF K<1
QUIT
Begin DoDot:1
+3 SET DA=K
IF DA
SET DIK="^FHNU("
DO ^DIK
+4 QUIT
End DoDot:1
+5 KILL ^TMP($JOB,"FHITEM"),^TMP($JOB,"FHPROD"),DA,DIK,K,KL,L,M,N,X,Y
QUIT
