- 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 Feb 18, 2025@23:20:48 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