source: FOIAVistA/trunk/r/DIETETICS-FH/FHMTK2.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 1.7 KB
Line 
1FHMTK2 ; HISC/NCA - List Diet Patterns ;4/25/95 09:54
2 ;;5.5;DIETETICS;;Jan 28, 2005
3ASK R !!,"Print ALL Diet Patterns? Y// ",ANS:DTIME G:'$T!(ANS="^") KIL S:ANS="" ANS="Y" S X=ANS D TR^FH S ANS=X
4 I $P("YES",ANS,1)'="",$P("NO",ANS,1)'="" W *7,!," Answer YES to print all Diet Patterns; NO to select ONE Diet Pattern to print" G ASK
5 I ANS?1"Y".E S FHDA="" G LIS
6F0 K DI S N1=0
7F1 W ! K DIC S DIC="^FH(111,",DIC(0)="AEQMZ" D ^DIC K DIC G KIL:X[U!$D(DTOUT),F5:X="",F1:Y<1
8 S PREC=$P(Y(0),U,4) I PREC,$D(DI(PREC)) W *7,!!,"This conflicts with ",$P(DI(PREC),"^",2),! G F1
9 S N1=N1+1,DI(PREC)=+Y_"^"_Y(0) G F5:+Y=1,F1:N1<5 W *7,!!,"You have now selected the maximum of 5 Diet Modifications!"
10F5 G:'N1 KIL
11 I N1>1 D I CHK W !!,"You can not select REGULAR with another Diet." G F0
12 .S CHK=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" I +DI(D0)=1 S CHK=1 Q
13 .Q
14 W !!,"You have selected the following Diet:",!
15 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" W !?5,$P(DI(D0),U,2)
16F9 R !!,"Is this Correct? Y// ",Y:DTIME G:'$T!(Y="^") KIL S:Y="" Y="Y" S X=Y D TR^FH S Y=X
17 I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to accept diet list; NO to select diets again" G F9
18 I Y'?1"Y".E W !!,"Select new diets ..." G F0
19 S FHOR="^^^^",N1=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" S N1=N1+1,$P(FHOR,U,N1)=+DI(D0)
20 S Y="" F A1=1:1:5 S D3=$P(FHOR,"^",A1) Q:'D3 S:Y'="" Y=Y_", " S Y=Y_$P(^FH(111,D3,0),"^",7)
21 S FHDA=$O(^FH(111.1,"AB",FHOR,0)) I 'FHDA W !,"No Diet Pattern for this Diet Order" G KIL
22 K A1,CHK,DI,D0,D3,FHOR,PREC,N1,Y
23LIS ; List Diet Patterns
24 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
25 I $D(IO("Q")) S FHPGM="L1^FHMTK21",FHLST="ANS^FHDA" D EN2^FH G KIL
26 U IO D L1^FHMTK21 D ^%ZISC K %ZIS,IOP G KIL
27KIL K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.