- 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 Feb 18, 2025@23:14:32 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