FHDCR1D ; HISC/REL/NCA/RVD - Build Separate Meal Diet Card ;2/23/00 09:52
;;5.5;DIETETICS;**3,5**;Jan 28, 2005;Build 53
;RVD 8/10/05 added logic on Food Preferences for Bread/Beverages default for outpatient.
;patch #5 - added outpatient SO and fix diet pattern for outpatient.
BLD ; Build Diet Card list for a patient in three per page format
S X1=$G(^FHPT(+FHDFN,"A",+ADM,0)),FHORD=$P(X1,"^",2),SVC=$P(X1,"^",5),SF=$P(X1,"^",7),IS=$P(X1,"^",10),FHD=$P(X1,"^",16),(FHOR,X)=""
I FHPAR'="Y" Q:SVC="C"
I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
Q:'FHORD S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
S PD=$P(X,"^",13),FHOR=$P(X,"^",2,6) Q:"^^^^"[FHOR
I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
S:SF SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
I UPD D OLD^FHMTK11 I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
S STR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
S DPAT=$O(^FH(111.1,"AB",FHOR,0))
K FP,MP,N2,NN I $P(STR,";",$S(MEAL="B":1,MEAL="N":2,1:3))'="" D DECOD^FHDCR1B
I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) D
.I $P(STR,";",$S(MEAL="B":1,MEAL="N":2,1:3))="",$O(MP(MEAL,""))="" F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)) D
..S ZZ=$G(^FH(114.1,+Z1,0)),NAM=$P(ZZ,"^",1)
..S K4=$P(ZZ,"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
..S MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$P(Z1,"^",2) Q
.Q
Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD="" D CHK^FHMTK1B
I NBR=3 D PRT^FHMTK1C K MM,PP,S S NBR=0
S NBR=NBR+1 D PID^FHDPA
F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 D
.S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1,$D(^TMP($J,"FHDEF",MEAL,+P1)) D
..S CHK="" F S CHK=$O(^TMP($J,"DEF",MEAL,PD,CHK)) Q:CHK="" S C1=$G(^(CHK)) I +CHK=+P1,$D(^TMP($J,"FHDEF",MEAL,+CHK,+C1)) D Q
...S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
...S P2=+P1,P3=$P(P1,"^",3) S:'$D(N2(P2,P3)) N2(P2,P3)=+$P(P1,"^",2)_"^"_P3 Q
..Q
S LP="" F S LP=$O(^TMP($J,"DEF",MEAL,PD,LP)) Q:LP="" I '$D(N2(+LP)) D
.S TST=$G(^TMP($J,"DEF",MEAL,PD,LP)),CHK="~"_$P(TST,"~",4,$L(TST,"~")) Q:'$F(CHK,"~"_SP_"~")
.I '$D(FP(+TST)) S N2(+LP,$P(LP,"~",2))=+TST_"^"_$P(LP,"~",2) Q
.Q:FLG
.F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 D
..S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I +PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1,+P1=+LP D
...S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
...S P2=+P1,P3=$P(P1,"^",3) S:'$D(N2(P2,P3)) N2(P2,P3)=+$P(P1,"^",2)_"^"_P3 Q
..Q
S Y0=$P($G(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC,S(NBR)=0,N1=0
D CUR^FHORD7 S N1=N1+1 I $L(Y)<40 S PP(N1,NBR)=Y
E S L=$S($L($P(Y,",",1,3))<40:3,1:2) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
S MM(0,NBR)=Y0_"^"_WRDN_"^"_RM
I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHMTK1B
S X8="" F S X8=$O(MP(MEAL,X8)) Q:X8="" S X1=+MP(MEAL,X8) D
.S Z1=+$P(X8,"~",2),QTY="" Q:'X1 S QTY=$S(+X1#1>0:$J(+X1,3,1),1:+X1_" ")_" "
.S Z1=+$P(X8,"~",2),QTY="" Q:'X1 S PAD=$E(" ",1,5-$L(X1)),QTY=+X1_PAD
.I $D(N2(Z1)) D Q
..S X7="" F S X7=$O(N2(Z1,X7)) Q:X7="" S C1=$P(X8,"~",1,2)_"~"_X7 I '$D(NN(C1)) S NN(C1)=QTY_X7
..Q
.S NN(X8)=QTY_$P(X8,"~",3)
.Q
S X8="" F S X8=$O(NN(X8)) Q:X8="" D
.S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$G(NN(X8)) Q
S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
D SO^FHMTK1B
S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
D DISL
Q
;
OUT ;process outpatient data
S (SVC,SF,IS)=""
I '$D(FHKDAT)!'$G(FHADM) Q
S X1=FHKDAT
S FHWARD=W1 D LOC^FHDCR11
S (FHOR,FHORD)=$P(FHKDAT,U,2),FHD=$P(X1,"^",14)
I FHPAR'="Y" Q:SVC="C"
I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
S:$D(^FHPT(FHDFN,0)) IS=$P(^FHPT(FHDFN,0),U,5)
I $D(^FHPT(FHDFN,"OP",FHADM,"SF",0)) S SF=$P(^(0),U,3)
I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
I SF,$D(^FHPT(FHDFN,"OP",FHADM,"SF",SF,0)),'$P(^(0),U,32) S SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"OP",FHADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
S MEAL=FHMEAL
I UPD D OLD^FHMTK11 I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
S STR=""
S:$G(FHOR) FHOR=FHOR_"^^^^"
I FHOR="" S FHOR=$P(FHKDAT,U,7,11)
S DPAT=$O(^FH(111.1,"AB",FHOR,0))
K FP,MP,N2,NN
S PD=""
S:$G(MPD) PD=MPD
I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) D
.F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)) D
..S ZZ=$G(^FH(114.1,+Z1,0)),NAM=$P(ZZ,"^",1)
..S K4=$P(ZZ,"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
..S MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$P(Z1,"^",2) Q
Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD="" D CHK^FHMTK1B
;
I NBR=3 D PRT^FHMTK1C K MM,PP,S S NBR=0
S NBR=NBR+1 D PATNAME^FHOMUTL
;
F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 D
.S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1,$D(^TMP($J,"FHDEF",MEAL,+P1)) D
..S CHK="" F S CHK=$O(^TMP($J,"DEF",MEAL,PD,CHK)) Q:CHK="" S C1=$G(^(CHK)) I +CHK=+P1,$D(^TMP($J,"FHDEF",MEAL,+CHK,+C1)) D Q
...S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
...S P2=+P1,P3=$P(P1,"^",3) S:'$D(N2(P2,P3)) N2(P2,P3)=+$P(P1,"^",2)_"^"_P3 Q
..Q
S LP="" F S LP=$O(^TMP($J,"DEF",MEAL,PD,LP)) Q:LP="" I '$D(N2(+LP)) D
.S TST=$G(^TMP($J,"DEF",MEAL,PD,LP)),CHK="~"_$P(TST,"~",4,$L(TST,"~")) Q:'$F(CHK,"~"_SP_"~")
.I '$D(FP(+TST)) S N2(+LP,$P(LP,"~",2))=+TST_"^"_$P(LP,"~",2) Q
.Q:FLG
.F X6=0:0 S X6=$O(^FHPT(FHDFN,"P","B",X6)) Q:X6<1 F X7=0:0 S X7=$O(^FHPT(FHDFN,"P","B",X6,X7)) Q:X7<1 D
..S PS=$P($G(^FH(115.2,+X6,0)),"^",4) I +PS S P4=$G(^FH(114,+PS,0)),P1=$P(P4,"^",7)_"^"_+PS_"^"_$P(P4,"^",1) I +P1,+P1=+LP D
...S C2=$G(^FHPT(FHDFN,"P",+X7,0)) Q:$P(C2,"^",2)'[MEAL
...S P2=+P1,P3=$P(P1,"^",3) S:'$D(N2(P2,P3)) N2(P2,P3)=+$P(P1,"^",2)_"^"_P3 Q
..Q
;
S Y0=FHPTNM_" ("_FHBID_")"_" "_SVC,S(NBR)=0,N1=0,Y="***"
I '$G(FHDIET) S FHRNUM=FHKD D DIETPAT^FHOMRR1 S Y=$E(FHDIETP,1,18)
S:$G(FHDIET) Y=$P(^FH(111,FHDIET,0),U,7)
S N1=N1+1 I $L(Y)<40 S PP(N1,NBR)=Y
E S L=$S($L($P(Y,",",1,3))<40:3,1:2) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
S MM(0,NBR)=Y0_"^"_WRDN_"^"_RM_"^^^^"_FHMEAL
I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHMTK1B
;
S X8="" F S X8=$O(MP(MEAL,X8)) Q:X8="" S X1=+MP(MEAL,X8) D
.S Z1=+$P(X8,"~",2),QTY="" Q:'X1 S QTY=$S(+X1#1>0:$J(+X1,3,1),1:+X1_" ")_" "
.S Z1=+$P(X8,"~",2),QTY="" Q:'X1 S PAD=$E(" ",1,5-$L(X1)),QTY=+X1_PAD
.I $D(N2(Z1)) D Q
..S X7="" F S X7=$O(N2(Z1,X7)) Q:X7="" S C1=$P(X8,"~",1,2)_"~"_X7 I '$D(NN(C1)) S NN(C1)=QTY_X7
..Q
.S NN(X8)=QTY_$P(X8,"~",3)
.Q
S X8="" F S X8=$O(NN(X8)) Q:X8="" D
.S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=$G(NN(X8)) Q
I $G(FHKD) S ADM=FHKD D SOUT^FHMTK1B ;get outpatient standing orders.
S S(NBR)=S(NBR)+1,MM(S(NBR),NBR)=""
D DISL
Q
;
DISL ; Store patient dislikes
F LL=0:0 S LL=$O(^TMP($J,"X",MEAL,LL)) Q:LL<1 D DL1
Q
DL1 S X6=$O(^FHPT(FHDFN,"P","B",LL,0)) Q:X6<1
S X2=$G(^FHPT(FHDFN,"P",X6,0)) Q:$P(X2,"^",2)'[MEAL
S S(NBR)=S(NBR)+1
S MM(S(NBR),NBR)=" "_$E($P($G(^FH(115.2,+X2,0)),"^",1),1,25)
Q
FHDCR1D ; HISC/REL/NCA/RVD - Build Separate Meal Diet Card ;2/23/00 09:52
+1 ;;5.5;DIETETICS;**3,5**;Jan 28, 2005;Build 53
+2 ;RVD 8/10/05 added logic on Food Preferences for Bread/Beverages default for outpatient.
+3 ;patch #5 - added outpatient SO and fix diet pattern for outpatient.
BLD ; Build Diet Card list for a patient in three per page format
+1 SET X1=$GET(^FHPT(+FHDFN,"A",+ADM,0))
SET FHORD=$PIECE(X1,"^",2)
SET SVC=$PIECE(X1,"^",5)
SET SF=$PIECE(X1,"^",7)
SET IS=$PIECE(X1,"^",10)
SET FHD=$PIECE(X1,"^",16)
SET (FHOR,X)=""
+2 IF FHPAR'="Y"
IF SVC="C"
QUIT
+3 IF SVC="C"
IF SP'=SP1
SET SP=SP1
IF 'SP
QUIT
+4 IF 'FHORD
QUIT
SET X=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
+5 SET PD=$PIECE(X,"^",13)
SET FHOR=$PIECE(X,"^",2,6)
IF "^^^^"[FHOR
QUIT
+6 IF IS
SET IS=$GET(^FH(119.4,+IS,0))
IF IS'=""
SET SVC=SVC_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+7 IF SF
SET SVC=SVC_" "_"SF"_"("_$SELECT($PIECE($GET(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
+8 IF UPD
DO OLD^FHMTK11
IF OLD=FHOR
SET FLG2=0
DO EVT^FHDCR2
IF 'FLG2
QUIT
+9 SET STR=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
+10 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
+11 KILL FP,MP,N2,NN
IF $PIECE(STR,";",$SELECT(MEAL="B":1,MEAL="N":2,1:3))'=""
DO DECOD^FHDCR1B
+12 IF DPAT
SET PD=$PIECE($GET(^FH(111.1,DPAT,0)),"^",7)
Begin DoDot:1
+13 IF $PIECE(STR,";",$SELECT(MEAL="B":1,MEAL="N":2,1:3))=""
IF $ORDER(MP(MEAL,""))=""
FOR X8=0:0
SET X8=$ORDER(^FH(111.1,DPAT,MEAL,X8))
IF X8<1
QUIT
SET Z1=$GET(^(X8,0))
Begin DoDot:2
+14 SET ZZ=$GET(^FH(114.1,+Z1,0))
SET NAM=$PIECE(ZZ,"^",1)
+15 SET K4=$PIECE(ZZ,"^",3)
SET K4=$SELECT('K4:99,K4<10:"0"_K4,1:K4)
+16 SET MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$PIECE(Z1,"^",2)
QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF PD=""
QUIT
SET PD=$PIECE($GET(^FH(116.2,PD,0)),"^",2)
IF PD=""
QUIT
DO CHK^FHMTK1B
+19 IF NBR=3
DO PRT^FHMTK1C
KILL MM,PP,S
SET NBR=0
+20 SET NBR=NBR+1
DO PID^FHDPA
+21 FOR X6=0:0
SET X6=$ORDER(^FHPT(FHDFN,"P","B",X6))
IF X6<1
QUIT
FOR X7=0:0
SET X7=$ORDER(^FHPT(FHDFN,"P","B",X6,X7))
IF X7<1
QUIT
Begin DoDot:1
+22 SET PS=$PIECE($GET(^FH(115.2,+X6,0)),"^",4)
IF PS
SET P4=$GET(^FH(114,+PS,0))
SET P1=$PIECE(P4,"^",7)_"^"_+PS_"^"_$PIECE(P4,"^",1)
IF +P1
IF $DATA(^TMP($JOB,"FHDEF",MEAL,+P1))
Begin DoDot:2
+23 SET CHK=""
FOR
SET CHK=$ORDER(^TMP($JOB,"DEF",MEAL,PD,CHK))
IF CHK=""
QUIT
SET C1=$GET(^(CHK))
IF +CHK=+P1
IF $DATA(^TMP($JOB,"FHDEF",MEAL,+CHK,+C1))
Begin DoDot:3
+24 SET C2=$GET(^FHPT(FHDFN,"P",+X7,0))
IF $PIECE(C2,"^",2)'[MEAL
QUIT
+25 SET P2=+P1
SET P3=$PIECE(P1,"^",3)
IF '$DATA(N2(P2,P3))
SET N2(P2,P3)=+$PIECE(P1,"^",2)_"^"_P3
QUIT
End DoDot:3
QUIT
+26 QUIT
End DoDot:2
End DoDot:1
+27 SET LP=""
FOR
SET LP=$ORDER(^TMP($JOB,"DEF",MEAL,PD,LP))
IF LP=""
QUIT
IF '$DATA(N2(+LP))
Begin DoDot:1
+28 SET TST=$GET(^TMP($JOB,"DEF",MEAL,PD,LP))
SET CHK="~"_$PIECE(TST,"~",4,$LENGTH(TST,"~"))
IF '$FIND(CHK,"~"_SP_"~")
QUIT
+29 IF '$DATA(FP(+TST))
SET N2(+LP,$PIECE(LP,"~",2))=+TST_"^"_$PIECE(LP,"~",2)
QUIT
+30 IF FLG
QUIT
+31 FOR X6=0:0
SET X6=$ORDER(^FHPT(FHDFN,"P","B",X6))
IF X6<1
QUIT
FOR X7=0:0
SET X7=$ORDER(^FHPT(FHDFN,"P","B",X6,X7))
IF X7<1
QUIT
Begin DoDot:2
+32 SET PS=$PIECE($GET(^FH(115.2,+X6,0)),"^",4)
IF +PS
SET P4=$GET(^FH(114,+PS,0))
SET P1=$PIECE(P4,"^",7)_"^"_+PS_"^"_$PIECE(P4,"^",1)
IF +P1
IF +P1=+LP
Begin DoDot:3
+33 SET C2=$GET(^FHPT(FHDFN,"P",+X7,0))
IF $PIECE(C2,"^",2)'[MEAL
QUIT
+34 SET P2=+P1
SET P3=$PIECE(P1,"^",3)
IF '$DATA(N2(P2,P3))
SET N2(P2,P3)=+$PIECE(P1,"^",2)_"^"_P3
QUIT
End DoDot:3
+35 QUIT
End DoDot:2
End DoDot:1
+36 SET Y0=$PIECE($GET(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC
SET S(NBR)=0
SET N1=0
+37 DO CUR^FHORD7
SET N1=N1+1
IF $LENGTH(Y)<40
SET PP(N1,NBR)=Y
+38 IF '$TEST
SET L=$SELECT($LENGTH($PIECE(Y,",",1,3))<40:3,1:2)
SET PP(N1,NBR)=$PIECE(Y,",",1,L)
SET N1=N1+1
SET PP(N1,NBR)=$EXTRACT($PIECE(Y,",",L+1,5),2,99)
+39 SET MM(0,NBR)=Y0_"^"_WRDN_"^"_RM
+40 IF $GET(DFN)
DO ALG^FHCLN
SET ALG="ALLGS.: "_$SELECT(ALG="":"NONE ON FILE",1:ALG)
SET J=0
DO BRK^FHMTK1B
+41 SET X8=""
FOR
SET X8=$ORDER(MP(MEAL,X8))
IF X8=""
QUIT
SET X1=+MP(MEAL,X8)
Begin DoDot:1
+42 SET Z1=+$PIECE(X8,"~",2)
SET QTY=""
IF 'X1
QUIT
SET QTY=$SELECT(+X1#1>0:$JUSTIFY(+X1,3,1),1:+X1_" ")_" "
+43 SET Z1=+$PIECE(X8,"~",2)
SET QTY=""
IF 'X1
QUIT
SET PAD=$EXTRACT(" ",1,5-$LENGTH(X1))
SET QTY=+X1_PAD
+44 IF $DATA(N2(Z1))
Begin DoDot:2
+45 SET X7=""
FOR
SET X7=$ORDER(N2(Z1,X7))
IF X7=""
QUIT
SET C1=$PIECE(X8,"~",1,2)_"~"_X7
IF '$DATA(NN(C1))
SET NN(C1)=QTY_X7
+46 QUIT
End DoDot:2
QUIT
+47 SET NN(X8)=QTY_$PIECE(X8,"~",3)
+48 QUIT
End DoDot:1
+49 SET X8=""
FOR
SET X8=$ORDER(NN(X8))
IF X8=""
QUIT
Begin DoDot:1
+50 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=$GET(NN(X8))
QUIT
End DoDot:1
+51 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=""
+52 DO SO^FHMTK1B
+53 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=""
+54 DO DISL
+55 QUIT
+56 ;
OUT ;process outpatient data
+1 SET (SVC,SF,IS)=""
+2 IF '$DATA(FHKDAT)!'$GET(FHADM)
QUIT
+3 SET X1=FHKDAT
+4 SET FHWARD=W1
DO LOC^FHDCR11
+5 SET (FHOR,FHORD)=$PIECE(FHKDAT,U,2)
SET FHD=$PIECE(X1,"^",14)
+6 IF FHPAR'="Y"
IF SVC="C"
QUIT
+7 IF SVC="C"
IF SP'=SP1
SET SP=SP1
IF 'SP
QUIT
+8 IF $DATA(^FHPT(FHDFN,0))
SET IS=$PIECE(^FHPT(FHDFN,0),U,5)
+9 IF $DATA(^FHPT(FHDFN,"OP",FHADM,"SF",0))
SET SF=$PIECE(^(0),U,3)
+10 IF IS
SET IS=$GET(^FH(119.4,+IS,0))
IF IS'=""
SET SVC=SVC_"-"_$PIECE(IS,"^",2)_$PIECE(IS,"^",3)
+11 IF SF
IF $DATA(^FHPT(FHDFN,"OP",FHADM,"SF",SF,0))
IF '$PIECE(^(0),U,32)
SET SVC=SVC_" "_"SF"_"("_$SELECT($PIECE($GET(^FHPT(FHDFN,"OP",FHADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
+12 SET MEAL=FHMEAL
+13 IF UPD
DO OLD^FHMTK11
IF OLD=FHOR
SET FLG2=0
DO EVT^FHDCR2
IF 'FLG2
QUIT
+14 SET STR=""
+15 IF $GET(FHOR)
SET FHOR=FHOR_"^^^^"
+16 IF FHOR=""
SET FHOR=$PIECE(FHKDAT,U,7,11)
+17 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
+18 KILL FP,MP,N2,NN
+19 SET PD=""
+20 IF $GET(MPD)
SET PD=MPD
+21 IF DPAT
SET PD=$PIECE($GET(^FH(111.1,DPAT,0)),"^",7)
Begin DoDot:1
+22 FOR X8=0:0
SET X8=$ORDER(^FH(111.1,DPAT,MEAL,X8))
IF X8<1
QUIT
SET Z1=$GET(^(X8,0))
Begin DoDot:2
+23 SET ZZ=$GET(^FH(114.1,+Z1,0))
SET NAM=$PIECE(ZZ,"^",1)
+24 SET K4=$PIECE(ZZ,"^",3)
SET K4=$SELECT('K4:99,K4<10:"0"_K4,1:K4)
+25 SET MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$PIECE(Z1,"^",2)
QUIT
End DoDot:2
End DoDot:1
+26 IF PD=""
QUIT
SET PD=$PIECE($GET(^FH(116.2,PD,0)),"^",2)
IF PD=""
QUIT
DO CHK^FHMTK1B
+27 ;
+28 IF NBR=3
DO PRT^FHMTK1C
KILL MM,PP,S
SET NBR=0
+29 SET NBR=NBR+1
DO PATNAME^FHOMUTL
+30 ;
+31 FOR X6=0:0
SET X6=$ORDER(^FHPT(FHDFN,"P","B",X6))
IF X6<1
QUIT
FOR X7=0:0
SET X7=$ORDER(^FHPT(FHDFN,"P","B",X6,X7))
IF X7<1
QUIT
Begin DoDot:1
+32 SET PS=$PIECE($GET(^FH(115.2,+X6,0)),"^",4)
IF PS
SET P4=$GET(^FH(114,+PS,0))
SET P1=$PIECE(P4,"^",7)_"^"_+PS_"^"_$PIECE(P4,"^",1)
IF +P1
IF $DATA(^TMP($JOB,"FHDEF",MEAL,+P1))
Begin DoDot:2
+33 SET CHK=""
FOR
SET CHK=$ORDER(^TMP($JOB,"DEF",MEAL,PD,CHK))
IF CHK=""
QUIT
SET C1=$GET(^(CHK))
IF +CHK=+P1
IF $DATA(^TMP($JOB,"FHDEF",MEAL,+CHK,+C1))
Begin DoDot:3
+34 SET C2=$GET(^FHPT(FHDFN,"P",+X7,0))
IF $PIECE(C2,"^",2)'[MEAL
QUIT
+35 SET P2=+P1
SET P3=$PIECE(P1,"^",3)
IF '$DATA(N2(P2,P3))
SET N2(P2,P3)=+$PIECE(P1,"^",2)_"^"_P3
QUIT
End DoDot:3
QUIT
+36 QUIT
End DoDot:2
End DoDot:1
+37 SET LP=""
FOR
SET LP=$ORDER(^TMP($JOB,"DEF",MEAL,PD,LP))
IF LP=""
QUIT
IF '$DATA(N2(+LP))
Begin DoDot:1
+38 SET TST=$GET(^TMP($JOB,"DEF",MEAL,PD,LP))
SET CHK="~"_$PIECE(TST,"~",4,$LENGTH(TST,"~"))
IF '$FIND(CHK,"~"_SP_"~")
QUIT
+39 IF '$DATA(FP(+TST))
SET N2(+LP,$PIECE(LP,"~",2))=+TST_"^"_$PIECE(LP,"~",2)
QUIT
+40 IF FLG
QUIT
+41 FOR X6=0:0
SET X6=$ORDER(^FHPT(FHDFN,"P","B",X6))
IF X6<1
QUIT
FOR X7=0:0
SET X7=$ORDER(^FHPT(FHDFN,"P","B",X6,X7))
IF X7<1
QUIT
Begin DoDot:2
+42 SET PS=$PIECE($GET(^FH(115.2,+X6,0)),"^",4)
IF +PS
SET P4=$GET(^FH(114,+PS,0))
SET P1=$PIECE(P4,"^",7)_"^"_+PS_"^"_$PIECE(P4,"^",1)
IF +P1
IF +P1=+LP
Begin DoDot:3
+43 SET C2=$GET(^FHPT(FHDFN,"P",+X7,0))
IF $PIECE(C2,"^",2)'[MEAL
QUIT
+44 SET P2=+P1
SET P3=$PIECE(P1,"^",3)
IF '$DATA(N2(P2,P3))
SET N2(P2,P3)=+$PIECE(P1,"^",2)_"^"_P3
QUIT
End DoDot:3
+45 QUIT
End DoDot:2
End DoDot:1
+46 ;
+47 SET Y0=FHPTNM_" ("_FHBID_")"_" "_SVC
SET S(NBR)=0
SET N1=0
SET Y="***"
+48 IF '$GET(FHDIET)
SET FHRNUM=FHKD
DO DIETPAT^FHOMRR1
SET Y=$EXTRACT(FHDIETP,1,18)
+49 IF $GET(FHDIET)
SET Y=$PIECE(^FH(111,FHDIET,0),U,7)
+50 SET N1=N1+1
IF $LENGTH(Y)<40
SET PP(N1,NBR)=Y
+51 IF '$TEST
SET L=$SELECT($LENGTH($PIECE(Y,",",1,3))<40:3,1:2)
SET PP(N1,NBR)=$PIECE(Y,",",1,L)
SET N1=N1+1
SET PP(N1,NBR)=$EXTRACT($PIECE(Y,",",L+1,5),2,99)
+52 SET MM(0,NBR)=Y0_"^"_WRDN_"^"_RM_"^^^^"_FHMEAL
+53 IF $GET(DFN)
DO ALG^FHCLN
SET ALG="ALLGS.: "_$SELECT(ALG="":"NONE ON FILE",1:ALG)
SET J=0
DO BRK^FHMTK1B
+54 ;
+55 SET X8=""
FOR
SET X8=$ORDER(MP(MEAL,X8))
IF X8=""
QUIT
SET X1=+MP(MEAL,X8)
Begin DoDot:1
+56 SET Z1=+$PIECE(X8,"~",2)
SET QTY=""
IF 'X1
QUIT
SET QTY=$SELECT(+X1#1>0:$JUSTIFY(+X1,3,1),1:+X1_" ")_" "
+57 SET Z1=+$PIECE(X8,"~",2)
SET QTY=""
IF 'X1
QUIT
SET PAD=$EXTRACT(" ",1,5-$LENGTH(X1))
SET QTY=+X1_PAD
+58 IF $DATA(N2(Z1))
Begin DoDot:2
+59 SET X7=""
FOR
SET X7=$ORDER(N2(Z1,X7))
IF X7=""
QUIT
SET C1=$PIECE(X8,"~",1,2)_"~"_X7
IF '$DATA(NN(C1))
SET NN(C1)=QTY_X7
+60 QUIT
End DoDot:2
QUIT
+61 SET NN(X8)=QTY_$PIECE(X8,"~",3)
+62 QUIT
End DoDot:1
+63 SET X8=""
FOR
SET X8=$ORDER(NN(X8))
IF X8=""
QUIT
Begin DoDot:1
+64 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=$GET(NN(X8))
QUIT
End DoDot:1
+65 ;get outpatient standing orders.
IF $GET(FHKD)
SET ADM=FHKD
DO SOUT^FHMTK1B
+66 SET S(NBR)=S(NBR)+1
SET MM(S(NBR),NBR)=""
+67 DO DISL
+68 QUIT
+69 ;
DISL ; Store patient dislikes
+1 FOR LL=0:0
SET LL=$ORDER(^TMP($JOB,"X",MEAL,LL))
IF LL<1
QUIT
DO DL1
+2 QUIT
DL1 SET X6=$ORDER(^FHPT(FHDFN,"P","B",LL,0))
IF X6<1
QUIT
+1 SET X2=$GET(^FHPT(FHDFN,"P",X6,0))
IF $PIECE(X2,"^",2)'[MEAL
QUIT
+2 SET S(NBR)=S(NBR)+1
+3 SET MM(S(NBR),NBR)=" "_$EXTRACT($PIECE($GET(^FH(115.2,+X2,0)),"^",1),1,25)
+4 QUIT
