- 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 Mar 13, 2025@20:52:42 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 ;
