FHSEL1 ; HISC/REL/NCA/JH/RTK/FAI - Patient Preferences ;10/20/04 10:19
;;5.5;DIETETICS;**8,24,29,36**;Jan 28, 2005;Build 3
EN1 ; Enter/Edit Preference File entries
I $G(FHALGMZ)=1 QUIT
W ! S (DIC,DIE)="^FH(115.2,",DIC(0)="AEQLM",DIC("DR")=".01;1",DLAYGO=115.2 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN1:Y<1
S (FHDA,DA)=+Y,DR=".01;26;1;S:X=""D"" Y=0;3;20;S:'X Y=99;21;27;99" D ^DIE
I $E($P($G(^FH(115.2,DA,0)),"^"),1,10)="ALLERGY - " S DR="25" D ^DIE
K DA,DIE,DR
I $P($G(^FH(115.2,FHDA,0)),"^",2)'="D"!($D(Y)) G EN1
TRAN R !!,"Do you want to import Recipes from another Food Preference? N // ",X:DTIME
G:'$T!(X["^") EN1
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 G:'ANS DIS
T1 W ! K DIC S DIC="^FH(115.2,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=""D""" D ^DIC K DIC
G KIL:"^"[X!($D(DTOUT)),T1:Y<1 S FHD=+Y
S:'$D(^FH(115.2,FHDA,"X",0)) ^(0)="^115.21P^^"
F DIS=0:0 S DIS=$O(^FH(115.2,FHD,"X",DIS)) Q:DIS<1 S L1=$G(^(DIS,0)) D ADD
DIS S DA=FHDA,DIE="^FH(115.2,",DR="10;27;99" D ^DIE K DA,DIE,DR G EN1
ADD ; Add dislikes recipes from another food preference
I $D(^FH(115.2,FHDA,"X","B",+L1)) Q
A L +^FH(115.2,FHDA,"X",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
S FHX1=$G(^FH(115.2,FHDA,"X",0)),FHX2=$P(FHX1,"^",3)+1
S $P(^FH(115.2,FHDA,"X",0),"^",3)=FHX2
L -^FH(115.2,FHDA,"X",0) I $D(^FH(115.2,FHDA,"X",FHX2,0)) G A
S $P(^FH(115.2,FHDA,"X",0),"^",4)=($P(FHX1,"^",4)+1)
S ^FH(115.2,FHDA,"X",FHX2,0)=+L1
S ^FH(115.2,FHDA,"X","B",+L1,FHX2)=""
Q
EN2 ; List Preference File
W ! K DIR S DIR("A")="Do you want to print recipes?: "
S DIR(0)="YA",DIR("B")="Y" D ^DIR
I $D(DIRUT) K %ZIS S IOP="" D ^%ZIS G KIL
S FHALRC=Y I FHALRC=1 D EN2OLD Q
I FHALRC=0 D EN2NEW Q
Q
EN2OLD W ! S L=0,DIC="^FH(115.2,",FLDS="[FHSELIST]",BY="LIKE OR DISLIKE,NAME"
S FR="@",TO="",DHD="PATIENT PREFERENCES" D EN1^DIP
K %ZIS S IOP="" D ^%ZIS G KIL
EN2NEW W ! S L=0,DIC="^FH(115.2,",FLDS="[FHSELST2]",BY="LIKE OR DISLIKE,NAME"
S FR="@",TO="",DHD="PATIENT PREFERENCES" D EN1^DIP
K %ZIS S IOP="" D ^%ZIS G KIL
EN3 ; Enter/Edit Patient Preferences
S FHALL=1 D ^FHOMDPA G:'FHDFN KIL D DISP S DA=FHDFN W !
K PP F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0),PP(+X)=$P(X,"^",2,3)
S DIE="^FHPT(",DR="[FHSEL]",DIE("NO^")="" D ^DIE K DIE S FLG=0
S:$D(Y) FLG=1
S STR="" F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) S:$P(X,"^",2)="" STR=STR_K_"," S:$P(X,"^",2)'="" $P(PP(+X),"^",3,4)=$P(X,"^",2)_"^"_$P(X,"^",3)
D N31 K PP
I FLG,STR'="" D
.S DA(1)=FHDFN F K=1:1 Q:'$P(STR,",",K) S DA=$P(STR,",",K) D
..S DIK="^FHPT("_DA(1)_",""P""," D ^DIK
..Q
.W *7,!,"<Preference deleted>" K DIK,DA Q
G EN3
N31 F K=0:0 S K=$O(PP(K)) Q:K<1 D N33
S KK=0,COM=""
N32 S KK=$O(PP(KK)) I KK<1 Q:COM="" S EVT="P^O^^"_$E(COM,2,999) D ^FHORX Q
I $L(COM)+$L(PP(KK))>120 S EVT="P^O^^"_$E(COM,2,999) D ^FHORX S COM=""
S COM=COM_" "_PP(KK) G N32
N33 S X1=$P(PP(K),"^",1,2),X2=$P(PP(K),"^",3,4) I X1=X2 K PP(K) Q
S X1=$S(X1="^":"Add",X2="":"Del",1:"Mod"),Q=$P(X2,"^",2)
I X1["Mod" D
.S NOD=$O(^FHPT(FHDFN,"P","B",K,0)) Q:NOD<1
.S:$P($G(^FHPT(FHDFN,"P",NOD,0)),"^",4)="Y" $P(^FHPT(FHDFN,"P",NOD,0),"^",4)=""
.Q
S PP(K)=X1_" "_$S(X2="":"",Q:Q_" ",1:"1 ")_$P(^FH(115.2,K,0),"^",1) S:X2'="" PP(K)=PP(K)_" ("_$P(X2,"^",1)_")" Q
EN4 ; Display Patient Preferences
S FHALL=1 D ^FHOMDPA G:'DFN KIL G:'FHDFN KIL D E41 G EN4
E41 ; Display Patient Header and Food Preferences
D NOW^%DTC S NOW=%,DT=NOW\1
S Y(0)=^DPT(DFN,0),SEX=$P(Y(0),"^",2),DOB=$P(Y(0),"^",3) D PID^FHDPA
S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))
W @IOF,!,PID,?17,$P(Y(0),"^",1),?49,$S(SEX="M":"Male",SEX="F":"Female",1:""),?55,"Age ",AGE
DISP ; Display Food Preferences
W !!?21,"Likes",?54,"DisLikes",!
K P S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D SP
W ! S (M,MM)="" F S M=$O(P(M)) Q:M="" I $D(P(M)) W $P(M,"~",2) D S MM=M
. S (P1,P2)=0 F S:P1'="" P1=$O(P(M,"L",P1)) S X1=$S(P1>0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 W:MM'=M !
. Q
I $O(P(""))="" W !,"No Food Preferences on file",!
Q
P0 I X1'="" W ?12 S X=X1 D P1 S X1=X
I X2'="" W ?46 S X=X2 D P1 S X2=X
Q:X1=""&(X2="") W ! G P0
P1 I $L(X)<34 W X S X="" Q
F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
SP ;Build food prefences print array
Q:+X<1
S M1=$S($P(X,U,2)="":"BNE",$P(X,U,2)="A":"BNE",1:$P(X,U,2))
S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!$P(Z,U,2)=""
S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)
I $P(X,U,2)="" S L1=L1_" *Need Meal*"
I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
I $P(X,U,2)="" S M="0~No Meal" G SP1
I M1="BNE" S M="1~All Meals" G SP1
S Z1=$E(M1,1) I Z1'="" S M=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
S Z1=$E(M1,2) I Z1'="" S M=M_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even")
SP1 S:'$D(P(M,KK,P1)) P(M,KK,P1)="" I $L(P(M,KK,P1))+$L(L1)<255 S P(M,KK,P1)=P(M,KK,P1)_$S(P(M,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"")
E S:'$D(P(M,KK,K)) P(M,KK,K)="" S P(M,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K
Q
KIL I $G(FHALGMZ) Q
G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSEL1 5199 printed Sep 23, 2025@19:30:59 Page 2
FHSEL1 ; HISC/REL/NCA/JH/RTK/FAI - Patient Preferences ;10/20/04 10:19
+1 ;;5.5;DIETETICS;**8,24,29,36**;Jan 28, 2005;Build 3
EN1 ; Enter/Edit Preference File entries
+1 IF $GET(FHALGMZ)=1
QUIT
+2 WRITE !
SET (DIC,DIE)="^FH(115.2,"
SET DIC(0)="AEQLM"
SET DIC("DR")=".01;1"
SET DLAYGO=115.2
WRITE !
DO ^DIC
KILL DIC,DLAYGO
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO EN1
+3 SET (FHDA,DA)=+Y
SET DR=".01;26;1;S:X=""D"" Y=0;3;20;S:'X Y=99;21;27;99"
DO ^DIE
+4 IF $EXTRACT($PIECE($GET(^FH(115.2,DA,0)),"^"),1,10)="ALLERGY - "
SET DR="25"
DO ^DIE
+5 KILL DA,DIE,DR
+6 IF $PIECE($GET(^FH(115.2,FHDA,0)),"^",2)'="D"!($DATA(Y))
GOTO EN1
TRAN READ !!,"Do you want to import Recipes from another Food Preference? N // ",X:DTIME
+1 if '$TEST!(X["^")
GOTO EN1
+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
GOTO DIS
T1 WRITE !
KILL DIC
SET DIC="^FH(115.2,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,2)=""D"""
DO ^DIC
KILL DIC
+1 if "^"[X!($DATA(DTOUT))
GOTO KIL
if Y<1
GOTO T1
SET FHD=+Y
+2 if '$DATA(^FH(115.2,FHDA,"X",0))
SET ^(0)="^115.21P^^"
+3 FOR DIS=0:0
SET DIS=$ORDER(^FH(115.2,FHD,"X",DIS))
if DIS<1
QUIT
SET L1=$GET(^(DIS,0))
DO ADD
DIS SET DA=FHDA
SET DIE="^FH(115.2,"
SET DR="10;27;99"
DO ^DIE
KILL DA,DIE,DR
GOTO EN1
ADD ; Add dislikes recipes from another food preference
+1 IF $DATA(^FH(115.2,FHDA,"X","B",+L1))
QUIT
A LOCK +^FH(115.2,FHDA,"X",0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+1 SET FHX1=$GET(^FH(115.2,FHDA,"X",0))
SET FHX2=$PIECE(FHX1,"^",3)+1
+2 SET $PIECE(^FH(115.2,FHDA,"X",0),"^",3)=FHX2
+3 LOCK -^FH(115.2,FHDA,"X",0)
IF $DATA(^FH(115.2,FHDA,"X",FHX2,0))
GOTO A
+4 SET $PIECE(^FH(115.2,FHDA,"X",0),"^",4)=($PIECE(FHX1,"^",4)+1)
+5 SET ^FH(115.2,FHDA,"X",FHX2,0)=+L1
+6 SET ^FH(115.2,FHDA,"X","B",+L1,FHX2)=""
+7 QUIT
EN2 ; List Preference File
+1 WRITE !
KILL DIR
SET DIR("A")="Do you want to print recipes?: "
+2 SET DIR(0)="YA"
SET DIR("B")="Y"
DO ^DIR
+3 IF $DATA(DIRUT)
KILL %ZIS
SET IOP=""
DO ^%ZIS
GOTO KIL
+4 SET FHALRC=Y
IF FHALRC=1
DO EN2OLD
QUIT
+5 IF FHALRC=0
DO EN2NEW
QUIT
+6 QUIT
EN2OLD WRITE !
SET L=0
SET DIC="^FH(115.2,"
SET FLDS="[FHSELIST]"
SET BY="LIKE OR DISLIKE,NAME"
+1 SET FR="@"
SET TO=""
SET DHD="PATIENT PREFERENCES"
DO EN1^DIP
+2 KILL %ZIS
SET IOP=""
DO ^%ZIS
GOTO KIL
EN2NEW WRITE !
SET L=0
SET DIC="^FH(115.2,"
SET FLDS="[FHSELST2]"
SET BY="LIKE OR DISLIKE,NAME"
+1 SET FR="@"
SET TO=""
SET DHD="PATIENT PREFERENCES"
DO EN1^DIP
+2 KILL %ZIS
SET IOP=""
DO ^%ZIS
GOTO KIL
EN3 ; Enter/Edit Patient Preferences
+1 SET FHALL=1
DO ^FHOMDPA
if 'FHDFN
GOTO KIL
DO DISP
SET DA=FHDFN
WRITE !
+2 KILL PP
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
SET PP(+X)=$PIECE(X,"^",2,3)
+3 SET DIE="^FHPT("
SET DR="[FHSEL]"
SET DIE("NO^")=""
DO ^DIE
KILL DIE
SET FLG=0
+4 if $DATA(Y)
SET FLG=1
+5 SET STR=""
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
if $PIECE(X,"^",2)=""
SET STR=STR_K_","
if $PIECE(X,"^",2)'=""
SET $PIECE(PP(+X),"^",3,4)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^",3)
+6 DO N31
KILL PP
+7 IF FLG
IF STR'=""
Begin DoDot:1
+8 SET DA(1)=FHDFN
FOR K=1:1
if '$PIECE(STR,",",K)
QUIT
SET DA=$PIECE(STR,",",K)
Begin DoDot:2
+9 SET DIK="^FHPT("_DA(1)_",""P"","
DO ^DIK
+10 QUIT
End DoDot:2
+11 WRITE *7,!,"<Preference deleted>"
KILL DIK,DA
QUIT
End DoDot:1
+12 GOTO EN3
N31 FOR K=0:0
SET K=$ORDER(PP(K))
if K<1
QUIT
DO N33
+1 SET KK=0
SET COM=""
N32 SET KK=$ORDER(PP(KK))
IF KK<1
if COM=""
QUIT
SET EVT="P^O^^"_$EXTRACT(COM,2,999)
DO ^FHORX
QUIT
+1 IF $LENGTH(COM)+$LENGTH(PP(KK))>120
SET EVT="P^O^^"_$EXTRACT(COM,2,999)
DO ^FHORX
SET COM=""
+2 SET COM=COM_" "_PP(KK)
GOTO N32
N33 SET X1=$PIECE(PP(K),"^",1,2)
SET X2=$PIECE(PP(K),"^",3,4)
IF X1=X2
KILL PP(K)
QUIT
+1 SET X1=$SELECT(X1="^":"Add",X2="":"Del",1:"Mod")
SET Q=$PIECE(X2,"^",2)
+2 IF X1["Mod"
Begin DoDot:1
+3 SET NOD=$ORDER(^FHPT(FHDFN,"P","B",K,0))
if NOD<1
QUIT
+4 if $PIECE($GET(^FHPT(FHDFN,"P",NOD,0)),"^",4)="Y"
SET $PIECE(^FHPT(FHDFN,"P",NOD,0),"^",4)=""
+5 QUIT
End DoDot:1
+6 SET PP(K)=X1_" "_$SELECT(X2="":"",Q:Q_" ",1:"1 ")_$PIECE(^FH(115.2,K,0),"^",1)
if X2'=""
SET PP(K)=PP(K)_" ("_$PIECE(X2,"^",1)_")"
QUIT
EN4 ; Display Patient Preferences
+1 SET FHALL=1
DO ^FHOMDPA
if 'DFN
GOTO KIL
if 'FHDFN
GOTO KIL
DO E41
GOTO EN4
E41 ; Display Patient Header and Food Preferences
+1 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
+2 SET Y(0)=^DPT(DFN,0)
SET SEX=$PIECE(Y(0),"^",2)
SET DOB=$PIECE(Y(0),"^",3)
DO PID^FHDPA
+3 SET AGE=$EXTRACT(NOW,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(NOW,4,7)<$EXTRACT(DOB,4,7))
+4 WRITE @IOF,!,PID,?17,$PIECE(Y(0),"^",1),?49,$SELECT(SEX="M":"Male",SEX="F":"Female",1:""),?55,"Age ",AGE
DISP ; Display Food Preferences
+1 WRITE !!?21,"Likes",?54,"DisLikes",!
+2 KILL P
SET P1=1
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET X=^(K,0)
DO SP
+3 WRITE !
SET (M,MM)=""
FOR
SET M=$ORDER(P(M))
if M=""
QUIT
IF $DATA(P(M))
WRITE $PIECE(M,"~",2)
Begin DoDot:1
+4 SET (P1,P2)=0
FOR
if P1'=""
SET P1=$ORDER(P(M,"L",P1))
SET X1=$SELECT(P1>0:P(M,"L",P1),1:"")
if P2'=""
SET P2=$ORDER(P(M,"D",P2))
SET X2=$SELECT(P2>0:P(M,"D",P2),1:"")
if P1=""&(P2="")
QUIT
DO P0
if MM'=M
WRITE !
+5 QUIT
End DoDot:1
SET MM=M
+6 IF $ORDER(P(""))=""
WRITE !,"No Food Preferences on file",!
+7 QUIT
P0 IF X1'=""
WRITE ?12
SET X=X1
DO P1
SET X1=X
+1 IF X2'=""
WRITE ?46
SET X=X2
DO P1
SET X2=X
+2 if X1=""&(X2="")
QUIT
WRITE !
GOTO P0
P1 IF $LENGTH(X)<34
WRITE X
SET X=""
QUIT
+1 FOR KK=35:-1:1
if $EXTRACT(X,KK-1,KK)=", "
QUIT
+2 WRITE $EXTRACT(X,1,KK-2)
SET X=$EXTRACT(X,KK+1,999)
QUIT
SP ;Build food prefences print array
+1 if +X<1
QUIT
+2 SET M1=$SELECT($PIECE(X,U,2)="":"BNE",$PIECE(X,U,2)="A":"BNE",1:$PIECE(X,U,2))
+3 SET Z=$GET(^FH(115.2,+X,0))
if $PIECE(Z,U)=""!$PIECE(Z,U,2)=""
QUIT
+4 SET L1=$PIECE(Z,"^",1)
SET KK=$PIECE(Z,"^",2)
SET M=""
SET DAS=$PIECE(X,"^",4)
+5 IF $PIECE(X,U,2)=""
SET L1=L1_" *Need Meal*"
+6 IF KK="L"
SET Q=$PIECE(X,"^",3)
SET L1=$SELECT(Q:Q,1:1)_" "_L1
+7 IF $PIECE(X,U,2)=""
SET M="0~No Meal"
GOTO SP1
+8 IF M1="BNE"
SET M="1~All Meals"
GOTO SP1
+9 SET Z1=$EXTRACT(M1,1)
IF Z1'=""
SET M=$SELECT(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
+10 SET Z1=$EXTRACT(M1,2)
IF Z1'=""
SET M=M_","_$SELECT(Z1="B":"Break",Z1="N":"Noon",1:"Even")
SP1 if '$DATA(P(M,KK,P1))
SET P(M,KK,P1)=""
IF $LENGTH(P(M,KK,P1))+$LENGTH(L1)<255
SET P(M,KK,P1)=P(M,KK,P1)_$SELECT(P(M,KK,P1)="":"",1:", ")_L1_$SELECT(DAS="Y":" (D)",1:"")
+1 IF '$TEST
if '$DATA(P(M,KK,K))
SET P(M,KK,K)=""
SET P(M,KK,K)=L1_$SELECT(DAS="Y":" (D)",1:"")
SET P1=K
+2 QUIT
KIL IF $GET(FHALGMZ)
QUIT
+1 GOTO KILL^XUSCLEAN
