- FHSEL1 ; HISC/REL/NCA/JH/RTK/FAI - Patient Preferences ;10/20/04 10:19
- ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- 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 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 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 Q:+X<1 S M1=$P(X,"^",2) Q:M1="" S:M1="A" M1="BNE" 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 KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
- 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 G KILL^XUSCLEAN
- FHSEL1 ; HISC/REL/NCA/JH/RTK/FAI - Patient Preferences ;10/20/04 10:19
- +1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- 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
- KILL DA,DIE,DR
- +4 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)
- +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 IF +X<1
- QUIT
- SET M1=$PIECE(X,"^",2)
- IF M1=""
- QUIT
- IF M1="A"
- SET M1="BNE"
- SET Z=$GET(^FH(115.2,+X,0))
- IF $PIECE(Z,U)=""!$PIECE(Z,U,2)=""
- QUIT
- SET L1=$PIECE(Z,"^",1)
- SET KK=$PIECE(Z,"^",2)
- SET M=""
- SET DAS=$PIECE(X,"^",4)
- +1 IF KK="L"
- SET Q=$PIECE(X,"^",3)
- SET L1=$SELECT(Q:Q,1:1)_" "_L1
- +2 IF M1="BNE"
- SET M="1~All Meals"
- GOTO SP1
- +3 SET Z1=$EXTRACT(M1,1)
- IF Z1'=""
- SET M=$SELECT(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
- +4 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 GOTO KILL^XUSCLEAN
