FHMTK ; HISC/REL/NCA - Enter/Edit Diet Patterns ;12/6/00 15:15
;;5.5;DIETETICS;;Jan 28, 2005
;last edited NOV 27,2000
S FLG=0 K ^TMP($J)
F0 K DI S N1=0,ANS=""
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 I 'N1,'FLG G KIL
I 'N1 D CLEANTMP^FHMTK8 D ^FHMTK7 G KIL ;P30
I N1>1 D I CHK W !!,"You can not order 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 DA=$O(^FH(111.1,"AB",FHOR,0)) G:DA F09
K DIC,DD,DO S DIC="^FH(111.1,",DIC(0)="L",X=Y D FILE^DICN S DA=+Y
S $P(^FH(111.1,DA,0),"^",2,6)=FHOR,^FH(111.1,"AB",FHOR,DA)=""
F09 D NEWTMP^FHMTK8 ;P30
S FHDA=DA D TRAN G:ANS="^" KIL K A1
D CODE I Z,'$P($G(^FH(111.1,FHDA,0)),"^",7) S $P(^FH(111.1,FHDA,0),"^",7)=Z
F10 K DIC,DIE W ! S DIE="^FH(111.1,",DA=FHDA,DR="10:99" D ^DIE K DIC,DIE,DR
I $P($G(^FH(111.1,FHDA,0)),"^",7)="" S DIK="^FH(111.1,",DA(1)=111.1,DA=FHDA D ^DIK W *7,!,"<Pattern deleted>" K DIK,DA,^FH(111.1,"AB",FHOR,FHDA)
S FLG=1 G F0
KIL K ^TMP($J) G KILL^XUSCLEAN
CODE ; Recode diet
S Z=0 Q:"^^^^"[FHOR I FHOR="1^^^^" S Z=1 G C1
S M="^" F K1=1:1:5 S Z=$P(FHOR,"^",K1) Q:Z<1 S M=M_+$P(^FH(111,Z,0),"^",5)_"^"
F LC=0:0 S LC=$O(^FH(116.2,"AR",LC)) Q:LC<1 S X=^(LC) F K1=1:1 S X1=$P(X,"^",K1) Q:X1<1 D REC G:Z C1
S Z=0
C1 Q
REC S Z=$P(X1,":",1),X1=$P(X1,":",2) F K2=1:1 S C=$P(X1," ",K2) Q:C<1 G:M'[("^"_C_"^") R1
Q
R1 S Z=0 Q
TRAN R !!,"Do you want to import Recipe Categories from another Diet Pattern? N // ",X:DTIME
I '$T!(X["^") S ANS="^" Q
S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G TRAN
S ANS=X?1"Y".E Q:'ANS
T1 W ! K DIC S DIC="^FH(111.1,",DIC(0)="AEMQ" D ^DIC K DIC
I "^"[X!($D(DTOUT)) S ANS="^" Q
G:Y<1 T1 S FHD=+Y
L +^FH(111.1,FHDA,0)
S SF=$P($G(^FH(111.1,FHD,0)),"^",8),$P(^FH(111.1,FHDA,0),"^",8)=SF
S:'$D(^FH(111.1,FHDA,"B",0)) ^(0)="^111.115P^^"
S:'$D(^FH(111.1,FHDA,"N",0)) ^(0)="^111.116P^^"
S:'$D(^FH(111.1,FHDA,"E",0)) ^(0)="^111.117P^^"
F MEAL="B","N","E" F LP=0:0 S LP=$O(^FH(111.1,FHD,MEAL,LP)) Q:LP<1 S L1=$G(^(LP,0)) D ADD
S:'$D(^FH(111.1,FHDA,"BS",0)) ^(0)="^111.11P^^"
S:'$D(^FH(111.1,FHDA,"NS",0)) ^(0)="^111.12P^^"
S:'$D(^FH(111.1,FHDA,"ES",0)) ^(0)="^111.13P^^"
F MEAL="BS","NS","ES" F LP=0:0 S LP=$O(^FH(111.1,FHD,MEAL,LP)) Q:LP<1 S L1=$G(^(LP,0)) D ADD
S:'$D(^FH(111.1,FHDA,"RES",0)) ^(0)="^111.119P^^"
S MEAL="RES" F LP=0:0 S LP=$O(^FH(111.1,FHD,MEAL,LP)) Q:LP<1 S L1=$G(^(LP,0)) D ADD
L -^FH(111.1,FHDA,0) W !,"..Done" Q
ADD I $D(^FH(111.1,FHDA,MEAL,"B",+L1)) Q
A S FHX1=$G(^FH(111.1,FHDA,MEAL,0)),FHX2=$P(FHX1,"^",3)+1
S $P(^FH(111.1,FHDA,MEAL,0),"^",3)=FHX2
I $D(^FH(111.1,FHDA,MEAL,FHX2,0)) G A
S $P(^FH(111.1,FHDA,MEAL,0),"^",4)=($P(FHX1,"^",4)+1)
S ^FH(111.1,FHDA,MEAL,FHX2,0)=+L1_"^"_$P(L1,"^",2)
S ^FH(111.1,FHDA,MEAL,"B",+L1,FHX2)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK 3655 printed Nov 22, 2024@16:58:14 Page 2
FHMTK ; HISC/REL/NCA - Enter/Edit Diet Patterns ;12/6/00 15:15
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;last edited NOV 27,2000
+3 SET FLG=0
KILL ^TMP($JOB)
F0 KILL DI
SET N1=0
SET ANS=""
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
IF 'FLG
GOTO KIL
+1 ;P30
IF 'N1
DO CLEANTMP^FHMTK8
DO ^FHMTK7
GOTO KIL
+2 IF N1>1
Begin DoDot:1
+3 SET CHK=0
FOR D0=0:0
SET D0=$ORDER(DI(D0))
if D0=""
QUIT
IF +DI(D0)=1
SET CHK=1
QUIT
+4 QUIT
End DoDot:1
IF CHK
WRITE !!,"You can not order REGULAR with another Diet."
GOTO F0
+5 WRITE !!,"You have selected the following Diet:",!
+6 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 DA=$ORDER(^FH(111.1,"AB",FHOR,0))
if DA
GOTO F09
+6 KILL DIC,DD,DO
SET DIC="^FH(111.1,"
SET DIC(0)="L"
SET X=Y
DO FILE^DICN
SET DA=+Y
+7 SET $PIECE(^FH(111.1,DA,0),"^",2,6)=FHOR
SET ^FH(111.1,"AB",FHOR,DA)=""
F09 ;P30
DO NEWTMP^FHMTK8
+1 SET FHDA=DA
DO TRAN
if ANS="^"
GOTO KIL
KILL A1
+2 DO CODE
IF Z
IF '$PIECE($GET(^FH(111.1,FHDA,0)),"^",7)
SET $PIECE(^FH(111.1,FHDA,0),"^",7)=Z
F10 KILL DIC,DIE
WRITE !
SET DIE="^FH(111.1,"
SET DA=FHDA
SET DR="10:99"
DO ^DIE
KILL DIC,DIE,DR
+1 IF $PIECE($GET(^FH(111.1,FHDA,0)),"^",7)=""
SET DIK="^FH(111.1,"
SET DA(1)=111.1
SET DA=FHDA
DO ^DIK
WRITE *7,!,"<Pattern deleted>"
KILL DIK,DA,^FH(111.1,"AB",FHOR,FHDA)
+2 SET FLG=1
GOTO F0
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
CODE ; Recode diet
+1 SET Z=0
if "^^^^"[FHOR
QUIT
IF FHOR="1^^^^"
SET Z=1
GOTO C1
+2 SET M="^"
FOR K1=1:1:5
SET Z=$PIECE(FHOR,"^",K1)
if Z<1
QUIT
SET M=M_+$PIECE(^FH(111,Z,0),"^",5)_"^"
+3 FOR LC=0:0
SET LC=$ORDER(^FH(116.2,"AR",LC))
if LC<1
QUIT
SET X=^(LC)
FOR K1=1:1
SET X1=$PIECE(X,"^",K1)
if X1<1
QUIT
DO REC
if Z
GOTO C1
+4 SET Z=0
C1 QUIT
REC SET Z=$PIECE(X1,":",1)
SET X1=$PIECE(X1,":",2)
FOR K2=1:1
SET C=$PIECE(X1," ",K2)
if C<1
QUIT
if M'[("^"_C_"^")
GOTO R1
+1 QUIT
R1 SET Z=0
QUIT
TRAN READ !!,"Do you want to import Recipe Categories from another Diet Pattern? N // ",X:DTIME
+1 IF '$TEST!(X["^")
SET ANS="^"
QUIT
+2 if X=""
SET X="N"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7,!," Answer YES or NO"
GOTO TRAN
+3 SET ANS=X?1"Y".E
if 'ANS
QUIT
T1 WRITE !
KILL DIC
SET DIC="^FH(111.1,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+1 IF "^"[X!($DATA(DTOUT))
SET ANS="^"
QUIT
+2 if Y<1
GOTO T1
SET FHD=+Y
+3 LOCK +^FH(111.1,FHDA,0)
+4 SET SF=$PIECE($GET(^FH(111.1,FHD,0)),"^",8)
SET $PIECE(^FH(111.1,FHDA,0),"^",8)=SF
+5 if '$DATA(^FH(111.1,FHDA,"B",0))
SET ^(0)="^111.115P^^"
+6 if '$DATA(^FH(111.1,FHDA,"N",0))
SET ^(0)="^111.116P^^"
+7 if '$DATA(^FH(111.1,FHDA,"E",0))
SET ^(0)="^111.117P^^"
+8 FOR MEAL="B","N","E"
FOR LP=0:0
SET LP=$ORDER(^FH(111.1,FHD,MEAL,LP))
if LP<1
QUIT
SET L1=$GET(^(LP,0))
DO ADD
+9 if '$DATA(^FH(111.1,FHDA,"BS",0))
SET ^(0)="^111.11P^^"
+10 if '$DATA(^FH(111.1,FHDA,"NS",0))
SET ^(0)="^111.12P^^"
+11 if '$DATA(^FH(111.1,FHDA,"ES",0))
SET ^(0)="^111.13P^^"
+12 FOR MEAL="BS","NS","ES"
FOR LP=0:0
SET LP=$ORDER(^FH(111.1,FHD,MEAL,LP))
if LP<1
QUIT
SET L1=$GET(^(LP,0))
DO ADD
+13 if '$DATA(^FH(111.1,FHDA,"RES",0))
SET ^(0)="^111.119P^^"
+14 SET MEAL="RES"
FOR LP=0:0
SET LP=$ORDER(^FH(111.1,FHD,MEAL,LP))
if LP<1
QUIT
SET L1=$GET(^(LP,0))
DO ADD
+15 LOCK -^FH(111.1,FHDA,0)
WRITE !,"..Done"
QUIT
ADD IF $DATA(^FH(111.1,FHDA,MEAL,"B",+L1))
QUIT
A SET FHX1=$GET(^FH(111.1,FHDA,MEAL,0))
SET FHX2=$PIECE(FHX1,"^",3)+1
+1 SET $PIECE(^FH(111.1,FHDA,MEAL,0),"^",3)=FHX2
+2 IF $DATA(^FH(111.1,FHDA,MEAL,FHX2,0))
GOTO A
+3 SET $PIECE(^FH(111.1,FHDA,MEAL,0),"^",4)=($PIECE(FHX1,"^",4)+1)
+4 SET ^FH(111.1,FHDA,MEAL,FHX2,0)=+L1_"^"_$PIECE(L1,"^",2)
+5 SET ^FH(111.1,FHDA,MEAL,"B",+L1,FHX2)=""
+6 QUIT
+7 ;
