FHMTK2 ; HISC/NCA - List Diet Patterns ;4/25/95 09:54
;;5.5;DIETETICS;;Jan 28, 2005
ASK 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
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
I ANS?1"Y".E S FHDA="" G LIS
F0 K DI S N1=0
F1 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
S PREC=$P(Y(0),U,4) I PREC,$D(DI(PREC)) W *7,!!,"This conflicts with ",$P(DI(PREC),"^",2),! G F1
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!"
F5 G:'N1 KIL
I N1>1 D I CHK W !!,"You can not select REGULAR with another Diet." G F0
.S CHK=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0="" I +DI(D0)=1 S CHK=1 Q
.Q
W !!,"You have selected the following Diet:",!
F D0=0:0 S D0=$O(DI(D0)) Q:D0="" W !?5,$P(DI(D0),U,2)
F9 R !!,"Is this Correct? Y// ",Y:DTIME G:'$T!(Y="^") KIL S:Y="" Y="Y" S X=Y D TR^FH S Y=X
I $P("YES",Y,1)'="",$P("NO",Y,1)'="" W *7,!," Answer YES to accept diet list; NO to select diets again" G F9
I Y'?1"Y".E W !!,"Select new diets ..." G F0
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)
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)
S FHDA=$O(^FH(111.1,"AB",FHOR,0)) I 'FHDA W !,"No Diet Pattern for this Diet Order" G KIL
K A1,CHK,DI,D0,D3,FHOR,PREC,N1,Y
LIS ; List Diet Patterns
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="L1^FHMTK21",FHLST="ANS^FHDA" D EN2^FH G KIL
U IO D L1^FHMTK21 D ^%ZISC K %ZIS,IOP G KIL
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK2 1792 printed Apr 09, 2024@21:00:13 Page 2
FHMTK2 ; HISC/NCA - List Diet Patterns ;4/25/95 09:54
+1 ;;5.5;DIETETICS;;Jan 28, 2005
ASK READ !!,"Print ALL Diet Patterns? Y// ",ANS:DTIME
if '$TEST!(ANS="^")
GOTO KIL
if ANS=""
SET ANS="Y"
SET X=ANS
DO TR^FH
SET ANS=X
+1 IF $PIECE("YES",ANS,1)'=""
IF $PIECE("NO",ANS,1)'=""
WRITE *7,!," Answer YES to print all Diet Patterns; NO to select ONE Diet Pattern to print"
GOTO ASK
+2 IF ANS?1"Y".E
SET FHDA=""
GOTO LIS
F0 KILL DI
SET N1=0
F1 WRITE !
KILL DIC
SET DIC="^FH(111,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if X[U!$DATA(DTOUT)
GOTO KIL
if X=""
GOTO F5
if Y<1
GOTO F1
+1 SET PREC=$PIECE(Y(0),U,4)
IF PREC
IF $DATA(DI(PREC))
WRITE *7,!!,"This conflicts with ",$PIECE(DI(PREC),"^",2),!
GOTO F1
+2 SET N1=N1+1
SET DI(PREC)=+Y_"^"_Y(0)
if +Y=1
GOTO F5
if N1<5
GOTO F1
WRITE *7,!!,"You have now selected the maximum of 5 Diet Modifications!"
F5 if 'N1
GOTO KIL
+1 IF N1>1
Begin DoDot:1
+2 SET CHK=0
FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
IF +DI(D0)=1
SET CHK=1
QUIT
+3 QUIT
End DoDot:1
IF CHK
WRITE !!,"You can not select REGULAR with another Diet."
GOTO F0
+4 WRITE !!,"You have selected the following Diet:",!
+5 FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
WRITE !?5,$PIECE(DI(D0),U,2)
F9 READ !!,"Is this Correct? Y// ",Y:DTIME
if '$TEST!(Y="^")
GOTO KIL
if Y=""
SET Y="Y"
SET X=Y
DO TR^FH
SET Y=X
+1 IF $PIECE("YES",Y,1)'=""
IF $PIECE("NO",Y,1)'=""
WRITE *7,!," Answer YES to accept diet list; NO to select diets again"
GOTO F9
+2 IF Y'?1"Y".E
WRITE !!,"Select new diets ..."
GOTO F0
+3 SET FHOR="^^^^"
SET N1=0
FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
SET N1=N1+1
SET $PIECE(FHOR,U,N1)=+DI(D0)
+4 SET Y=""
FOR A1=1:1:5
SET D3=$PIECE(FHOR,"^",A1)
if 'D3
QUIT
if Y'=""
SET Y=Y_", "
SET Y=Y_$PIECE(^FH(111,D3,0),"^",7)
+5 SET FHDA=$ORDER(^FH(111.1,"AB",FHOR,0))
IF 'FHDA
WRITE !,"No Diet Pattern for this Diet Order"
GOTO KIL
+6 KILL A1,CHK,DI,D0,D3,FHOR,PREC,N1,Y
LIS ; List Diet Patterns
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="L1^FHMTK21"
SET FHLST="ANS^FHDA"
DO EN2^FH
GOTO KIL
+3 USE IO
DO L1^FHMTK21
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
