source: FOIAVistA/tag/r/DIETETICS-FH/FHPRC6.m@ 628

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

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1FHPRC6 ; HISC/REL/NCA - Edit Meal Production Diets ;2/26/96 10:04
2 ;;5.5;DIETETICS;;Jan 28, 2005
3R0 S DIC="^FH(116.1,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:U[X!$D(DTOUT),R0:Y<1 S D0=+Y
4R1 S DIC="^FH(116.1,D0,""RE"",",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:X[U!$D(DTOUT),R0:X="",R1:Y<1 S D1=+Y
5 Q:$O(^FH(116.1,D0,"RE",D1,"R",0))<1
6R11 S DIC="^FH(116.1,D0,""RE"",D1,""R"",",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:X[U!$D(DTOUT),R1:X="",R11:Y<1 S CAT=+Y
7 S OLD=$P(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)
8 I $E(OLD,$L(OLD))=" " S OLD=$E(OLD,1,$L(OLD)-1)
9 S NEW=OLD D IN
10R2 D LI R !!,"Action: ",Y:DTIME G:'$T KIL I "^"[Y S:OLD'=NEW $P(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)=NEW G R1
11 I Y["?" D IN G R2
12 S X=Y D TR^FH S Y=X
13 S Z=$E(Y,1),FLG=0 G AD:Z="+",DE:Z="-",MO
14 Q
15AD S FHX1=$E(Y,2,999) F LL=1:1 Q:$P(FHX1," ",LL,99)="" S FHX2=$P(FHX1," ",LL),PD=$P(FHX2,";",1) D A1 Q:'$D(X)
16 W:'FLG " ok"
17 G R2
18A1 D CK I X6<0 S FLG=1 Q
19 I X6 W *7,!?5," ",FHX2," already exists! Use Modify option." S FLG=1 Q
20 S X=NEW_" "_FHX2 S:$E(X,1)=" " X=$E(X,2,999) D EN2^FHPRC1 I $D(X) S NEW=X
21 Q
22DE S FHX1=$E(Y,2,999) F LL=1:1 Q:$P(FHX1," ",LL,99)="" S FHX2=$P(FHX1," ",LL),PD=$P(FHX2,";",1) D D1
23 W:'FLG " ok"
24 G R2
25D1 D CK I X6<0 S FLG=1 Q
26 I 'X6 W *7,!?5," ",FHX2," does not exist!" S FLG=1 Q
27 S X=$P(NEW," ",1,X6-1)_" "_$P(NEW," ",X6+1,999) S:$E(X,1)=" " X=$E(X,2,999) S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1)
28 D EN2^FHPRC1 I $D(X) S NEW=X
29 Q
30MO S PD=$E(Y,1,2) D CK G:X6<0 R2
31 I 'X6 W *7," ",PD," does not exist!" G R2
32 S X=NEW,$P(X," ",X6)=Y I $L(X)>200 W *7,!!?5,"String Length >200." K X G R2
33 D EN2^FHPRC1 I $D(X) S NEW=X W " ok"
34 G R2
35CK S:PD'?1U1UN PD="---" I '$D(^FH(116.2,"C",PD)) W *7,!?5," ",PD," Not a valid Production Diet code!" S X6=-1 Q
36 S X6=0 F K=1:1 S Z=$P(NEW," ",K) Q:Z="" I $E(Z,1,2)=PD S X6=K Q
37 Q
38E1 W *7," Illegal Production Diet code" G R2
39LI W !!,"Production Diets: " S X=NEW
40L1 I $L(X)<61 W ?19,X Q
41 F N1=61:-1:1 Q:$E(X,N1)=" "
42 W ?19,$E(X,1,N1-1) S X=$E(X,N1+1,999) Q:X="" W ! G L1
43IN W !!?5,"Enter + to add (example: +RG;C50)"
44 W !?5,"Enter -Production Diet to delete (example: -RG)"
45 W !?5,"Enter new code to modify (example: LS;C30)" Q
46KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.