Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHPRF1

FHPRF1.m

Go to the documentation of this file.
  1. FHPRF1 ; HISC/REL/RVD - Calculate Total Forecast ;1/23/98 16:10
  1. ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
  1. ;
  1. ;patch #5 - added screen for cancelled quest meals.
  1. ;
  1. S %DT="X",X="T" D ^%DT S DT=+Y
  1. D DIV^FHOMUTL G:'$D(FHSITE) KIL
  1. D1 R !!,"Forecast Date: ",X:DTIME G:'$T!("^"[X) KIL S %DT="EX" D ^%DT G KIL:"^"[X,D1:Y<1 S D1=+Y
  1. S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G R1
  1. R0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
  1. K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
  1. R1 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
  1. I $D(IO("Q")) S FHPGM="Q1^FHPRF1",FHLST="D1^FHP^FHSITE^FHSITENM" D EN2^FH G KIL
  1. U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
  1. Q1 ; Process Census Forecast
  1. D Q2,Q3
  1. ;get outpatient data
  1. S FHD1SAV=D1
  1. S:'$G(FHSITE) FHSITE=""
  1. S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
  1. D GETSM^FHOMRBLD(D1,FHSITE,"","")
  1. D GETGM^FHOMRBL1(D1,FHSITE,"","")
  1. S D1=D1-.000001
  1. D GETRM^FHOMRBLD(D1,FHSITE,"","")
  1. D PROSG ;process recurring, special and guest meal from "OP" node
  1. S D1=FHD1SAV
  1. G ^FHPRF1A
  1. Q2 ; Calculate Service Point census forecast
  1. S X="T",%DT="X" D ^%DT S DT=+Y
  1. K ^TMP($J) S X=D1 D DOW^%DTC S DOW=Y+1 D BLD,DAT
  1. F W1=0:0 S W1=$O(^TMP($J,"W",W1)) Q:W1<1 D WRD S ^TMP($J,"W",W1)=S1
  1. K D,DC S X1=DT,X2=-1 D C^%DTC S D2=X
  1. F P0=0:0 S P0=$O(^TMP($J,"S",P0)) Q:P0<1 D ADD S ^TMP($J,P0)=S1
  1. Q
  1. Q3 F P0=0:0 S P0=$O(^TMP($J,P0)) Q:P0<1 S S1=^(P0) D PER S ^TMP($J,P0)=S0
  1. F K=0:0 S K=$O(D(K)) Q:K<1 S ^TMP($J,0,K)=D(K)
  1. K D,^TMP($J,"W"),^TMP($J,"S") Q
  1. 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
  1. G:'CT W1 I CT=1 S S1=S3 G W1
  1. S S0=S1*S1/CT-S2,A=S1*S3/CT-S4/S0,B=S3/CT-(A*S1/CT)
  1. S A=$J(A,0,3),B=$J(B,0,2),S1=10*A+B
  1. 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
  1. I N1 S C2=C2/C3,S1=S1+C2
  1. S S1=$J(S1,0,0) Q
  1. 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
  1. S S1=$J(S1,0,0)
  1. I '$D(^FH(119.72,P0,"C",D1,0)) S ^(0)=D1 I '$D(^FH(119.72,P0,"C",0)) S ^(0)="^119.722DA^^"
  1. I D1'<DT S C2=$P(^FH(119.72,P0,"C",D1,0),"^",3),$P(^(0),"^",2,5)=CT_"^"_C2_"^"_S1_"^"_DT
  1. Q:'$D(^FH(119.72,P0,"C",DT,0)) S C2=0
  1. 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)
  1. S:C2 $P(^FH(119.72,P0,"C",DT,0),"^",3)=C2 Q
  1. 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
  1. Q
  1. DAT ; Build list of dates
  1. K D,DC S X1=D1,X2=-1 D C^%DTC S D2=X
  1. F K=1:1:9 S X1=D2,X2=-7 D C^%DTC S D(K)=X,D2=X
  1. S D2=D1 F K=1:1:7 S X1=D2,X2=-1 D C^%DTC S DC(K)=X,D2=X
  1. Q
  1. BLD ; Build list of MAS wards and %'s for each Service Point
  1. K ^TMP($J,"S"),^TMP($J,"W")
  1. 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)=""
  1. ;F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1
  1. 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))
  1. Q
  1. 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
  1. S Z=$P(X,"^",6) I Z,$D(^TMP($J,"S",Z)) S Z1=$P(X,"^",18) S:Z1="" Z1=100 D B2
  1. Q
  1. 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
  1. Q
  1. ;
  1. PROSG ;process outpatient data from ^tmp($j global
  1. S FHPLNM=""
  1. S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
  1. RECUR ;recurring meals
  1. S FHDT=D1+.999999
  1. S FHTMPS="^TMP($J,""OP"",""R"")"
  1. 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
  1. .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1. .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
  1. ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
  1. ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1. ..Q:$P(FHIJKDAT,U,19)="C" ;quit if status is cancelled.
  1. ..S FHDIET=$P(FHIJKDAT,U,3),FHDIET=$O(^FH(111,"B",FHDIET,0))
  1. ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
  1. ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1. ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
  1. ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
  1. ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
  1. ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
  1. ..I $D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
  1. ..I '$D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=1
  1. ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
  1. ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
  1. ;
  1. SPEC ;special meals
  1. S FHTMPS="^TMP($J,""OP"",""S"")"
  1. 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
  1. .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1. .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
  1. ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
  1. ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1. ..S FHDIET=$P(FHIJKDAT,U,4),FHDIET=$O(^FH(111,"B",FHDIET,0))
  1. ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
  1. ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1. ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
  1. ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
  1. ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
  1. ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
  1. ..I $D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
  1. ..I '$D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=1
  1. ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
  1. ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
  1. ;
  1. GUEST ;guest meals
  1. S FHTMPS="^TMP($J,""OP"",""G"")"
  1. 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
  1. .I (FHPLNM'=""),(FHN'=FHPLNM) Q
  1. .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
  1. ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
  1. ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
  1. ..Q:$P(FHIJKDAT,U,7)="C"
  1. ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2) ;default diet from 119.9
  1. ..S FHDIETN=$P(FHIJKDAT,U,6) ;diet from guest meal
  1. ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
  1. ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
  1. ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
  1. ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
  1. ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
  1. ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
  1. ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
  1. ..I $G(FHDIETN),($D(^FH(111,FHDIETN,0))) D
  1. ...S FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
  1. ..I $D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
  1. ..I '$D(^TMP($J,FHSER,FHPDIET)) D
  1. ...S ^TMP($J,FHSER,FHPDIET)=1
  1. ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
  1. ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
  1. Q
  1. ;
  1. KIL K ^TMP($J) G KILL^XUSCLEAN