source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHREC5.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.6 KB
Line 
1FHREC5 ; HISC/REL - Recipe Analysis ;5/10/93 10:53
2 ;;5.5;DIETETICS;;Jan 28, 2005
3ALL ; Analyze all Recipes
4 D ^FHIPST6 F REC=0:0 S REC=$O(^FH(114,REC)) Q:REC<1 D ANAL
5 G KIL
6ANAL ; Analyze
7 K A S SUM=0 F KK=1:1:66 S A(KK)=0
8 S POR=$P($G(^FH(114,REC,0)),"^",2) Q:'POR
9 F KK=0:0 S KK=$O(^FH(114,REC,"R",KK)) Q:KK<1 S Y0=$G(^(KK,0)) D R1
10 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
11 I 'SUM Q
12 F K=1:1:66 S A(K)=A(K)/SUM,A(K)=+$J(A(K),0,3)
13 ; File Recipe
14 S NAM=$E("*"_$P($G(^FH(114,REC,0)),"^",1),1,30),DA=$P($G(^FH(114,REC,0)),"^",14) G:DA A1
15 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
16 S $P(^FH(114,REC,0),"^",14)=DA
17 S $P(^FHNU(DA,0),"^",3)="svg.",$P(^(0),"^",7)="X"
18A1 S (Z1,Z2,Z3,Z4)="" F K=1:1:20 S $P(Z1,"^",K)=A(K)
19 F K=21:1:38 S $P(Z2,"^",K-20)=A(K)
20 F K=39:1:56 S $P(Z3,"^",K-38)=A(K)
21 F K=57:1:66 S $P(Z4,"^",K-56)=A(K)
22 S $P(^FHNU(DA,0),"^",4)=$J(SUM/POR*100,0,0)
23 S ^FHNU(DA,1)=Z1,^(2)=Z2 S:Z3'="" ^FHNU(DA,3)=Z3 S:Z4'="" ^FHNU(DA,4)=Z4
24 Q
25R1 ; Analyze embedded recipes
26 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
27 F LL=0:0 S LL=$O(^FH(114,R1,"I",LL)) Q:LL<1 S Y0=$G(^(LL,0)) D I1
28 Q
29I1 S K1=$P(Y0,"^",3) Q:'K1
30 S AMT=$P(Y0,"^",4)*4.536*MUL Q:'AMT S SUM=SUM+AMT
31 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)
32 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)
33 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)
34 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)
35 Q
36KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.