- FHPRO2 ; HISC/REL/NCA/RVD - Forecast/Census Calculations ;1/23/98 16:10
- ;;5.5;DIETETICS;**3**;Jan 28, 2005
- ;RVD 5/17/05 - as part of AFP project.
- ;if date is range, save all the value of DOW for every day in fhdodt.
- S FHD1SAV=D1
- F FHDTI=1:1 S X1=FHD1SAV,X2=FHDTI-1 D C^%DTC Q:FHDTI'>0!(X>FHDT2) D
- .D DOW^%DTC S FHDODT(FHDTI)=Y+1,FHDODAY(FHDTI)=X
- S X=D1 D DOW^%DTC S (FHDOWSV,DOW)=Y+1
- S DTP=D1\1 D DTP^FH S FHDSTART=DTP,DTP=FHDT2\1 D DTP^FH S FHDTSTOP=DTP
- S FHSTARTD=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
- S X=FHDT2 D DOW^%DTC S DOW=Y+1
- S FHSTOPDT=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
- S DOW=FHDOWSV
- S X1=FHDT2,X2=D1 D ^%DTC S FHNUMDAY=X+1 ;number of days fr start to end
- D NOW^%DTC S NOW=%,PG=0
- S FHMLSAV=MEAL
- D DATE^FHPRO4
- ;I (MEAL="B")!(MEAL="N")!(MEAL="E") D Q2 D:FHP8["Y" P3^FHPRO7 D AFP^FHPRO6 D:FHP9["Y" AAR^FHPRO7 Q
- F FHMEAL="B","N","E" S MEAL=FHMEAL D Q2
- D:FHP8["Y" P3^FHPRO7 D:FHP10["Y" AFP^FHPRO6 D:FHP9["Y" AAR^FHPRO7
- Q
- Q2 S K3=$F("BNE",MEAL)-1 ;FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
- Q:'$D(FHMEALAR(MEAL))
- D CEN:FHP6["C",FOR:FHP6["F",LIS
- G ^FHPRO3
- FOR ; Calculate for Forecast
- K ^TMP($J,"FH"),^TMP($J,"FHD") ;F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S ^TMP($J,"FH",P0)=M2(P0)
- K D F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S S1=M2(P0) D PER S ^TMP($J,"FH",P0)=S0
- F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 I $D(^FH(119.72,P0,"B")) D F1
- F LL=0:0 S LL=$O(D(LL)) Q:LL<1 S ^TMP($J,"FH",0,LL)=D(LL)
- K D Q
- F1 F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 D
- .F FHDDI=0:0 S FHDDI=$O(FHDODT(FHDDI)) Q:FHDDI'>0 D
- ..S FHDDIDO=FHDODT(FHDDI)
- ..S FHPX1=FHDODAY(FHDDI)
- ..Q:'$D(FHMEALAR(MEAL,FHPX1)) ;meal is not for certain date.
- ..S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*FHDDIDO-2+K3)
- ..I Y>0 S D(LL)=$G(D(LL))+Y,^TMP($J,"FH",P0)=^TMP($J,"FH",P0)+Y,^TMP($J,"FH",P0,LL)=$G(^TMP($J,"FH",P0,LL))+Y
- ..I Y>0 S:'$D(^TMP($J,"FHD",FHPX1,P0,LL)) ^TMP($J,"FHD",FHPX1,P0,LL)=0 S ^TMP($J,"FHD",FHPX1,P0,LL)=^TMP($J,"FHD",FHPX1,P0,LL)+Y
- Q
- PER S S0=0 F K=0:0 S K=$O(^FH(119.72,P0,"A",K)) Q:K<1 D
- .S ^TMP($J,"FH",P0,K)=0,D(K)=0
- .F FHDDI=0:0 S FHDDI=$O(FHDODT(FHDDI)) Q:FHDDI'>0 D
- ..S FHDDIDO=FHDODT(FHDDI)
- ..S FHPX1=FHDODAY(FHDDI)
- ..S Z=$P(^FH(119.72,P0,"A",K,0),"^",FHDDIDO+1)
- ..S FHS1=$P(S1,"^",FHDDI)
- ..S Z=$J(Z*FHS1/100,0,0)
- ..I Z S ^TMP($J,"FH",P0,K)=^TMP($J,"FH",P0,K)+Z,S0=S0+Z,D(K)=$G(D(K))+Z
- ..I Z S:'$D(^TMP($J,"FHD",FHPX1,P0,K)) ^TMP($J,"FHD",FHPX1,P0,K)=0 S ^TMP($J,"FHD",FHPX1,P0,K)=^TMP($J,"FHD",FHPX1,P0,K)+Z
- Q
- LIS ;print listing
- Q:'$D(FHMEALAR(MEAL))
- S (FHRETYP,FHW1NM,FHSITENM)=""
- I $G(FHSITE),$D(^FH(119.73,FHSITE,0)) S FHSITENM=$P(^FH(119.73,FHSITE,0),U,1)
- S:$G(FHSITE) FHRETYP="Comm Office: "_FHSITENM
- S:'$G(FHSITE) FHRETYP="Consolidated"
- I FHSTARTD'=FHSTOPDT D
- .S TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- .S TIMAFP=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP
- I FHSTARTD=FHSTOPDT D
- .S TIM=FHSTARTD_"DAY "_FHDSTART_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- .S TIMAFP=FHSTARTD_"DAY "_FHDSTART
- ;S:FHSTARTD'=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- ;S:FHSTARTD=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- S TIMAFP=TIMAFP_" ( "_FHMEALHE_" )"
- S DTP=NOW D DTP^FH
- K S,D,N S L1=38
- F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0="" S X=^FH(119.72,P0,0),N1=$P(X,"^",1),N2=$P(X,"^",2),N3=$P(X,"^",4) S:N3="" N3=$E(N1,1,6) S S(N3,P0)=$J(N3,8)_"^"_N2,L1=L1+14
- S:L1<80 L1=80
- S Z=$S(FHP6["F":"F O R E C A S T E D",1:"A C T U A L")_" D I E T C E N S U S"
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- S DTP=NOW D DTP^FH W !,DTP,?(L1-$L(Z)\2),Z,?(L1-7),"Page ",PG
- W !,FHRETYP
- S Z=$P(^FH(119.71,FHP,0),"^",1)
- W !?(L1-$L(Z)\2),Z,!!?(L1-$L(TIM)\2),TIM
- W !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!?29
- S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" W $P(S(X,K),"^",1)
- W " Total" S LN="",$P(LN,"-",L1+1)="" W !,LN,! K LN
- F P1=0:0 S P1=$O(^FH(116.2,"AP",P1)) Q:P1<1 F K=0:0 S K=$O(^FH(116.2,"AP",P1,K)) Q:K<1 I $D(^TMP($J,"FH",0,K)) D PRO
- I FHP6["C" W !?3,"N P O",?31 S K=.5 D P1 K NP(.5)
- I FHP6["C" W !?3,"P A S S",?31 S K=.8 D P1 K NP(.8)
- I FHP6["C" W !?3,"TF Only",?31 S K=.7 D P1 K NP(.7)
- I FHP6["C" W !?3,"No Order",?31 S K=.6 D P1 K NP(.6)
- W !!,"TOTAL MEALS",?31 S TOT=""
- S X="" F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" D
- .S Z=$G(^TMP($J,"FH",K1)) S:Z TOT=TOT+Z W $J(Z,6)," "
- W $J(TOT,7) Q
- W !!!,"*** Includes other gratuitous/paid meals.",! K S,D,N,P Q
- PRO W !,$P($G(^FH(116.2,K,0)),"^",1),?31
- P1 S (TOT,X)="" F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" D
- .S Z=$S(K>.9:$G(^TMP($J,"FH",K1,K)),1:$G(NP(K,K1)))
- .S:Z TOT=TOT+Z W $J(Z,6)," "
- W $J(TOT,7) Q
- CEN ; Calculate for Census
- K ^TMP($J,"FH"),^TMP($J,"FHD")
- S X=D1_"@"_$S(MEAL="B":"7AM",MEAL="N":"11AM",1:"4PM"),%DT="TX" D ^%DT S TIM=Y
- K D,P F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D
- .I $G(FHSITE),($P(X,U,8)'=FHSITE) Q
- .S FHSERFLG=0
- .S FHSER=$P(X,U,5) S:$G(FHSER) SP(FHSER)="" I $G(FHSER),$D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)=FHP S FHSERFLG=1
- .S FHSER=$P(X,U,6) S:$G(FHSER) SP(FHSER)="" I $G(FHSER),$D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)=FHP S FHSERFLG=1
- .Q:'$G(FHSERFLG)
- .I '$G(FHSITE) D WRD^FHORD9 Q
- .I $G(FHSITE),$P(X,U,8)=FHSITE D WRD^FHORD9
- S FHDTOT=0
- F FHIJ=0:0 S FHIJ=$O(FHMEALAR(MEAL,FHIJ)) Q:FHIJ'>0 D
- .S FHDTOT=FHDTOT+1
- .F FHI=0:0 S FHI=$O(P(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(P(FHI,FHJ)) Q:FHJ'>0 D
- ..Q:FHI<1
- ..S:'$D(^TMP($J,"FHD",FHIJ,FHJ,FHI)) ^TMP($J,"FHD",FHIJ,FHJ,FHI)=0
- ..S ^TMP($J,"FHD",FHIJ,FHJ,FHI)=^TMP($J,"FHD",FHIJ,FHJ,FHI)+P(FHI,FHJ)
- ;
- F FHI=0:0 S FHI=$O(P(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(P(FHI,FHJ)) Q:FHJ'>0 D
- .I P(FHI,FHJ)>0 S P(FHI,FHJ)=P(FHI,FHJ)*FHDTOT
- ;go proccess outpatient data
- D OUT^FHPRO3
- ;
- COMB ;
- K D,NP,T F LP=0:0 S LP=$O(P(.5,LP)) Q:LP<1 S:'$D(NP(.5,LP)) NP(.5,LP)=0 S NP(.5,LP)=NP(.5,LP)+P(.5,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.5,LP)
- K P(.5) F LP=0:0 S LP=$O(P(.7,LP)) Q:LP<1 S:'$D(NP(.7,LP)) NP(.7,LP)=0 S NP(.7,LP)=NP(.7,LP)+P(.7,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.7,LP)
- K P(.7) F LL=0:0 S LL=$O(P(.6,LL)) Q:LL<1 S:'$D(NP(.6,LL)) NP(.6,LL)=0 S NP(.6,LL)=NP(.6,LL)+P(.6,LL)
- K P(.6) F LL=0:0 S LL=$O(P(.8,LL)) Q:LL<1 S:'$D(NP(.8,LL)) NP(.8,LL)=0 S NP(.8,LL)=NP(.8,LL)+P(.8,LL) S:'$D(D(LL)) D(LL)=0 S D(LL)=D(LL)+P(.8,LL)
- K P(.8) F LL=0:0 S LL=$O(P(LL)) Q:LL<1 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S:'$D(T(P0)) T(P0)=0 S T(P0)=T(P0)+P(LL,P0)
- F LP=0:0 S LP=$O(NP(.6,LP)) Q:LP<1 S:$D(T(LP)) NP(.6,LP)=NP(.6,LP)-T(LP)-$G(D(LP)) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+NP(.6,LP)
- F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1 I $P(^(P0,0),"^",3)=FHP I $D(^FH(119.72,P0,"B")) D D0
- K ^TMP($J,"FH") F LL=0:0 S LL=$O(P(LL)) Q:LL<1 S P(LL,0)=0 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S ^TMP($J,"FH",P0,LL)=P(LL,P0) S:'$D(D(P0)) D(P0)="" S D(P0)=D(P0)+P(LL,P0),P(LL,0)=P(LL,0)+P(LL,P0)
- F P0=0:0 S P0=$O(D(P0)) Q:P0<1 S ^TMP($J,"FH",P0)=D(P0)
- F LL=0:0 S LL=$O(P(LL)) Q:LL<1 I $G(P(LL,0)) S ^TMP($J,"FH",0,LL)=P(LL,0)
- K P,D Q
- D0 ;
- I '$D(SP(P0)) Q
- I $G(^FH(119.72,P0,"I"))="Y" Q
- ;get all the AO for all dates being asked.
- F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 F FHDOII=0:0 S FHDOII=$O(FHDODAY(FHDOII)) Q:FHDOII'>0 D
- .S (FHDOD1,X)=FHDODAY(FHDOII) D DOW^%DTC S DOW=Y+1
- .Q:'$D(FHMEALAR(MEAL,FHDOD1)) ;meal is not for certain date.
- .S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
- .I Y>0 S:'$D(^TMP($J,"FHD",FHDOD1,P0,LL)) ^TMP($J,"FHD",FHDOD1,P0,LL)=0 S ^TMP($J,"FHD",FHDOD1,P0,LL)=^TMP($J,"FHD",FHDOD1,P0,LL)+Y
- ;F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
- Q
- FHPRO2 ; HISC/REL/NCA/RVD - Forecast/Census Calculations ;1/23/98 16:10
- +1 ;;5.5;DIETETICS;**3**;Jan 28, 2005
- +2 ;RVD 5/17/05 - as part of AFP project.
- +3 ;if date is range, save all the value of DOW for every day in fhdodt.
- +4 SET FHD1SAV=D1
- +5 FOR FHDTI=1:1
- SET X1=FHD1SAV
- SET X2=FHDTI-1
- DO C^%DTC
- IF FHDTI'>0!(X>FHDT2)
- QUIT
- Begin DoDot:1
- +6 DO DOW^%DTC
- SET FHDODT(FHDTI)=Y+1
- SET FHDODAY(FHDTI)=X
- End DoDot:1
- +7 SET X=D1
- DO DOW^%DTC
- SET (FHDOWSV,DOW)=Y+1
- +8 SET DTP=D1\1
- DO DTP^FH
- SET FHDSTART=DTP
- SET DTP=FHDT2\1
- DO DTP^FH
- SET FHDTSTOP=DTP
- +9 SET FHSTARTD=$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
- +10 SET X=FHDT2
- DO DOW^%DTC
- SET DOW=Y+1
- +11 SET FHSTOPDT=$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
- +12 SET DOW=FHDOWSV
- +13 ;number of days fr start to end
- SET X1=FHDT2
- SET X2=D1
- DO ^%DTC
- SET FHNUMDAY=X+1
- +14 DO NOW^%DTC
- SET NOW=%
- SET PG=0
- +15 SET FHMLSAV=MEAL
- +16 DO DATE^FHPRO4
- +17 ;I (MEAL="B")!(MEAL="N")!(MEAL="E") D Q2 D:FHP8["Y" P3^FHPRO7 D AFP^FHPRO6 D:FHP9["Y" AAR^FHPRO7 Q
- +18 FOR FHMEAL="B","N","E"
- SET MEAL=FHMEAL
- DO Q2
- +19 IF FHP8["Y"
- DO P3^FHPRO7
- IF FHP10["Y"
- DO AFP^FHPRO6
- IF FHP9["Y"
- DO AAR^FHPRO7
- +20 QUIT
- Q2 ;FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
- SET K3=$FIND("BNE",MEAL)-1
- +1 IF '$DATA(FHMEALAR(MEAL))
- QUIT
- +2 IF FHP6["C"
- DO CEN
- IF FHP6["F"
- DO FOR
- DO LIS
- +3 GOTO ^FHPRO3
- FOR ; Calculate for Forecast
- +1 ;F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S ^TMP($J,"FH",P0)=M2(P0)
- KILL ^TMP($JOB,"FH"),^TMP($JOB,"FHD")
- +2 KILL D
- FOR P0=0:0
- SET P0=$ORDER(M2(P0))
- IF P0<1
- QUIT
- SET S1=M2(P0)
- DO PER
- SET ^TMP($JOB,"FH",P0)=S0
- +3 FOR P0=0:0
- SET P0=$ORDER(^TMP($JOB,"FH",P0))
- IF P0<1
- QUIT
- IF $DATA(^FH(119.72,P0,"B"))
- DO F1
- +4 FOR LL=0:0
- SET LL=$ORDER(D(LL))
- IF LL<1
- QUIT
- SET ^TMP($JOB,"FH",0,LL)=D(LL)
- +5 KILL D
- QUIT
- F1 FOR LL=0:0
- SET LL=$ORDER(^FH(119.72,P0,"B",LL))
- IF LL<1
- QUIT
- Begin DoDot:1
- +1 FOR FHDDI=0:0
- SET FHDDI=$ORDER(FHDODT(FHDDI))
- IF FHDDI'>0
- QUIT
- Begin DoDot:2
- +2 SET FHDDIDO=FHDODT(FHDDI)
- +3 SET FHPX1=FHDODAY(FHDDI)
- +4 ;meal is not for certain date.
- IF '$DATA(FHMEALAR(MEAL,FHPX1))
- QUIT
- +5 SET Y=$PIECE(^FH(119.72,P0,"B",LL,0),"^",3*FHDDIDO-2+K3)
- +6 IF Y>0
- SET D(LL)=$GET(D(LL))+Y
- SET ^TMP($JOB,"FH",P0)=^TMP($JOB,"FH",P0)+Y
- SET ^TMP($JOB,"FH",P0,LL)=$GET(^TMP($JOB,"FH",P0,LL))+Y
- +7 IF Y>0
- IF '$DATA(^TMP($JOB,"FHD",FHPX1,P0,LL))
- SET ^TMP($JOB,"FHD",FHPX1,P0,LL)=0
- SET ^TMP($JOB,"FHD",FHPX1,P0,LL)=^TMP($JOB,"FHD",FHPX1,P0,LL)+Y
- End DoDot:2
- End DoDot:1
- +8 QUIT
- PER SET S0=0
- FOR K=0:0
- SET K=$ORDER(^FH(119.72,P0,"A",K))
- IF K<1
- QUIT
- Begin DoDot:1
- +1 SET ^TMP($JOB,"FH",P0,K)=0
- SET D(K)=0
- +2 FOR FHDDI=0:0
- SET FHDDI=$ORDER(FHDODT(FHDDI))
- IF FHDDI'>0
- QUIT
- Begin DoDot:2
- +3 SET FHDDIDO=FHDODT(FHDDI)
- +4 SET FHPX1=FHDODAY(FHDDI)
- +5 SET Z=$PIECE(^FH(119.72,P0,"A",K,0),"^",FHDDIDO+1)
- +6 SET FHS1=$PIECE(S1,"^",FHDDI)
- +7 SET Z=$JUSTIFY(Z*FHS1/100,0,0)
- +8 IF Z
- SET ^TMP($JOB,"FH",P0,K)=^TMP($JOB,"FH",P0,K)+Z
- SET S0=S0+Z
- SET D(K)=$GET(D(K))+Z
- +9 IF Z
- IF '$DATA(^TMP($JOB,"FHD",FHPX1,P0,K))
- SET ^TMP($JOB,"FHD",FHPX1,P0,K)=0
- SET ^TMP($JOB,"FHD",FHPX1,P0,K)=^TMP($JOB,"FHD",FHPX1,P0,K)+Z
- End DoDot:2
- End DoDot:1
- +10 QUIT
- LIS ;print listing
- +1 IF '$DATA(FHMEALAR(MEAL))
- QUIT
- +2 SET (FHRETYP,FHW1NM,FHSITENM)=""
- +3 IF $GET(FHSITE)
- IF $DATA(^FH(119.73,FHSITE,0))
- SET FHSITENM=$PIECE(^FH(119.73,FHSITE,0),U,1)
- +4 IF $GET(FHSITE)
- SET FHRETYP="Comm Office: "_FHSITENM
- +5 IF '$GET(FHSITE)
- SET FHRETYP="Consolidated"
- +6 IF FHSTARTD'=FHSTOPDT
- Begin DoDot:1
- +7 SET TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$PIECE("BREAKFAST^NOON^EVENING","^",K3)
- +8 SET TIMAFP=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP
- End DoDot:1
- +9 IF FHSTARTD=FHSTOPDT
- Begin DoDot:1
- +10 SET TIM=FHSTARTD_"DAY "_FHDSTART_" "_$PIECE("BREAKFAST^NOON^EVENING","^",K3)
- +11 SET TIMAFP=FHSTARTD_"DAY "_FHDSTART
- End DoDot:1
- +12 ;S:FHSTARTD'=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- +13 ;S:FHSTARTD=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
- +14 SET TIMAFP=TIMAFP_" ( "_FHMEALHE_" )"
- +15 SET DTP=NOW
- DO DTP^FH
- +16 KILL S,D,N
- SET L1=38
- +17 FOR P0=0:0
- SET P0=$ORDER(^TMP($JOB,"FH",P0))
- IF P0=""
- QUIT
- SET X=^FH(119.72,P0,0)
- SET N1=$PIECE(X,"^",1)
- SET N2=$PIECE(X,"^",2)
- SET N3=$PIECE(X,"^",4)
- IF N3=""
- SET N3=$EXTRACT(N1,1,6)
- SET S(N3,P0)=$JUSTIFY(N3,8)_"^"_N2
- SET L1=L1+14
- +18 IF L1<80
- SET L1=80
- +19 SET Z=$SELECT(FHP6["F":"F O R E C A S T E D",1:"A C T U A L")_" D I E T C E N S U S"
- +20 IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +21 SET DTP=NOW
- DO DTP^FH
- WRITE !,DTP,?(L1-$LENGTH(Z)\2),Z,?(L1-7),"Page ",PG
- +22 WRITE !,FHRETYP
- +23 SET Z=$PIECE(^FH(119.71,FHP,0),"^",1)
- +24 WRITE !?(L1-$LENGTH(Z)\2),Z,!!?(L1-$LENGTH(TIM)\2),TIM
- +25 WRITE !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!?29
- +26 SET X=""
- FOR
- SET X=$ORDER(S(X))
- IF X=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(X,K))
- IF K=""
- QUIT
- WRITE $PIECE(S(X,K),"^",1)
- +27 WRITE " Total"
- SET LN=""
- SET $PIECE(LN,"-",L1+1)=""
- WRITE !,LN,!
- KILL LN
- +28 FOR P1=0:0
- SET P1=$ORDER(^FH(116.2,"AP",P1))
- IF P1<1
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FH(116.2,"AP",P1,K))
- IF K<1
- QUIT
- IF $DATA(^TMP($JOB,"FH",0,K))
- DO PRO
- +29 IF FHP6["C"
- WRITE !?3,"N P O",?31
- SET K=.5
- DO P1
- KILL NP(.5)
- +30 IF FHP6["C"
- WRITE !?3,"P A S S",?31
- SET K=.8
- DO P1
- KILL NP(.8)
- +31 IF FHP6["C"
- WRITE !?3,"TF Only",?31
- SET K=.7
- DO P1
- KILL NP(.7)
- +32 IF FHP6["C"
- WRITE !?3,"No Order",?31
- SET K=.6
- DO P1
- KILL NP(.6)
- +33 WRITE !!,"TOTAL MEALS",?31
- SET TOT=""
- +34 SET X=""
- FOR
- SET X=$ORDER(S(X))
- IF X=""
- QUIT
- FOR K1=0:0
- SET K1=$ORDER(S(X,K1))
- IF K1=""
- QUIT
- Begin DoDot:1
- +35 SET Z=$GET(^TMP($JOB,"FH",K1))
- IF Z
- SET TOT=TOT+Z
- WRITE $JUSTIFY(Z,6)," "
- End DoDot:1
- +36 WRITE $JUSTIFY(TOT,7)
- QUIT
- +37 WRITE !!!,"*** Includes other gratuitous/paid meals.",!
- KILL S,D,N,P
- QUIT
- PRO WRITE !,$PIECE($GET(^FH(116.2,K,0)),"^",1),?31
- P1 SET (TOT,X)=""
- FOR
- SET X=$ORDER(S(X))
- IF X=""
- QUIT
- FOR K1=0:0
- SET K1=$ORDER(S(X,K1))
- IF K1=""
- QUIT
- Begin DoDot:1
- +1 SET Z=$SELECT(K>.9:$GET(^TMP($JOB,"FH",K1,K)),1:$GET(NP(K,K1)))
- +2 IF Z
- SET TOT=TOT+Z
- WRITE $JUSTIFY(Z,6)," "
- End DoDot:1
- +3 WRITE $JUSTIFY(TOT,7)
- QUIT
- CEN ; Calculate for Census
- +1 KILL ^TMP($JOB,"FH"),^TMP($JOB,"FHD")
- +2 SET X=D1_"@"_$SELECT(MEAL="B":"7AM",MEAL="N":"11AM",1:"4PM")
- SET %DT="TX"
- DO ^%DT
- SET TIM=Y
- +3 KILL D,P
- FOR WRD=0:0
- SET WRD=$ORDER(^FH(119.6,WRD))
- IF WRD<1
- QUIT
- SET X=^(WRD,0)
- Begin DoDot:1
- +4 IF $GET(FHSITE)
- IF ($PIECE(X,U,8)'=FHSITE)
- QUIT
- +5 SET FHSERFLG=0
- +6 SET FHSER=$PIECE(X,U,5)
- IF $GET(FHSER)
- SET SP(FHSER)=""
- IF $GET(FHSER)
- IF $DATA(^FH(119.72,FHSER,0))
- IF $PIECE(^FH(119.72,FHSER,0),U,3)=FHP
- SET FHSERFLG=1
- +7 SET FHSER=$PIECE(X,U,6)
- IF $GET(FHSER)
- SET SP(FHSER)=""
- IF $GET(FHSER)
- IF $DATA(^FH(119.72,FHSER,0))
- IF $PIECE(^FH(119.72,FHSER,0),U,3)=FHP
- SET FHSERFLG=1
- +8 IF '$GET(FHSERFLG)
- QUIT
- +9 IF '$GET(FHSITE)
- DO WRD^FHORD9
- QUIT
- +10 IF $GET(FHSITE)
- IF $PIECE(X,U,8)=FHSITE
- DO WRD^FHORD9
- End DoDot:1
- +11 SET FHDTOT=0
- +12 FOR FHIJ=0:0
- SET FHIJ=$ORDER(FHMEALAR(MEAL,FHIJ))
- IF FHIJ'>0
- QUIT
- Begin DoDot:1
- +13 SET FHDTOT=FHDTOT+1
- +14 FOR FHI=0:0
- SET FHI=$ORDER(P(FHI))
- IF FHI'>0
- QUIT
- FOR FHJ=0:0
- SET FHJ=$ORDER(P(FHI,FHJ))
- IF FHJ'>0
- QUIT
- Begin DoDot:2
- +15 IF FHI<1
- QUIT
- +16 IF '$DATA(^TMP($JOB,"FHD",FHIJ,FHJ,FHI))
- SET ^TMP($JOB,"FHD",FHIJ,FHJ,FHI)=0
- +17 SET ^TMP($JOB,"FHD",FHIJ,FHJ,FHI)=^TMP($JOB,"FHD",FHIJ,FHJ,FHI)+P(FHI,FHJ)
- End DoDot:2
- End DoDot:1
- +18 ;
- +19 FOR FHI=0:0
- SET FHI=$ORDER(P(FHI))
- IF FHI'>0
- QUIT
- FOR FHJ=0:0
- SET FHJ=$ORDER(P(FHI,FHJ))
- IF FHJ'>0
- QUIT
- Begin DoDot:1
- +20 IF P(FHI,FHJ)>0
- SET P(FHI,FHJ)=P(FHI,FHJ)*FHDTOT
- End DoDot:1
- +21 ;go proccess outpatient data
- +22 DO OUT^FHPRO3
- +23 ;
- COMB ;
- +1 KILL D,NP,T
- FOR LP=0:0
- SET LP=$ORDER(P(.5,LP))
- IF LP<1
- QUIT
- IF '$DATA(NP(.5,LP))
- SET NP(.5,LP)=0
- SET NP(.5,LP)=NP(.5,LP)+P(.5,LP)
- IF '$DATA(D(LP))
- SET D(LP)=0
- SET D(LP)=D(LP)+P(.5,LP)
- +2 KILL P(.5)
- FOR LP=0:0
- SET LP=$ORDER(P(.7,LP))
- IF LP<1
- QUIT
- IF '$DATA(NP(.7,LP))
- SET NP(.7,LP)=0
- SET NP(.7,LP)=NP(.7,LP)+P(.7,LP)
- IF '$DATA(D(LP))
- SET D(LP)=0
- SET D(LP)=D(LP)+P(.7,LP)
- +3 KILL P(.7)
- FOR LL=0:0
- SET LL=$ORDER(P(.6,LL))
- IF LL<1
- QUIT
- IF '$DATA(NP(.6,LL))
- SET NP(.6,LL)=0
- SET NP(.6,LL)=NP(.6,LL)+P(.6,LL)
- +4 KILL P(.6)
- FOR LL=0:0
- SET LL=$ORDER(P(.8,LL))
- IF LL<1
- QUIT
- IF '$DATA(NP(.8,LL))
- SET NP(.8,LL)=0
- SET NP(.8,LL)=NP(.8,LL)+P(.8,LL)
- IF '$DATA(D(LL))
- SET D(LL)=0
- SET D(LL)=D(LL)+P(.8,LL)
- +5 KILL P(.8)
- FOR LL=0:0
- SET LL=$ORDER(P(LL))
- IF LL<1
- QUIT
- FOR P0=0:0
- SET P0=$ORDER(P(LL,P0))
- IF P0<1
- QUIT
- IF '$DATA(T(P0))
- SET T(P0)=0
- SET T(P0)=T(P0)+P(LL,P0)
- +6 FOR LP=0:0
- SET LP=$ORDER(NP(.6,LP))
- IF LP<1
- QUIT
- IF $DATA(T(LP))
- SET NP(.6,LP)=NP(.6,LP)-T(LP)-$GET(D(LP))
- IF '$DATA(D(LP))
- SET D(LP)=0
- SET D(LP)=D(LP)+NP(.6,LP)
- +7 FOR P0=0:0
- SET P0=$ORDER(^FH(119.72,P0))
- IF P0<1
- QUIT
- IF $PIECE(^(P0,0),"^",3)=FHP
- IF $DATA(^FH(119.72,P0,"B"))
- DO D0
- +8 KILL ^TMP($JOB,"FH")
- FOR LL=0:0
- SET LL=$ORDER(P(LL))
- IF LL<1
- QUIT
- SET P(LL,0)=0
- FOR P0=0:0
- SET P0=$ORDER(P(LL,P0))
- IF P0<1
- QUIT
- SET ^TMP($JOB,"FH",P0,LL)=P(LL,P0)
- IF '$DATA(D(P0))
- SET D(P0)=""
- SET D(P0)=D(P0)+P(LL,P0)
- SET P(LL,0)=P(LL,0)+P(LL,P0)
- +9 FOR P0=0:0
- SET P0=$ORDER(D(P0))
- IF P0<1
- QUIT
- SET ^TMP($JOB,"FH",P0)=D(P0)
- +10 FOR LL=0:0
- SET LL=$ORDER(P(LL))
- IF LL<1
- QUIT
- IF $GET(P(LL,0))
- SET ^TMP($JOB,"FH",0,LL)=P(LL,0)
- +11 KILL P,D
- QUIT
- D0 ;
- +1 IF '$DATA(SP(P0))
- QUIT
- +2 IF $GET(^FH(119.72,P0,"I"))="Y"
- QUIT
- +3 ;get all the AO for all dates being asked.
- +4 FOR LL=0:0
- SET LL=$ORDER(^FH(119.72,P0,"B",LL))
- IF LL<1
- QUIT
- FOR FHDOII=0:0
- SET FHDOII=$ORDER(FHDODAY(FHDOII))
- IF FHDOII'>0
- QUIT
- Begin DoDot:1
- +5 SET (FHDOD1,X)=FHDODAY(FHDOII)
- DO DOW^%DTC
- SET DOW=Y+1
- +6 ;meal is not for certain date.
- IF '$DATA(FHMEALAR(MEAL,FHDOD1))
- QUIT
- +7 SET Y=$PIECE(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3)
- IF Y>0
- IF '$DATA(P(LL,P0))
- SET P(LL,P0)=0
- SET P(LL,P0)=P(LL,P0)+Y
- +8 IF Y>0
- IF '$DATA(^TMP($JOB,"FHD",FHDOD1,P0,LL))
- SET ^TMP($JOB,"FHD",FHDOD1,P0,LL)=0
- SET ^TMP($JOB,"FHD",FHDOD1,P0,LL)=^TMP($JOB,"FHD",FHDOD1,P0,LL)+Y
- End DoDot:1
- +9 ;F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
- +10 QUIT
