FHPRF1 ; HISC/REL/RVD - Calculate Total Forecast ;1/23/98 16:10
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;
;patch #5 - added screen for cancelled quest meals.
;
S %DT="X",X="T" D ^%DT S DT=+Y
D DIV^FHOMUTL G:'$D(FHSITE) KIL
D1 R !!,"Forecast Date: ",X:DTIME G:'$T!("^"[X) KIL S %DT="EX" D ^%DT G KIL:"^"[X,D1:Y<1 S D1=+Y
S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G R1
R0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
R1 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHPRF1",FHLST="D1^FHP^FHSITE^FHSITENM" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Process Census Forecast
D Q2,Q3
;get outpatient data
S FHD1SAV=D1
S:'$G(FHSITE) FHSITE=""
S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
D GETSM^FHOMRBLD(D1,FHSITE,"","")
D GETGM^FHOMRBL1(D1,FHSITE,"","")
S D1=D1-.000001
D GETRM^FHOMRBLD(D1,FHSITE,"","")
D PROSG ;process recurring, special and guest meal from "OP" node
S D1=FHD1SAV
G ^FHPRF1A
Q2 ; Calculate Service Point census forecast
S X="T",%DT="X" D ^%DT S DT=+Y
K ^TMP($J) S X=D1 D DOW^%DTC S DOW=Y+1 D BLD,DAT
F W1=0:0 S W1=$O(^TMP($J,"W",W1)) Q:W1<1 D WRD S ^TMP($J,"W",W1)=S1
K D,DC S X1=DT,X2=-1 D C^%DTC S D2=X
F P0=0:0 S P0=$O(^TMP($J,"S",P0)) Q:P0<1 D ADD S ^TMP($J,P0)=S1
Q
Q3 F P0=0:0 S P0=$O(^TMP($J,P0)) Q:P0<1 S S1=^(P0) D PER S ^TMP($J,P0)=S0
F K=0:0 S K=$O(D(K)) Q:K<1 S ^TMP($J,0,K)=D(K)
K D,^TMP($J,"W"),^TMP($J,"S") Q
WRD S (A,B,CT,S1,S2,S3,S4)=0 F K=1:1:9 S Y=$P($G(^DG(41.9,W1,"C",D(K),0)),"^",2) I Y S CT=CT+1,S0=10-K,S1=S1+S0,S2=S0*S0+S2,S3=S3+Y,S4=S0*Y+S4
G:'CT W1 I CT=1 S S1=S3 G W1
S S0=S1*S1/CT-S2,A=S1*S3/CT-S4/S0,B=S3/CT-(A*S1/CT)
S A=$J(A,0,3),B=$J(B,0,2),S1=10*A+B
W1 S (N1,C2,C3)=0 F K=1:1:7 S Y0=$P($G(^DG(41.9,W1,"C",DC(K),0)),"^",2) I Y0 S N1=N1+1,C2=Y0-S1*(4-N1)+C2,C3=4-N1+C3 Q:N1=3
I N1 S C2=C2/C3,S1=S1+C2
S S1=$J(S1,0,0) Q
ADD S (S1,CT)=0 F W1=0:0 S W1=$O(^TMP($J,"S",P0,W1)) Q:W1<1 S Z=^(W1),T0=$G(^TMP($J,"W",W1)),CT=CT+T0,S1=Z*T0/100+S1
S S1=$J(S1,0,0)
I '$D(^FH(119.72,P0,"C",D1,0)) S ^(0)=D1 I '$D(^FH(119.72,P0,"C",0)) S ^(0)="^119.722DA^^"
I D1'<DT S C2=$P(^FH(119.72,P0,"C",D1,0),"^",3),$P(^(0),"^",2,5)=CT_"^"_C2_"^"_S1_"^"_DT
Q:'$D(^FH(119.72,P0,"C",DT,0)) S C2=0
F W1=0:0 S W1=$O(^TMP($J,"S",P0,W1)) Q:W1<1 S C2=C2+$P($G(^DG(41.9,W1,"C",D2,0)),"^",2)
S:C2 $P(^FH(119.72,P0,"C",DT,0),"^",3)=C2 Q
PER S S0=0 F K=0:0 S K=$O(^FH(119.72,P0,"A",K)) Q:K<1 S Z=$P($G(^(K,0)),"^",DOW+1),Z=$J(Z*S1/100,0,0) I Z S ^TMP($J,P0,K)=Z,S0=S0+Z,D(K)=$G(D(K))+Z
Q
DAT ; Build list of dates
K D,DC S X1=D1,X2=-1 D C^%DTC S D2=X
F K=1:1:9 S X1=D2,X2=-7 D C^%DTC S D(K)=X,D2=X
S D2=D1 F K=1:1:7 S X1=D2,X2=-1 D C^%DTC S DC(K)=X,D2=X
Q
BLD ; Build list of MAS wards and %'s for each Service Point
K ^TMP($J,"S"),^TMP($J,"W")
F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1 S X=$G(^(P0,0)) I $P(X,"^",3)=FHP,$G(^FH(119.72,P0,"I"))'="Y" S ^TMP($J,"S",P0)=""
;F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1
F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1:($P(X,U,8)=FHSITE!(FHSITE=0))
Q
B1 S Z=$P(X,"^",5) I Z,$D(^TMP($J,"S",Z)) S Z1=$P(X,"^",17) S:$P(X,"^",7) Z1=Z1+$P(X,"^",19) S:'Z1 Z1=100 D B2
S Z=$P(X,"^",6) I Z,$D(^TMP($J,"S",Z)) S Z1=$P(X,"^",18) S:Z1="" Z1=100 D B2
Q
B2 F L2=0:0 S L2=$O(^FH(119.6,K1,"W",L2)) Q:L2<1 S ZW=+$G(^(L2,0)) I ZW S ^TMP($J,"W",ZW)="",^TMP($J,"S",Z,ZW)=Z1
Q
;
PROSG ;process outpatient data from ^tmp($j global
S FHPLNM=""
S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
RECUR ;recurring meals
S FHDT=D1+.999999
S FHTMPS="^TMP($J,""OP"",""R"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
..Q:$P(FHIJKDAT,U,19)="C" ;quit if status is cancelled.
..S FHDIET=$P(FHIJKDAT,U,3),FHDIET=$O(^FH(111,"B",FHDIET,0))
..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
..I $D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
..I '$D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=1
..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
;
SPEC ;special meals
S FHTMPS="^TMP($J,""OP"",""S"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
..S FHDIET=$P(FHIJKDAT,U,4),FHDIET=$O(^FH(111,"B",FHDIET,0))
..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
..I $D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
..I '$D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=1
..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
;
GUEST ;guest meals
S FHTMPS="^TMP($J,""OP"",""G"")"
S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
.I (FHPLNM'=""),(FHN'=FHPLNM) Q
.F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
..Q:$P(FHIJKDAT,U,7)="C"
..S FHDIET=$P($G(^FH(119.9,1,0)),U,2) ;default diet from 119.9
..S FHDIETN=$P(FHIJKDAT,U,6) ;diet from guest meal
..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
..I $G(FHDIETN),($D(^FH(111,FHDIETN,0))) D
...S FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
..I $D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
..I '$D(^TMP($J,FHSER,FHPDIET)) D
...S ^TMP($J,FHSER,FHPDIET)=1
..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
Q
;
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRF1 7469 printed Apr 09, 2024@21:00:44 Page 2
FHPRF1 ; HISC/REL/RVD - Calculate Total Forecast ;1/23/98 16:10
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;
+3 ;patch #5 - added screen for cancelled quest meals.
+4 ;
+5 SET %DT="X"
SET X="T"
DO ^%DT
SET DT=+Y
+6 DO DIV^FHOMUTL
if '$DATA(FHSITE)
GOTO KIL
D1 READ !!,"Forecast Date: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
SET %DT="EX"
DO ^%DT
if "^"[X
GOTO KIL
if Y<1
GOTO D1
SET D1=+Y
+1 SET FHP=$ORDER(^FH(119.71,0))
IF FHP'<1
IF $ORDER(^FH(119.71,FHP))<1
GOTO R1
R0 READ !!,"Select PRODUCTION FACILITY: ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
+1 KILL DIC
SET DIC="^FH(119.71,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO R0
SET FHP=+Y
R1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+1 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHPRF1"
SET FHLST="D1^FHP^FHSITE^FHSITENM"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Process Census Forecast
+1 DO Q2
DO Q3
+2 ;get outpatient data
+3 SET FHD1SAV=D1
+4 if '$GET(FHSITE)
SET FHSITE=""
+5 if '$DATA(FHSITENM)
SET FHSITENM="CONSOLIDATED"
+6 DO GETSM^FHOMRBLD(D1,FHSITE,"","")
+7 DO GETGM^FHOMRBL1(D1,FHSITE,"","")
+8 SET D1=D1-.000001
+9 DO GETRM^FHOMRBLD(D1,FHSITE,"","")
+10 ;process recurring, special and guest meal from "OP" node
DO PROSG
+11 SET D1=FHD1SAV
+12 GOTO ^FHPRF1A
Q2 ; Calculate Service Point census forecast
+1 SET X="T"
SET %DT="X"
DO ^%DT
SET DT=+Y
+2 KILL ^TMP($JOB)
SET X=D1
DO DOW^%DTC
SET DOW=Y+1
DO BLD
DO DAT
+3 FOR W1=0:0
SET W1=$ORDER(^TMP($JOB,"W",W1))
if W1<1
QUIT
DO WRD
SET ^TMP($JOB,"W",W1)=S1
+4 KILL D,DC
SET X1=DT
SET X2=-1
DO C^%DTC
SET D2=X
+5 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,"S",P0))
if P0<1
QUIT
DO ADD
SET ^TMP($JOB,P0)=S1
+6 QUIT
Q3 FOR P0=0:0
SET P0=$ORDER(^TMP($JOB,P0))
if P0<1
QUIT
SET S1=^(P0)
DO PER
SET ^TMP($JOB,P0)=S0
+1 FOR K=0:0
SET K=$ORDER(D(K))
if K<1
QUIT
SET ^TMP($JOB,0,K)=D(K)
+2 KILL D,^TMP($JOB,"W"),^TMP($JOB,"S")
QUIT
WRD SET (A,B,CT,S1,S2,S3,S4)=0
FOR K=1:1:9
SET Y=$PIECE($GET(^DG(41.9,W1,"C",D(K),0)),"^",2)
IF Y
SET CT=CT+1
SET S0=10-K
SET S1=S1+S0
SET S2=S0*S0+S2
SET S3=S3+Y
SET S4=S0*Y+S4
+1 if 'CT
GOTO W1
IF CT=1
SET S1=S3
GOTO W1
+2 SET S0=S1*S1/CT-S2
SET A=S1*S3/CT-S4/S0
SET B=S3/CT-(A*S1/CT)
+3 SET A=$JUSTIFY(A,0,3)
SET B=$JUSTIFY(B,0,2)
SET S1=10*A+B
W1 SET (N1,C2,C3)=0
FOR K=1:1:7
SET Y0=$PIECE($GET(^DG(41.9,W1,"C",DC(K),0)),"^",2)
IF Y0
SET N1=N1+1
SET C2=Y0-S1*(4-N1)+C2
SET C3=4-N1+C3
if N1=3
QUIT
+1 IF N1
SET C2=C2/C3
SET S1=S1+C2
+2 SET S1=$JUSTIFY(S1,0,0)
QUIT
ADD SET (S1,CT)=0
FOR W1=0:0
SET W1=$ORDER(^TMP($JOB,"S",P0,W1))
if W1<1
QUIT
SET Z=^(W1)
SET T0=$GET(^TMP($JOB,"W",W1))
SET CT=CT+T0
SET S1=Z*T0/100+S1
+1 SET S1=$JUSTIFY(S1,0,0)
+2 IF '$DATA(^FH(119.72,P0,"C",D1,0))
SET ^(0)=D1
IF '$DATA(^FH(119.72,P0,"C",0))
SET ^(0)="^119.722DA^^"
+3 IF D1'<DT
SET C2=$PIECE(^FH(119.72,P0,"C",D1,0),"^",3)
SET $PIECE(^(0),"^",2,5)=CT_"^"_C2_"^"_S1_"^"_DT
+4 if '$DATA(^FH(119.72,P0,"C",DT,0))
QUIT
SET C2=0
+5 FOR W1=0:0
SET W1=$ORDER(^TMP($JOB,"S",P0,W1))
if W1<1
QUIT
SET C2=C2+$PIECE($GET(^DG(41.9,W1,"C",D2,0)),"^",2)
+6 if C2
SET $PIECE(^FH(119.72,P0,"C",DT,0),"^",3)=C2
QUIT
PER SET S0=0
FOR K=0:0
SET K=$ORDER(^FH(119.72,P0,"A",K))
if K<1
QUIT
SET Z=$PIECE($GET(^(K,0)),"^",DOW+1)
SET Z=$JUSTIFY(Z*S1/100,0,0)
IF Z
SET ^TMP($JOB,P0,K)=Z
SET S0=S0+Z
SET D(K)=$GET(D(K))+Z
+1 QUIT
DAT ; Build list of dates
+1 KILL D,DC
SET X1=D1
SET X2=-1
DO C^%DTC
SET D2=X
+2 FOR K=1:1:9
SET X1=D2
SET X2=-7
DO C^%DTC
SET D(K)=X
SET D2=X
+3 SET D2=D1
FOR K=1:1:7
SET X1=D2
SET X2=-1
DO C^%DTC
SET DC(K)=X
SET D2=X
+4 QUIT
BLD ; Build list of MAS wards and %'s for each Service Point
+1 KILL ^TMP($JOB,"S"),^TMP($JOB,"W")
+2 FOR P0=0:0
SET P0=$ORDER(^FH(119.72,P0))
if P0<1
QUIT
SET X=$GET(^(P0,0))
IF $PIECE(X,"^",3)=FHP
IF $GET(^FH(119.72,P0,"I"))'="Y"
SET ^TMP($JOB,"S",P0)=""
+3 ;F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1
+4 FOR K1=0:0
SET K1=$ORDER(^FH(119.6,K1))
if K1<1
QUIT
SET X=$GET(^(K1,0))
if ($PIECE(X,U,8)=FHSITE!(FHSITE=0))
DO B1
+5 QUIT
B1 SET Z=$PIECE(X,"^",5)
IF Z
IF $DATA(^TMP($JOB,"S",Z))
SET Z1=$PIECE(X,"^",17)
if $PIECE(X,"^",7)
SET Z1=Z1+$PIECE(X,"^",19)
if 'Z1
SET Z1=100
DO B2
+1 SET Z=$PIECE(X,"^",6)
IF Z
IF $DATA(^TMP($JOB,"S",Z))
SET Z1=$PIECE(X,"^",18)
if Z1=""
SET Z1=100
DO B2
+2 QUIT
B2 FOR L2=0:0
SET L2=$ORDER(^FH(119.6,K1,"W",L2))
if L2<1
QUIT
SET ZW=+$GET(^(L2,0))
IF ZW
SET ^TMP($JOB,"W",ZW)=""
SET ^TMP($JOB,"S",Z,ZW)=Z1
+1 QUIT
+2 ;
PROSG ;process outpatient data from ^tmp($j global
+1 SET FHPLNM=""
+2 if $GET(FHSITE)
SET FHPLNM=$PIECE($GET(^FH(119.73,FHSITE,0)),U,1)
RECUR ;recurring meals
+1 SET FHDT=D1+.999999
+2 SET FHTMPS="^TMP($J,""OP"",""R"")"
+3 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+4 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+5 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+6 SET (FHPDIET,FHLOC,FHSER,FHDIET)="***"
+7 SET FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
+8 ;quit if status is cancelled.
if $PIECE(FHIJKDAT,U,19)="C"
QUIT
+9 SET FHDIET=$PIECE(FHIJKDAT,U,3)
SET FHDIET=$ORDER(^FH(111,"B",FHDIET,0))
+10 IF $GET(FHDIET)
IF $DATA(^FH(111,FHDIET,0))
SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
+11 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+12 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+13 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+14 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+15 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+16 if $DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=^TMP($JOB,FHSER)+1
+17 if '$DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=1
+18 IF $DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+19 SET ^TMP($JOB,FHSER,FHPDIET)=^TMP($JOB,FHSER,FHPDIET)+1
End DoDot:3
+20 IF '$DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+21 SET ^TMP($JOB,FHSER,FHPDIET)=1
End DoDot:3
+22 IF $DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=^TMP($JOB,0,FHPDIET)+1
+23 IF '$DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=1
End DoDot:2
End DoDot:1
+24 ;
SPEC ;special meals
+1 SET FHTMPS="^TMP($J,""OP"",""S"")"
+2 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+3 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+4 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+5 SET (FHPDIET,FHLOC,FHSER,FHDIET)="***"
+6 SET FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
+7 SET FHDIET=$PIECE(FHIJKDAT,U,4)
SET FHDIET=$ORDER(^FH(111,"B",FHDIET,0))
+8 if $DATA(^FH(111,FHDIET,0))
SET FHPDIET=$PIECE(^FH(111,FHDIET,0),U,5)
+9 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+10 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+11 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+12 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+13 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+14 if $DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=^TMP($JOB,FHSER)+1
+15 if '$DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=1
+16 IF $DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+17 SET ^TMP($JOB,FHSER,FHPDIET)=^TMP($JOB,FHSER,FHPDIET)+1
End DoDot:3
+18 IF '$DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+19 SET ^TMP($JOB,FHSER,FHPDIET)=1
End DoDot:3
+20 IF $DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=^TMP($JOB,0,FHPDIET)+1
+21 IF '$DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=1
End DoDot:2
End DoDot:1
+22 ;
GUEST ;guest meals
+1 SET FHTMPS="^TMP($J,""OP"",""G"")"
+2 SET FHN=""
FOR
SET FHN=$ORDER(@FHTMPS@(FHN))
if FHN=""
QUIT
SET FHI=""
FOR
SET FHI=$ORDER(@FHTMPS@(FHN,FHI))
if FHI=""
QUIT
SET FHJ=""
FOR
SET FHJ=$ORDER(@FHTMPS@(FHN,FHI,FHJ))
if FHJ=""
QUIT
Begin DoDot:1
+3 IF (FHPLNM'="")
IF (FHN'=FHPLNM)
QUIT
+4 FOR FHK=0:0
SET FHK=$ORDER(@FHTMPS@(FHN,FHI,FHJ,FHK))
if (FHK'>0)!(FHK>FHDT)
QUIT
Begin DoDot:2
+5 SET (FHPDIET,FHLOC,FHSER,FHDIET)="***"
+6 SET FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
+7 if $PIECE(FHIJKDAT,U,7)="C"
QUIT
+8 ;default diet from 119.9
SET FHDIET=$PIECE($GET(^FH(119.9,1,0)),U,2)
+9 ;diet from guest meal
SET FHDIETN=$PIECE(FHIJKDAT,U,6)
+10 if $DATA(^FH(119.6,"B",FHI))
SET FHLOC=$ORDER(^FH(119.6,"B",FHI,0))
+11 if $GET(FHLOC)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,5)
+12 if '$GET(FHSER)
SET FHSER=$PIECE($GET(^FH(119.6,FHLOC,0)),U,6)
+13 if '$GET(FHSER)
SET FHSER=$ORDER(^FH(119.72,0))
+14 IF $DATA(^FH(119.72,FHSER,0))
IF $PIECE(^FH(119.72,FHSER,0),U,3)'=FHP
QUIT
+15 if $DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=^TMP($JOB,FHSER)+1
+16 if '$DATA(^TMP($JOB,FHSER))
SET ^TMP($JOB,FHSER)=1
+17 IF $GET(FHDIETN)
IF ($DATA(^FH(111,FHDIETN,0)))
Begin DoDot:3
+18 SET FHPDIET=$PIECE(^FH(111,FHDIETN,0),U,5)
End DoDot:3
+19 IF $DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+20 SET ^TMP($JOB,FHSER,FHPDIET)=^TMP($JOB,FHSER,FHPDIET)+1
End DoDot:3
+21 IF '$DATA(^TMP($JOB,FHSER,FHPDIET))
Begin DoDot:3
+22 SET ^TMP($JOB,FHSER,FHPDIET)=1
End DoDot:3
+23 IF $DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=^TMP($JOB,0,FHPDIET)+1
+24 IF '$DATA(^TMP($JOB,0,FHPDIET))
SET ^TMP($JOB,0,FHPDIET)=1
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
