- FHREC5 ; HISC/REL - Recipe Analysis ;5/10/93 10:53
- ;;5.5;DIETETICS;;Jan 28, 2005
- ALL ; Analyze all Recipes
- D ^FHIPST6 F REC=0:0 S REC=$O(^FH(114,REC)) Q:REC<1 D ANAL
- G KIL
- ANAL ; Analyze
- K A S SUM=0 F KK=1:1:66 S A(KK)=0
- S POR=$P($G(^FH(114,REC,0)),"^",2) Q:'POR
- F KK=0:0 S KK=$O(^FH(114,REC,"R",KK)) Q:KK<1 S Y0=$G(^(KK,0)) D R1
- S MUL=1 F KK=0:0 S KK=$O(^FH(114,REC,"I",KK)) Q:KK<1 S Y0=$G(^(KK,0)) D I1
- I 'SUM Q
- F K=1:1:66 S A(K)=A(K)/SUM,A(K)=+$J(A(K),0,3)
- ; File Recipe
- S NAM=$E("*"_$P($G(^FH(114,REC,0)),"^",1),1,30),DA=$P($G(^FH(114,REC,0)),"^",14) G:DA A1
- K DIC,DD,DO,DINUM S (DIC,DIE)="^FHNU(",DIC(0)="L",DLAYGO=112,X=NAM D FILE^DICN K DIC,DLAYGO Q:Y<1 S DA=+Y
- S $P(^FH(114,REC,0),"^",14)=DA
- S $P(^FHNU(DA,0),"^",3)="svg.",$P(^(0),"^",7)="X"
- A1 S (Z1,Z2,Z3,Z4)="" F K=1:1:20 S $P(Z1,"^",K)=A(K)
- F K=21:1:38 S $P(Z2,"^",K-20)=A(K)
- F K=39:1:56 S $P(Z3,"^",K-38)=A(K)
- F K=57:1:66 S $P(Z4,"^",K-56)=A(K)
- S $P(^FHNU(DA,0),"^",4)=$J(SUM/POR*100,0,0)
- S ^FHNU(DA,1)=Z1,^(2)=Z2 S:Z3'="" ^FHNU(DA,3)=Z3 S:Z4'="" ^FHNU(DA,4)=Z4
- Q
- R1 ; Analyze embedded recipes
- S R1=+Y0 Q:'R1 S P1=$P(Y0,"^",2) Q:'P1 S MUL=$P($G(^FH(114,R1,0)),"^",2) Q:'MUL S MUL=P1/MUL
- F LL=0:0 S LL=$O(^FH(114,R1,"I",LL)) Q:LL<1 S Y0=$G(^(LL,0)) D I1
- Q
- I1 S K1=$P(Y0,"^",3) Q:'K1
- S AMT=$P(Y0,"^",4)*4.536*MUL Q:'AMT S SUM=SUM+AMT
- S Y=$G(^FHNU(K1,1)) F K=1:1:20 S Z1=$P(Y,"^",K) I Z1'="" S A(K)=Z1*AMT+A(K)
- S Y=$G(^FHNU(K1,2)) F K=21:1:38 S Z1=$P(Y,"^",K-20) I Z1'="" S A(K)=Z1*AMT+A(K)
- S Y=$G(^FHNU(K1,3)) F K=39:1:56 S Z1=$P(Y,"^",K-38) I Z1'="" S A(K)=Z1*AMT+A(K)
- S Y=$G(^FHNU(K1,4)) F K=57:1:66 S Z1=$P(Y,"^",K-56) I Z1'="" S A(K)=Z1*AMT+A(K)
- Q
- KIL G KILL^XUSCLEAN
- FHREC5 ; HISC/REL - Recipe Analysis ;5/10/93 10:53
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- ALL ; Analyze all Recipes
- +1 DO ^FHIPST6
- FOR REC=0:0
- SET REC=$ORDER(^FH(114,REC))
- IF REC<1
- QUIT
- DO ANAL
- +2 GOTO KIL
- ANAL ; Analyze
- +1 KILL A
- SET SUM=0
- FOR KK=1:1:66
- SET A(KK)=0
- +2 SET POR=$PIECE($GET(^FH(114,REC,0)),"^",2)
- IF 'POR
- QUIT
- +3 FOR KK=0:0
- SET KK=$ORDER(^FH(114,REC,"R",KK))
- IF KK<1
- QUIT
- SET Y0=$GET(^(KK,0))
- DO R1
- +4 SET MUL=1
- FOR KK=0:0
- SET KK=$ORDER(^FH(114,REC,"I",KK))
- IF KK<1
- QUIT
- SET Y0=$GET(^(KK,0))
- DO I1
- +5 IF 'SUM
- QUIT
- +6 FOR K=1:1:66
- SET A(K)=A(K)/SUM
- SET A(K)=+$JUSTIFY(A(K),0,3)
- +7 ; File Recipe
- +8 SET NAM=$EXTRACT("*"_$PIECE($GET(^FH(114,REC,0)),"^",1),1,30)
- SET DA=$PIECE($GET(^FH(114,REC,0)),"^",14)
- IF DA
- GOTO A1
- +9 KILL DIC,DD,DO,DINUM
- SET (DIC,DIE)="^FHNU("
- SET DIC(0)="L"
- SET DLAYGO=112
- SET X=NAM
- DO FILE^DICN
- KILL DIC,DLAYGO
- IF Y<1
- QUIT
- SET DA=+Y
- +10 SET $PIECE(^FH(114,REC,0),"^",14)=DA
- +11 SET $PIECE(^FHNU(DA,0),"^",3)="svg."
- SET $PIECE(^(0),"^",7)="X"
- A1 SET (Z1,Z2,Z3,Z4)=""
- FOR K=1:1:20
- SET $PIECE(Z1,"^",K)=A(K)
- +1 FOR K=21:1:38
- SET $PIECE(Z2,"^",K-20)=A(K)
- +2 FOR K=39:1:56
- SET $PIECE(Z3,"^",K-38)=A(K)
- +3 FOR K=57:1:66
- SET $PIECE(Z4,"^",K-56)=A(K)
- +4 SET $PIECE(^FHNU(DA,0),"^",4)=$JUSTIFY(SUM/POR*100,0,0)
- +5 SET ^FHNU(DA,1)=Z1
- SET ^(2)=Z2
- IF Z3'=""
- SET ^FHNU(DA,3)=Z3
- IF Z4'=""
- SET ^FHNU(DA,4)=Z4
- +6 QUIT
- R1 ; Analyze embedded recipes
- +1 SET R1=+Y0
- IF 'R1
- QUIT
- SET P1=$PIECE(Y0,"^",2)
- IF 'P1
- QUIT
- SET MUL=$PIECE($GET(^FH(114,R1,0)),"^",2)
- IF 'MUL
- QUIT
- SET MUL=P1/MUL
- +2 FOR LL=0:0
- SET LL=$ORDER(^FH(114,R1,"I",LL))
- IF LL<1
- QUIT
- SET Y0=$GET(^(LL,0))
- DO I1
- +3 QUIT
- I1 SET K1=$PIECE(Y0,"^",3)
- IF 'K1
- QUIT
- +1 SET AMT=$PIECE(Y0,"^",4)*4.536*MUL
- IF 'AMT
- QUIT
- SET SUM=SUM+AMT
- +2 SET Y=$GET(^FHNU(K1,1))
- FOR K=1:1:20
- SET Z1=$PIECE(Y,"^",K)
- IF Z1'=""
- SET A(K)=Z1*AMT+A(K)
- +3 SET Y=$GET(^FHNU(K1,2))
- FOR K=21:1:38
- SET Z1=$PIECE(Y,"^",K-20)
- IF Z1'=""
- SET A(K)=Z1*AMT+A(K)
- +4 SET Y=$GET(^FHNU(K1,3))
- FOR K=39:1:56
- SET Z1=$PIECE(Y,"^",K-38)
- IF Z1'=""
- SET A(K)=Z1*AMT+A(K)
- +5 SET Y=$GET(^FHNU(K1,4))
- FOR K=57:1:66
- SET Z1=$PIECE(Y,"^",K-56)
- IF Z1'=""
- SET A(K)=Z1*AMT+A(K)
- +6 QUIT
- KIL GOTO KILL^XUSCLEAN