- FHPRR2 ; HISC/REL/RVD - Projected Usage (cont). ;1/23/98 16:11
- ;;5.5;DIETETICS;;Jan 28, 2005
- ;RVD - Outpatient meals.
- S T0=0 F P0=0:0 S P0=$O(M(P0)) Q:P0<1 S T0=T0+M(P0)
- S DTP=SDT D DTP^FH S H1=DTP,DTP=EDT D DTP^FH S H1=H1_" to "_DTP
- S X=SDT D DOW^%DTC S DOW=Y+1
- P0 S X1=SDT D E1^FHPRC1 G:FHCY<1 P1 G:'$D(^FH(116,FHCY,"DA",FHDA,0)) P1
- S FHX1=^FH(116,FHCY,"DA",FHDA,0)
- I $D(^FH(116.3,SDT,0)) S X=^(0) F LL=2:1:4 I $P(X,"^",LL) S $P(FHX1,"^",LL)=$P(X,"^",LL)
- F K3=1:1:3 S MENU=$P(FHX1,"^",K3+1) D:MENU P2
- P1 S X1=SDT,X2=1 D C^%DTC S SDT=X I SDT>EDT G S0
- S DOW=DOW+1 S:DOW=8 DOW=1 G P0
- P2 F L1=0:0 S L1=$O(^FH(116.1,MENU,"RE",L1)) Q:L1<1 S M=^(L1,0) D P3
- K M,Y,Z Q
- P3 S N1=0,M=+M,X=$G(^FH(114,M,0))
- F CAT=0:0 S CAT=$O(^FH(116.1,MENU,"RE",L1,"R",CAT)) Q:CAT<1 S FHPD=$P($G(^(CAT,0)),"^",2) D
- .F LL=1:1 S FHX2=$P(FHPD," ",LL) Q:FHX2="" D P4
- .Q
- Q:'N1 S:'$D(^TMP($J,"T",M)) ^TMP($J,"T",M)=0 S ^(M)=^(M)+N1 Q
- P4 S X=$P(FHX2,";",1)
- S X1=$G(^TMP($J,"M",DOW_K3,X,"T")),X2=$G(^TMP($J,"M",DOW_K3,X,"C"))
- S Y=$P(FHX2,";",2) I Y="" G P41:$O(^FH(116.1,MENU,"RE",L1,"D",0))="",P6
- D P5 S Y=$P(FHX2,";",3) D:Y'="" P5
- P41 S N1=N1+X1+X2 Q
- P5 I $E(Y,1)="C" S X2=$J($E(Y,2,99)*X2/100,0,0) Q
- S X1=$J($E(Y,2,99)*X1/100,0,0) Q
- P6 F P0=0:0 S P0=$O(^TMP($J,"P",DOW_K3,P0)) Q:P0<1 D P7
- Q
- P7 S SRV=$P($G(^FH(119.72,P0,0)),"^",2)
- I $E(SRV,1)="T" S X1=$G(^TMP($J,"P",DOW_K3,P0,X,"T"))
- I $E(SRV,1)="C" S X1=$G(^TMP($J,"P",DOW_K3,P0,X,"C"))
- S Z1=$G(^FH(116.1,MENU,"RE",L1,"D",P0,0))
- S Y=$P(Z1,"^",2) I Y'="" S X1=$J(Y*X1/100,0,0)
- S N1=N1+X1 Q
- S0 F K1=0:0 S K1=$O(^TMP($J,"T",K1)) Q:K1<1 D S1
- G:$O(^TMP($J,"T",""))'="" S0
- G LIS
- S1 S X0=$G(^FH(114,K1,0)),P1=^TMP($J,"T",K1),MUL=$P(X0,"^",2) K ^TMP($J,"T",K1) Q:'MUL S MUL=P1/MUL
- F KK=0:0 S KK=$O(^FH(114,K1,"I",KK)) Q:KK<1 S Y=^(KK,0) D S2
- F KK=0:0 S KK=$O(^FH(114,K1,"R",KK)) Q:KK<1 S Y=^(KK,0) D S3
- Q
- S2 S X1=+Y,Q=$P(Y,"^",2)*MUL
- S Y0=$G(^FHING(X1,0))
- S S1=$E($P(Y0,"^",1),1,30) Q:S1="" I V0 S V1=$P(Y0,"^",4) S:V1 V1=$P($G(^FH(113.2,V1,0)),"^",1) S S1=$E(V1_$J("",30),1,30)_S1
- S:'$D(^TMP($J,"S",S1,X1)) ^TMP($J,"S",S1,X1)=0 S ^(X1)=^(X1)+Q Q
- S3 S P1=$P(Y,"^",2)*MUL S:'$D(^TMP($J,"T",+Y)) ^TMP($J,"T",+Y)=0 S ^TMP($J,"T",+Y)=^TMP($J,"T",+Y)+P1 Q
- LIS D NOW^%DTC S NOW=%,DTP=NOW D DTP^FH S (PG,TOT)=0 D HDR
- S (S1,V1)="" F K=0:0 S S1=$O(^TMP($J,"S",S1)) Q:S1="" F L1=0:0 S L1=$O(^TMP($J,"S",S1,L1)) Q:L1<1 S X0=^(L1) D L0
- W !!,"Total Cost",?77,$J(TOT,12,2),! Q
- L0 D:$Y>(IOSL-7) HDR S Y0=^FHING(L1,0) G:'V0 L1
- S X1=$P(Y0,"^",4) S:X1 X1=$P($G(^FH(113.2,X1,0)),"^",1) I X1'=V1 S V1=X1 W !!?5,"Vendor: ",X1,!
- L1 S I1=$P(Y0,"^",17),X1=$S('I1:"",1:X0/I1)
- S I1=$P(Y0,"^",8),X2=$S('I1:"",1:X1/I1),X3=$P(Y0,"^",9)*(X2+.99\1) S:'X3 X3="" I X3 S X3=$J(X3,0,2),TOT=TOT+X3,%=$L(X3) I %>6 S X3=$E(X3,1,%-6)_","_$E(X3,%-5,%)
- S X=X0 D COM S X0=X,X=X1 D COM S X1=X,X=X2 D COM S X2=X
- W !,$P(Y0,"^",1),?63,$J(X2,8)," ",$P(Y0,"^",5),?80,$J(X3,9),?93,$J(X1,8)," ",$P(Y0,"^",6),?118,$J(X0,8)," ",$P(Y0,"^",16) Q
- COM Q:X="" S X=X+.99\1,%=$L(X) Q:%<4 S X=$E(X,1,%-3)_","_$E(X,%-2,%) Q
- HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,DTP,?51,"P R O J E C T E D U S A G E ",?125,"Page ",PG
- W !!,"Avg. Total Census = ",T0,?(131-$L(H1)\2),H1
- W !!,"Ingredient",?64,"Purchase Qty",?84,"Cost",?97,"Issue Qty",?121,"Recipe Qty"
- W ! F K=1:1:131 W "-"
- Q
- FHPRR2 ; HISC/REL/RVD - Projected Usage (cont). ;1/23/98 16:11
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 ;RVD - Outpatient meals.
- +3 SET T0=0
- FOR P0=0:0
- SET P0=$ORDER(M(P0))
- IF P0<1
- QUIT
- SET T0=T0+M(P0)
- +4 SET DTP=SDT
- DO DTP^FH
- SET H1=DTP
- SET DTP=EDT
- DO DTP^FH
- SET H1=H1_" to "_DTP
- +5 SET X=SDT
- DO DOW^%DTC
- SET DOW=Y+1
- P0 SET X1=SDT
- DO E1^FHPRC1
- IF FHCY<1
- GOTO P1
- IF '$DATA(^FH(116,FHCY,"DA",FHDA,0))
- GOTO P1
- +1 SET FHX1=^FH(116,FHCY,"DA",FHDA,0)
- +2 IF $DATA(^FH(116.3,SDT,0))
- SET X=^(0)
- FOR LL=2:1:4
- IF $PIECE(X,"^",LL)
- SET $PIECE(FHX1,"^",LL)=$PIECE(X,"^",LL)
- +3 FOR K3=1:1:3
- SET MENU=$PIECE(FHX1,"^",K3+1)
- IF MENU
- DO P2
- P1 SET X1=SDT
- SET X2=1
- DO C^%DTC
- SET SDT=X
- IF SDT>EDT
- GOTO S0
- +1 SET DOW=DOW+1
- IF DOW=8
- SET DOW=1
- GOTO P0
- P2 FOR L1=0:0
- SET L1=$ORDER(^FH(116.1,MENU,"RE",L1))
- IF L1<1
- QUIT
- SET M=^(L1,0)
- DO P3
- +1 KILL M,Y,Z
- QUIT
- P3 SET N1=0
- SET M=+M
- SET X=$GET(^FH(114,M,0))
- +1 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,MENU,"RE",L1,"R",CAT))
- IF CAT<1
- QUIT
- SET FHPD=$PIECE($GET(^(CAT,0)),"^",2)
- Begin DoDot:1
- +2 FOR LL=1:1
- SET FHX2=$PIECE(FHPD," ",LL)
- IF FHX2=""
- QUIT
- DO P4
- +3 QUIT
- End DoDot:1
- +4 IF 'N1
- QUIT
- IF '$DATA(^TMP($JOB,"T",M))
- SET ^TMP($JOB,"T",M)=0
- SET ^(M)=^(M)+N1
- QUIT
- P4 SET X=$PIECE(FHX2,";",1)
- +1 SET X1=$GET(^TMP($JOB,"M",DOW_K3,X,"T"))
- SET X2=$GET(^TMP($JOB,"M",DOW_K3,X,"C"))
- +2 SET Y=$PIECE(FHX2,";",2)
- IF Y=""
- IF $ORDER(^FH(116.1,MENU,"RE",L1,"D",0))=""
- GOTO P41
- GOTO P6
- +3 DO P5
- SET Y=$PIECE(FHX2,";",3)
- IF Y'=""
- DO P5
- P41 SET N1=N1+X1+X2
- QUIT
- P5 IF $EXTRACT(Y,1)="C"
- SET X2=$JUSTIFY($EXTRACT(Y,2,99)*X2/100,0,0)
- QUIT
- +1 SET X1=$JUSTIFY($EXTRACT(Y,2,99)*X1/100,0,0)
- QUIT
- P6 FOR P0=0:0
- SET P0=$ORDER(^TMP($JOB,"P",DOW_K3,P0))
- IF P0<1
- QUIT
- DO P7
- +1 QUIT
- P7 SET SRV=$PIECE($GET(^FH(119.72,P0,0)),"^",2)
- +1 IF $EXTRACT(SRV,1)="T"
- SET X1=$GET(^TMP($JOB,"P",DOW_K3,P0,X,"T"))
- +2 IF $EXTRACT(SRV,1)="C"
- SET X1=$GET(^TMP($JOB,"P",DOW_K3,P0,X,"C"))
- +3 SET Z1=$GET(^FH(116.1,MENU,"RE",L1,"D",P0,0))
- +4 SET Y=$PIECE(Z1,"^",2)
- IF Y'=""
- SET X1=$JUSTIFY(Y*X1/100,0,0)
- +5 SET N1=N1+X1
- QUIT
- S0 FOR K1=0:0
- SET K1=$ORDER(^TMP($JOB,"T",K1))
- IF K1<1
- QUIT
- DO S1
- +1 IF $ORDER(^TMP($JOB,"T",""))'=""
- GOTO S0
- +2 GOTO LIS
- S1 SET X0=$GET(^FH(114,K1,0))
- SET P1=^TMP($JOB,"T",K1)
- SET MUL=$PIECE(X0,"^",2)
- KILL ^TMP($JOB,"T",K1)
- IF 'MUL
- QUIT
- SET MUL=P1/MUL
- +1 FOR KK=0:0
- SET KK=$ORDER(^FH(114,K1,"I",KK))
- IF KK<1
- QUIT
- SET Y=^(KK,0)
- DO S2
- +2 FOR KK=0:0
- SET KK=$ORDER(^FH(114,K1,"R",KK))
- IF KK<1
- QUIT
- SET Y=^(KK,0)
- DO S3
- +3 QUIT
- S2 SET X1=+Y
- SET Q=$PIECE(Y,"^",2)*MUL
- +1 SET Y0=$GET(^FHING(X1,0))
- +2 SET S1=$EXTRACT($PIECE(Y0,"^",1),1,30)
- IF S1=""
- QUIT
- IF V0
- SET V1=$PIECE(Y0,"^",4)
- IF V1
- SET V1=$PIECE($GET(^FH(113.2,V1,0)),"^",1)
- SET S1=$EXTRACT(V1_$JUSTIFY("",30),1,30)_S1
- +3 IF '$DATA(^TMP($JOB,"S",S1,X1))
- SET ^TMP($JOB,"S",S1,X1)=0
- SET ^(X1)=^(X1)+Q
- QUIT
- S3 SET P1=$PIECE(Y,"^",2)*MUL
- IF '$DATA(^TMP($JOB,"T",+Y))
- SET ^TMP($JOB,"T",+Y)=0
- SET ^TMP($JOB,"T",+Y)=^TMP($JOB,"T",+Y)+P1
- QUIT
- LIS DO NOW^%DTC
- SET NOW=%
- SET DTP=NOW
- DO DTP^FH
- SET (PG,TOT)=0
- DO HDR
- +1 SET (S1,V1)=""
- FOR K=0:0
- SET S1=$ORDER(^TMP($JOB,"S",S1))
- IF S1=""
- QUIT
- FOR L1=0:0
- SET L1=$ORDER(^TMP($JOB,"S",S1,L1))
- IF L1<1
- QUIT
- SET X0=^(L1)
- DO L0
- +2 WRITE !!,"Total Cost",?77,$JUSTIFY(TOT,12,2),!
- QUIT
- L0 IF $Y>(IOSL-7)
- DO HDR
- SET Y0=^FHING(L1,0)
- IF 'V0
- GOTO L1
- +1 SET X1=$PIECE(Y0,"^",4)
- IF X1
- SET X1=$PIECE($GET(^FH(113.2,X1,0)),"^",1)
- IF X1'=V1
- SET V1=X1
- WRITE !!?5,"Vendor: ",X1,!
- L1 SET I1=$PIECE(Y0,"^",17)
- SET X1=$SELECT('I1:"",1:X0/I1)
- +1 SET I1=$PIECE(Y0,"^",8)
- SET X2=$SELECT('I1:"",1:X1/I1)
- SET X3=$PIECE(Y0,"^",9)*(X2+.99\1)
- IF 'X3
- SET X3=""
- IF X3
- SET X3=$JUSTIFY(X3,0,2)
- SET TOT=TOT+X3
- SET %=$LENGTH(X3)
- IF %>6
- SET X3=$EXTRACT(X3,1,%-6)_","_$EXTRACT(X3,%-5,%)
- +2 SET X=X0
- DO COM
- SET X0=X
- SET X=X1
- DO COM
- SET X1=X
- SET X=X2
- DO COM
- SET X2=X
- +3 WRITE !,$PIECE(Y0,"^",1),?63,$JUSTIFY(X2,8)," ",$PIECE(Y0,"^",5),?80,$JUSTIFY(X3,9),?93,$JUSTIFY(X1,8)," ",$PIECE(Y0,"^",6),?118,$JUSTIFY(X0,8)," ",$PIECE(Y0,"^",16)
- QUIT
- COM IF X=""
- QUIT
- SET X=X+.99\1
- SET %=$LENGTH(X)
- IF %<4
- QUIT
- SET X=$EXTRACT(X,1,%-3)_","_$EXTRACT(X,%-2,%)
- QUIT
- HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !,DTP,?51,"P R O J E C T E D U S A G E ",?125,"Page ",PG
- +1 WRITE !!,"Avg. Total Census = ",T0,?(131-$LENGTH(H1)\2),H1
- +2 WRITE !!,"Ingredient",?64,"Purchase Qty",?84,"Cost",?97,"Issue Qty",?121,"Recipe Qty"
- +3 WRITE !
- FOR K=1:1:131
- WRITE "-"
- +4 QUIT
