source: FOIAVistA/tag/r/DIETETICS-FH/FHADR9.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 3.3 KB
Line 
1FHADR9 ; HISC/NCA - Dietetic Survey ;11/25/94 14:27
2 ;;5.5;DIETETICS;;Jan 28, 2005
3EN1 ; Enter/Edit Dietetic Survey
4 D QR^FHADR1 G:'PRE KIL
5F1 ; Select Survey Category
6 S FHX3=0 K DIR S DIR(0)="SO^1:APPETIZING;2:FOODS PREFERRED;3:HOT ENOUGH;4:COLD ENOUGH;5:COURTEOUS;6:PREFERENCES DISCUSSED;7:TIMELINESS;8:ENOUGH TIME TO EAT;9:NUTRITIONAL INFO;10:OVERALL",DIR("A")="Select SURVEY CATEGORY"
7 S DIR("?")="Select one of the questions on the Dietetic Survey."
8 D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S FHX1=+Y
9 S FLDNUM=69+FHX1
10 S TIT=$P($G(^DD(117.3,FLDNUM,0)),U,4)
11 S TIT=$S(FHX1=1:"Q1AP",FHX1=2:"Q2FP",FHX1=3:"Q3HF",FHX1=4:"Q4CF",FHX1=5:"Q5CR",FHX1=6:"Q6PD",FHX1=7:"Q7TI",FHX1=8:"Q8ET",FHX1=9:"Q9NI",1:"Q10V")
12 I '$D(^FH(117.3,PRE,TIT,0)) D CREAT
13F2 ; Select Service
14 K DIR S DIR(0)="SO^1:GM&S;2:NHCU;3:PSYCH;4:DOM;5:SCI;6:OTHER",DIR("A")="Select SERVICE",DIR("?")="Enter the Service you want to enter or edit."
15 D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S FHX2=+Y
16 I 'FHX3 S FHX3=$P($G(^FH(117.3,PRE,TIT,0)),"^",3) Q:'FHX3
17 S OLD=$P($G(^FH(117.3,PRE,TIT,FHX3,0)),"^",FHX2+1)
18 G RTG
19CREAT ; Create the first entry
20 ;S ^FH(117.3,PRE,TIT,0)=$S(FHX1=1:"^117.358^^",FHX1=2:"^117.359^^",FHX1=3:"^117.31^^",FHX1=4:"^117.361^^",FHX1=5:"^117.362^^",FHX1=6:"^117.363^^",FHX1=7:"^117.364^^",FHX1=8:"^117.365^^",1:"^117.366^^")
21 ;S ^FH(117.3,PRE,TIT,0)=$S(FHX1=1:"^117.37^^",FHX1=2:"^117.371^^",FHX1=3:"^117.372^^",FHX1=4:"^117.373^^",FHX1=5:"^117.374^^",FHX1=6:"^117.375^^",FHX1=7:"^117.376^^",FHX1=8:"^117.377^^",FHX1=8:"^117.378^^",1:"^117.379^^")
22 ;S ^FH(117.3,PRE,TIT,0)=$P($G(^DD(117.3,FLDNUM,0)),U,2)
23 ;S DA=$P(^FH(117.3,PRE,TIT,0),"^",3)+1,$P(^FH(117.3,PRE,TIT,0),"^",3)=DA
24 K DIC,DD,DO S DIC="^FH(117.3,PRE,TIT,",DIC(0)="L",DLAYGO=117.3,DA(1)=PRE
25 S (X,DINUM)=1 D FILE^DICN
26 S FHX3=+Y K DA,DIC,DLAYGO,DINUM Q
27RTG ; Read in Rating String
28 W ! K DIR S DIR(0)="FO^2:35",DIR("A")="Enter Rating String" S:OLD'="" DIR("B")=OLD S DIR("?")="^D HEL^FHADR9"
29 D ^DIR I X="@" S X="" G R1
30 G:$D(DIRUT)!($D(DIROUT)) KIL
31 D C0 I '$D(X) G RTG
32R1 S $P(^FH(117.3,PRE,TIT,FHX3,0),"^",FHX2+1)=X
33F3 W ! K DIR S DIR(0)="YA",DIR("A")="Enter More Rating String for another service ? ",DIR("B")="YES" D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL K DIR
34 G F2:Y,F1
35C0 ; Check validity of the Rating String
36 D TR^FH
37 I $E(X,$L(X))=" " S X=$E(X,1,$L(X)-1)
38 S X9="",(X6,X7)=0 F X4=1:1 Q:$P(X," ",X4,99)="" S X1=$P(X," ",X4) D C1
39 K:X6 X K X1,X2,X3,X4,X5,X6,X7,X8,X9 Q
40C1 I X1="" W *7,!?5,"Two spaces found in input" S X6=1 Q
41 S X5=$F("E V G F U",$E(X1,1)) I 'X5 W *7,!?5,"'",$E(X1,1),"' Not a Rating." S X6=1 Q
42 F X8=1:1 Q:$E(X1,X8)'?1U
43 I X8<2!(X8>2) W *7,!?5,"Illegal String Specification in ",X1 S X6=1 Q
44 I $E(X1,X8,$L(X1))="" W *7,!?5,"No number surveyed for ",X1 S X6=1
45 I $E(X1,X8,$L(X1))'?1.4N W *7,!?5,"Illegal entry in rating ",X1 S X6=1
46 I $E(X1,X8,$L(X1))>9999 W *7,!?5,$E(X1,X8,$L(X1))," cannot be greater than 9999" S X6=1
47 S X2=$E(X1,1)
48 I X9[X2 W *7,!?5,X2," used more than once." S X6=1
49 S X9=X9_" "_X2,X7=X7+1
50 I X7>5 W *7,!?5,"There are only 5 ratings." S X6=1
51 Q
52HEL ; Help Prompt for Rating String
53 W !!,"List the numbers surveyed by specifying which rating it belongs"
54 W !,"to and separated by a single space.",!
55 W !,"Example: E20 V40 G40 F3 U1",!
56 W !," E = Excellent, V = Very Good, G = Good, F = Fair and U = Unacceptable",!
57 W !,"Omit if none surveyed for a certain rating.",! Q
58KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.