FHADR9 ; HISC/NCA - Dietetic Survey ;11/25/94 14:27
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Dietetic Survey
D QR^FHADR1 G:'PRE KIL
F1 ; Select Survey Category
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"
S DIR("?")="Select one of the questions on the Dietetic Survey."
D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S FHX1=+Y
S FLDNUM=69+FHX1
S TIT=$P($G(^DD(117.3,FLDNUM,0)),U,4)
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")
I '$D(^FH(117.3,PRE,TIT,0)) D CREAT
F2 ; Select Service
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."
D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S FHX2=+Y
I 'FHX3 S FHX3=$P($G(^FH(117.3,PRE,TIT,0)),"^",3) Q:'FHX3
S OLD=$P($G(^FH(117.3,PRE,TIT,FHX3,0)),"^",FHX2+1)
G RTG
CREAT ; Create the first entry
;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^^")
;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^^")
;S ^FH(117.3,PRE,TIT,0)=$P($G(^DD(117.3,FLDNUM,0)),U,2)
;S DA=$P(^FH(117.3,PRE,TIT,0),"^",3)+1,$P(^FH(117.3,PRE,TIT,0),"^",3)=DA
K DIC,DD,DO S DIC="^FH(117.3,PRE,TIT,",DIC(0)="L",DLAYGO=117.3,DA(1)=PRE
S (X,DINUM)=1 D FILE^DICN
S FHX3=+Y K DA,DIC,DLAYGO,DINUM Q
RTG ; Read in Rating String
W ! K DIR S DIR(0)="FO^2:35",DIR("A")="Enter Rating String" S:OLD'="" DIR("B")=OLD S DIR("?")="^D HEL^FHADR9"
D ^DIR I X="@" S X="" G R1
G:$D(DIRUT)!($D(DIROUT)) KIL
D C0 I '$D(X) G RTG
R1 S $P(^FH(117.3,PRE,TIT,FHX3,0),"^",FHX2+1)=X
F3 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
G F2:Y,F1
C0 ; Check validity of the Rating String
D TR^FH
I $E(X,$L(X))=" " S X=$E(X,1,$L(X)-1)
S X9="",(X6,X7)=0 F X4=1:1 Q:$P(X," ",X4,99)="" S X1=$P(X," ",X4) D C1
K:X6 X K X1,X2,X3,X4,X5,X6,X7,X8,X9 Q
C1 I X1="" W *7,!?5,"Two spaces found in input" S X6=1 Q
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
F X8=1:1 Q:$E(X1,X8)'?1U
I X8<2!(X8>2) W *7,!?5,"Illegal String Specification in ",X1 S X6=1 Q
I $E(X1,X8,$L(X1))="" W *7,!?5,"No number surveyed for ",X1 S X6=1
I $E(X1,X8,$L(X1))'?1.4N W *7,!?5,"Illegal entry in rating ",X1 S X6=1
I $E(X1,X8,$L(X1))>9999 W *7,!?5,$E(X1,X8,$L(X1))," cannot be greater than 9999" S X6=1
S X2=$E(X1,1)
I X9[X2 W *7,!?5,X2," used more than once." S X6=1
S X9=X9_" "_X2,X7=X7+1
I X7>5 W *7,!?5,"There are only 5 ratings." S X6=1
Q
HEL ; Help Prompt for Rating String
W !!,"List the numbers surveyed by specifying which rating it belongs"
W !,"to and separated by a single space.",!
W !,"Example: E20 V40 G40 F3 U1",!
W !," E = Excellent, V = Very Good, G = Good, F = Fair and U = Unacceptable",!
W !,"Omit if none surveyed for a certain rating.",! Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADR9 3437 printed Nov 22, 2024@16:56:49 Page 2
FHADR9 ; HISC/NCA - Dietetic Survey ;11/25/94 14:27
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Dietetic Survey
+1 DO QR^FHADR1
if 'PRE
GOTO KIL
F1 ; Select Survey Category
+1 SET FHX3=0
KILL DIR
SET 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"
SET DIR("A")="Select SURVEY CATEGORY"
+2 SET DIR("?")="Select one of the questions on the Dietetic Survey."
+3 DO ^DIR
if $DATA(DIRUT)!($DATA(DIROUT))
GOTO KIL
SET FHX1=+Y
+4 SET FLDNUM=69+FHX1
+5 SET TIT=$PIECE($GET(^DD(117.3,FLDNUM,0)),U,4)
+6 SET TIT=$SELECT(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")
+7 IF '$DATA(^FH(117.3,PRE,TIT,0))
DO CREAT
F2 ; Select Service
+1 KILL DIR
SET DIR(0)="SO^1:GM&S;2:NHCU;3:PSYCH;4:DOM;5:SCI;6:OTHER"
SET DIR("A")="Select SERVICE"
SET DIR("?")="Enter the Service you want to enter or edit."
+2 DO ^DIR
if $DATA(DIRUT)!($DATA(DIROUT))
GOTO KIL
SET FHX2=+Y
+3 IF 'FHX3
SET FHX3=$PIECE($GET(^FH(117.3,PRE,TIT,0)),"^",3)
if 'FHX3
QUIT
+4 SET OLD=$PIECE($GET(^FH(117.3,PRE,TIT,FHX3,0)),"^",FHX2+1)
+5 GOTO RTG
CREAT ; Create the first entry
+1 ;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^^")
+2 ;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^^")
+3 ;S ^FH(117.3,PRE,TIT,0)=$P($G(^DD(117.3,FLDNUM,0)),U,2)
+4 ;S DA=$P(^FH(117.3,PRE,TIT,0),"^",3)+1,$P(^FH(117.3,PRE,TIT,0),"^",3)=DA
+5 KILL DIC,DD,DO
SET DIC="^FH(117.3,PRE,TIT,"
SET DIC(0)="L"
SET DLAYGO=117.3
SET DA(1)=PRE
+6 SET (X,DINUM)=1
DO FILE^DICN
+7 SET FHX3=+Y
KILL DA,DIC,DLAYGO,DINUM
QUIT
RTG ; Read in Rating String
+1 WRITE !
KILL DIR
SET DIR(0)="FO^2:35"
SET DIR("A")="Enter Rating String"
if OLD'=""
SET DIR("B")=OLD
SET DIR("?")="^D HEL^FHADR9"
+2 DO ^DIR
IF X="@"
SET X=""
GOTO R1
+3 if $DATA(DIRUT)!($DATA(DIROUT))
GOTO KIL
+4 DO C0
IF '$DATA(X)
GOTO RTG
R1 SET $PIECE(^FH(117.3,PRE,TIT,FHX3,0),"^",FHX2+1)=X
F3 WRITE !
KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Enter More Rating String for another service ? "
SET DIR("B")="YES"
DO ^DIR
if $DATA(DIRUT)!($DATA(DIROUT))
GOTO KIL
KILL DIR
+1 if Y
GOTO F2
GOTO F1
C0 ; Check validity of the Rating String
+1 DO TR^FH
+2 IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 SET X9=""
SET (X6,X7)=0
FOR X4=1:1
if $PIECE(X," ",X4,99)=""
QUIT
SET X1=$PIECE(X," ",X4)
DO C1
+4 if X6
KILL X
KILL X1,X2,X3,X4,X5,X6,X7,X8,X9
QUIT
C1 IF X1=""
WRITE *7,!?5,"Two spaces found in input"
SET X6=1
QUIT
+1 SET X5=$FIND("E V G F U",$EXTRACT(X1,1))
IF 'X5
WRITE *7,!?5,"'",$EXTRACT(X1,1),"' Not a Rating."
SET X6=1
QUIT
+2 FOR X8=1:1
if $EXTRACT(X1,X8)'?1U
QUIT
+3 IF X8<2!(X8>2)
WRITE *7,!?5,"Illegal String Specification in ",X1
SET X6=1
QUIT
+4 IF $EXTRACT(X1,X8,$LENGTH(X1))=""
WRITE *7,!?5,"No number surveyed for ",X1
SET X6=1
+5 IF $EXTRACT(X1,X8,$LENGTH(X1))'?1.4N
WRITE *7,!?5,"Illegal entry in rating ",X1
SET X6=1
+6 IF $EXTRACT(X1,X8,$LENGTH(X1))>9999
WRITE *7,!?5,$EXTRACT(X1,X8,$LENGTH(X1))," cannot be greater than 9999"
SET X6=1
+7 SET X2=$EXTRACT(X1,1)
+8 IF X9[X2
WRITE *7,!?5,X2," used more than once."
SET X6=1
+9 SET X9=X9_" "_X2
SET X7=X7+1
+10 IF X7>5
WRITE *7,!?5,"There are only 5 ratings."
SET X6=1
+11 QUIT
HEL ; Help Prompt for Rating String
+1 WRITE !!,"List the numbers surveyed by specifying which rating it belongs"
+2 WRITE !,"to and separated by a single space.",!
+3 WRITE !,"Example: E20 V40 G40 F3 U1",!
+4 WRITE !," E = Excellent, V = Very Good, G = Good, F = Fair and U = Unacceptable",!
+5 WRITE !,"Omit if none surveyed for a certain rating.",!
QUIT
KIL GOTO KILL^XUSCLEAN
