source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHSEL1.m@ 738

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1FHSEL1 ; HISC/REL/NCA/JH/RTK/FAI - Patient Preferences ;10/20/04 10:19
2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
3EN1 ; Enter/Edit Preference File entries
4 I $G(FHALGMZ)=1 QUIT
5 W ! S (DIC,DIE)="^FH(115.2,",DIC(0)="AEQLM",DIC("DR")=".01;1",DLAYGO=115.2 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN1:Y<1
6 S (FHDA,DA)=+Y,DR=".01;26;1;S:X=""D"" Y=0;3;20;S:'X Y=99;21;27;99" D ^DIE K DA,DIE,DR
7 I $P($G(^FH(115.2,FHDA,0)),"^",2)'="D"!($D(Y)) G EN1
8TRAN R !!,"Do you want to import Recipes from another Food Preference? N // ",X:DTIME
9 G:'$T!(X["^") EN1
10 S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G TRAN
11 S ANS=X?1"Y".E G:'ANS DIS
12T1 W ! K DIC S DIC="^FH(115.2,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=""D""" D ^DIC K DIC
13 G KIL:"^"[X!($D(DTOUT)),T1:Y<1 S FHD=+Y
14 S:'$D(^FH(115.2,FHDA,"X",0)) ^(0)="^115.21P^^"
15 F DIS=0:0 S DIS=$O(^FH(115.2,FHD,"X",DIS)) Q:DIS<1 S L1=$G(^(DIS,0)) D ADD
16DIS S DA=FHDA,DIE="^FH(115.2,",DR="10;27;99" D ^DIE K DA,DIE,DR G EN1
17ADD ; Add dislikes recipes from another food preference
18 I $D(^FH(115.2,FHDA,"X","B",+L1)) Q
19A L +^FH(115.2,FHDA,"X",0)
20 S FHX1=$G(^FH(115.2,FHDA,"X",0)),FHX2=$P(FHX1,"^",3)+1
21 S $P(^FH(115.2,FHDA,"X",0),"^",3)=FHX2
22 L -^FH(115.2,FHDA,"X",0) I $D(^FH(115.2,FHDA,"X",FHX2,0)) G A
23 S $P(^FH(115.2,FHDA,"X",0),"^",4)=($P(FHX1,"^",4)+1)
24 S ^FH(115.2,FHDA,"X",FHX2,0)=+L1
25 S ^FH(115.2,FHDA,"X","B",+L1,FHX2)=""
26 Q
27EN2 ; List Preference File
28 W ! K DIR S DIR("A")="Do you want to print recipes?: "
29 S DIR(0)="YA",DIR("B")="Y" D ^DIR
30 I $D(DIRUT) K %ZIS S IOP="" D ^%ZIS G KIL
31 S FHALRC=Y I FHALRC=1 D EN2OLD Q
32 I FHALRC=0 D EN2NEW Q
33 Q
34EN2OLD W ! S L=0,DIC="^FH(115.2,",FLDS="[FHSELIST]",BY="LIKE OR DISLIKE,NAME"
35 S FR="@",TO="",DHD="PATIENT PREFERENCES" D EN1^DIP
36 K %ZIS S IOP="" D ^%ZIS G KIL
37EN2NEW W ! S L=0,DIC="^FH(115.2,",FLDS="[FHSELST2]",BY="LIKE OR DISLIKE,NAME"
38 S FR="@",TO="",DHD="PATIENT PREFERENCES" D EN1^DIP
39 K %ZIS S IOP="" D ^%ZIS G KIL
40EN3 ; Enter/Edit Patient Preferences
41 S FHALL=1 D ^FHOMDPA G:'FHDFN KIL D DISP S DA=FHDFN W !
42 K PP F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0),PP(+X)=$P(X,"^",2,3)
43 S DIE="^FHPT(",DR="[FHSEL]",DIE("NO^")="" D ^DIE K DIE S FLG=0
44 S:$D(Y) FLG=1
45 S STR="" F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) S:$P(X,"^",2)="" STR=STR_K_"," S:$P(X,"^",2)'="" $P(PP(+X),"^",3,4)=$P(X,"^",2)_"^"_$P(X,"^",3)
46 D N31 K PP
47 I FLG,STR'="" D
48 .S DA(1)=FHDFN F K=1:1 Q:'$P(STR,",",K) S DA=$P(STR,",",K) D
49 ..S DIK="^FHPT("_DA(1)_",""P""," D ^DIK
50 ..Q
51 .W *7,!,"<Preference deleted>" K DIK,DA Q
52 G EN3
53N31 F K=0:0 S K=$O(PP(K)) Q:K<1 D N33
54 S KK=0,COM=""
55N32 S KK=$O(PP(KK)) I KK<1 Q:COM="" S EVT="P^O^^"_$E(COM,2,999) D ^FHORX Q
56 I $L(COM)+$L(PP(KK))>120 S EVT="P^O^^"_$E(COM,2,999) D ^FHORX S COM=""
57 S COM=COM_" "_PP(KK) G N32
58N33 S X1=$P(PP(K),"^",1,2),X2=$P(PP(K),"^",3,4) I X1=X2 K PP(K) Q
59 S X1=$S(X1="^":"Add",X2="":"Del",1:"Mod"),Q=$P(X2,"^",2)
60 I X1["Mod" D
61 .S NOD=$O(^FHPT(FHDFN,"P","B",K,0)) Q:NOD<1
62 .S:$P($G(^FHPT(FHDFN,"P",NOD,0)),"^",4)="Y" $P(^FHPT(FHDFN,"P",NOD,0),"^",4)=""
63 .Q
64 S PP(K)=X1_" "_$S(X2="":"",Q:Q_" ",1:"1 ")_$P(^FH(115.2,K,0),"^",1) S:X2'="" PP(K)=PP(K)_" ("_$P(X2,"^",1)_")" Q
65EN4 ; Display Patient Preferences
66 S FHALL=1 D ^FHOMDPA G:'DFN KIL G:'FHDFN KIL D E41 G EN4
67E41 ; Display Patient Header and Food Preferences
68 D NOW^%DTC S NOW=%,DT=NOW\1
69 S Y(0)=^DPT(DFN,0),SEX=$P(Y(0),"^",2),DOB=$P(Y(0),"^",3) D PID^FHDPA
70 S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))
71 W @IOF,!,PID,?17,$P(Y(0),"^",1),?49,$S(SEX="M":"Male",SEX="F":"Female",1:""),?55,"Age ",AGE
72DISP ; Display Food Preferences
73 W !!?21,"Likes",?54,"DisLikes",!
74 K P S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D SP
75 W ! S (M,MM)="" F S M=$O(P(M)) Q:M="" I $D(P(M)) W $P(M,"~",2) D S MM=M
76 . S (P1,P2)=0 F S:P1'="" P1=$O(P(M,"L",P1)) S X1=$S(P1>0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 W:MM'=M !
77 . Q
78 I $O(P(""))="" W !,"No Food Preferences on file",!
79 Q
80P0 I X1'="" W ?12 S X=X1 D P1 S X1=X
81 I X2'="" W ?46 S X=X2 D P1 S X2=X
82 Q:X1=""&(X2="") W ! G P0
83P1 I $L(X)<34 W X S X="" Q
84 F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
85 W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
86SP Q:+X<1 S M1=$P(X,"^",2) Q:M1="" S:M1="A" M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!$P(Z,U,2)="" S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)
87 I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
88 I M1="BNE" S M="1~All Meals" G SP1
89 S Z1=$E(M1,1) I Z1'="" S M=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
90 S Z1=$E(M1,2) I Z1'="" S M=M_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even")
91SP1 S:'$D(P(M,KK,P1)) P(M,KK,P1)="" I $L(P(M,KK,P1))+$L(L1)<255 S P(M,KK,P1)=P(M,KK,P1)_$S(P(M,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"")
92 E S:'$D(P(M,KK,K)) P(M,KK,K)="" S P(M,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K
93 Q
94KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.