- 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
