FHADR81 ; HISC/NCA - Print Dietetic Costs ;11/25/94 14:11
;;5.5;DIETETICS;;Jan 28, 2005
EN2 ; Print Dietetic Cost
K N,PER,T1,TO,TP S (TO,TP,TQ,TQ1,TQ2,TQ3,TQ4)="",TOT=0
F I=1:1:5 S T1(I)=""
F I=1:1:4 S PER(I)=""
F QR=1:1:4 S QTR=QR,PRE=FHYR_"0"_QTR_"00" D Q2^FHADRPT,CALC
D PRT K N,PER,T1,TO,TP Q
CALC ; Calculate the Avg Cost Per Meal and store it in T1(1)
Q:'SDT!('EDT)
S (BEG,CLOS,ISS,USG)=0
S SDT=$E(SDT,1,5)_"00",EDT=$E(EDT,1,5)_"00"
S X1=$P($G(^FH(117.2,SDT,0)),"^",2,7) F J=1:1:6 S BEG=BEG+$P(X1,"^",J)
S X1=$P($G(^FH(117.2,EDT,0)),"^",14,19) F J=1:1:6 S CLOS=CLOS+$P(X1,"^",J)
S SDT=$E(SDT,1,5)-1_"00"
F LL=SDT:0 S LL=$O(^FH(117.2,LL)) Q:LL<1!(LL>EDT) S X1=^(LL,0) D
.S J1=7
.F J=1:1:6 D
..S J1=J1+1
..S ISS=ISS+$P(X1,"^",J1)
..Q
.Q
S USG=(BEG+ISS)-CLOS
S TQ=TQ+1
S TOT=$P($G(^FH(117.3,PRE,1)),"^",5)
S USG=$S(TOT:USG/TOT,1:"") S:USG TQ1=TQ1+1 S $P(T1(1),"^",QTR)=$P(T1(1),"^",QTR)+USG
S $P(T1(1),"^",5)=$P(T1(1),"^",5)+USG
; Calculate the Cost Per Diem
S ST=$P($G(^FH(117.3,PRE,"COST",0)),"^",3) Q:ST<1
S ST1=$G(^FH(117.3,PRE,"COST",ST,0)) Q:ST1=""
F I=1:1:10 S N(I)=""
S K=0 F I=1:1:6,8,9 S K=K+1,N(I)=$P(ST1,"^",K)
S TOT=$S(TOT:TOT/3,1:"")
F M=1:1:6,8,9 S N(M)=$S(TOT:N(M)/TOT,1:"")
S N(7)=N(2)-N(3)-N(4)-N(5)-N(6),N(10)=N(1)-N(2)-N(8)-N(9)
F M=1:1:10 S N(M)=$J(N(M),0,2)
S:N(1) TQ2=TQ2+1
S:N(2) TQ3=TQ3+1
; Store data of each 4 Quarters in T1(2)-T1(5) and Total in TO.
S K=0 F I=3:1:10 S K=K+1,$P(T1(QTR+1),"^",K)=$S(N(I):N(I),1:"")
S $P(T1(QTR+1),"^",9)=$S(N(2):N(2),1:""),$P(T1(QTR+1),"^",10)=$S(N(1):N(1),1:"")
F L=1:1:10 S $P(TO,"^",L)=$P(TO,"^",L)+$P(T1(QTR+1),"^",L)
; Calculate and store Percent Cost and after T1 Cost Strg.
F I=6:1:10 S $P(PER(QTR),"^",I)=$S(+$P(T1(QTR+1),"^",10)'<1:$P(T1(QTR+1),"^",I)/$P(T1(QTR+1),"^",10)*100,1:"")
Q
PRT ; Print Avg Cost Per Meal, Cost Per Diem, and the YTD
S $P(T1(1),"^",5)=$S(TQ1:$P(T1(1),"^",5)/TQ1,1:"")
D:$Y'<(LIN-9) HDR^FHADRPT D HD,HDR
W ?35 F L=1:1:4 W " ",$S($P(T1(1),"^",L):$J($P(T1(1),"^",L),8,2),1:$J("",8))_$J("",11)
W $S($P(T1(1),"^",5):$J($P(T1(1),"^",5),8,2),1:$J("",8))
D HDR1
F L=6:1:10 S $P(TP,"^",L)=$S(+$P(TO,"^",10)'<1:$P(TO,"^",L)/$P(TO,"^",10)*100,1:"")
S K=1
S I=2 F TIT="Tech (1019)","Dietitians (1018)","Wageboard (1008)","Clerical (1002)","Other" S TQ4=TQ2 D LOOP
S X="Total Personal Cost" S K1=9 D LAST
S I=0,K=6 F TIT="Subsistence (2610)","Operating Supp (2660)","All Other" S TQ4=TQ3 D LOOP
S X="Total" S K1=10 D LAST
Q
LAST ; Print the Last Line
S TQ4=""
W !,X,?29 F I=1:1:4 D
.S X=$S($P(T1(I+1),"^",K1):$P(T1(I+1),"^",K1),1:"")
.S:X TQ4=TQ4+1
.W $S(X:$J(X,9,2),1:$J("",9))_" "
.W $S($P(PER(I),"^",K1):$J($P(PER(I),"^",K1),8,2),1:$J("",8))_" "
.Q
W ?110 S X=$S($P(TO,"^",K1):$P(TO,"^",K1),1:""),X=$J($S(TQ4:X/TQ4,1:""),0,2)
W $S(X:$J(X,9,2),1:$J("",9))_" "
W $S($P(TP,"^",K1):$J($P(TP,"^",K1),8,2),1:$J("",8))
Q
LOOP ; Print title for each row along with the cost of the quarters.
W ! W:I ?I W TIT,?29
F J=1:1:4 D
.S X=$S($P(T1(J+1),"^",K):$P(T1(J+1),"^",K),1:"")
.W $S(X:$J(X,9,2),1:$J("",9))_" "
.W $S($P(PER(J),"^",K):$J($P(PER(J),"^",K),8,2),1:$J("",8))_" "
.Q
W ?110 S X=$S($P(TO,"^",K):$P(TO,"^",K),1:""),X=$J($S(TQ4:X/TQ4,1:""),0,2)
W $S(X:$J(X,9,2),1:$J("",9))_" "
W $S($P(TP,"^",K):$J($P(TP,"^",K),8,2),1:$J("",8))
S K=K+1
Q
HD W !!!!,"S E C T I O N V D I E T E T I C C O S T" Q
HDR ; Print Cost Per Meal Hdg
W !!!!,"COST PER MEAL"
W ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
W !!,"Average Cost Per Meal"
Q
HDR1 ; Print Cost Per Diem Hdg
D:$Y'<(LIN-15) HDR^FHADRPT,HD
W !!!!,"COST PER DIEM"
W ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
W !,?34,"Cost",?41,"% Cost",?54,"Cost",?61,"% Cost",?74,"Cost",?81,"% Cost",?94,"Cost",?101,"% Cost",?112,"Avg Tot",?122,"% Cost"
W !,"Personal Services" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADR81 3928 printed Dec 13, 2024@01:46:37 Page 2
FHADR81 ; HISC/NCA - Print Dietetic Costs ;11/25/94 14:11
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN2 ; Print Dietetic Cost
+1 KILL N,PER,T1,TO,TP
SET (TO,TP,TQ,TQ1,TQ2,TQ3,TQ4)=""
SET TOT=0
+2 FOR I=1:1:5
SET T1(I)=""
+3 FOR I=1:1:4
SET PER(I)=""
+4 FOR QR=1:1:4
SET QTR=QR
SET PRE=FHYR_"0"_QTR_"00"
DO Q2^FHADRPT
DO CALC
+5 DO PRT
KILL N,PER,T1,TO,TP
QUIT
CALC ; Calculate the Avg Cost Per Meal and store it in T1(1)
+1 if 'SDT!('EDT)
QUIT
+2 SET (BEG,CLOS,ISS,USG)=0
+3 SET SDT=$EXTRACT(SDT,1,5)_"00"
SET EDT=$EXTRACT(EDT,1,5)_"00"
+4 SET X1=$PIECE($GET(^FH(117.2,SDT,0)),"^",2,7)
FOR J=1:1:6
SET BEG=BEG+$PIECE(X1,"^",J)
+5 SET X1=$PIECE($GET(^FH(117.2,EDT,0)),"^",14,19)
FOR J=1:1:6
SET CLOS=CLOS+$PIECE(X1,"^",J)
+6 SET SDT=$EXTRACT(SDT,1,5)-1_"00"
+7 FOR LL=SDT:0
SET LL=$ORDER(^FH(117.2,LL))
if LL<1!(LL>EDT)
QUIT
SET X1=^(LL,0)
Begin DoDot:1
+8 SET J1=7
+9 FOR J=1:1:6
Begin DoDot:2
+10 SET J1=J1+1
+11 SET ISS=ISS+$PIECE(X1,"^",J1)
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET USG=(BEG+ISS)-CLOS
+15 SET TQ=TQ+1
+16 SET TOT=$PIECE($GET(^FH(117.3,PRE,1)),"^",5)
+17 SET USG=$SELECT(TOT:USG/TOT,1:"")
if USG
SET TQ1=TQ1+1
SET $PIECE(T1(1),"^",QTR)=$PIECE(T1(1),"^",QTR)+USG
+18 SET $PIECE(T1(1),"^",5)=$PIECE(T1(1),"^",5)+USG
+19 ; Calculate the Cost Per Diem
+20 SET ST=$PIECE($GET(^FH(117.3,PRE,"COST",0)),"^",3)
if ST<1
QUIT
+21 SET ST1=$GET(^FH(117.3,PRE,"COST",ST,0))
if ST1=""
QUIT
+22 FOR I=1:1:10
SET N(I)=""
+23 SET K=0
FOR I=1:1:6,8,9
SET K=K+1
SET N(I)=$PIECE(ST1,"^",K)
+24 SET TOT=$SELECT(TOT:TOT/3,1:"")
+25 FOR M=1:1:6,8,9
SET N(M)=$SELECT(TOT:N(M)/TOT,1:"")
+26 SET N(7)=N(2)-N(3)-N(4)-N(5)-N(6)
SET N(10)=N(1)-N(2)-N(8)-N(9)
+27 FOR M=1:1:10
SET N(M)=$JUSTIFY(N(M),0,2)
+28 if N(1)
SET TQ2=TQ2+1
+29 if N(2)
SET TQ3=TQ3+1
+30 ; Store data of each 4 Quarters in T1(2)-T1(5) and Total in TO.
+31 SET K=0
FOR I=3:1:10
SET K=K+1
SET $PIECE(T1(QTR+1),"^",K)=$SELECT(N(I):N(I),1:"")
+32 SET $PIECE(T1(QTR+1),"^",9)=$SELECT(N(2):N(2),1:"")
SET $PIECE(T1(QTR+1),"^",10)=$SELECT(N(1):N(1),1:"")
+33 FOR L=1:1:10
SET $PIECE(TO,"^",L)=$PIECE(TO,"^",L)+$PIECE(T1(QTR+1),"^",L)
+34 ; Calculate and store Percent Cost and after T1 Cost Strg.
+35 FOR I=6:1:10
SET $PIECE(PER(QTR),"^",I)=$SELECT(+$PIECE(T1(QTR+1),"^",10)'<1:$PIECE(T1(QTR+1),"^",I)/$PIECE(T1(QTR+1),"^",10)*100,1:"")
+36 QUIT
PRT ; Print Avg Cost Per Meal, Cost Per Diem, and the YTD
+1 SET $PIECE(T1(1),"^",5)=$SELECT(TQ1:$PIECE(T1(1),"^",5)/TQ1,1:"")
+2 if $Y'<(LIN-9)
DO HDR^FHADRPT
DO HD
DO HDR
+3 WRITE ?35
FOR L=1:1:4
WRITE " ",$SELECT($PIECE(T1(1),"^",L):$JUSTIFY($PIECE(T1(1),"^",L),8,2),1:$JUSTIFY("",8))_$JUSTIFY("",11)
+4 WRITE $SELECT($PIECE(T1(1),"^",5):$JUSTIFY($PIECE(T1(1),"^",5),8,2),1:$JUSTIFY("",8))
+5 DO HDR1
+6 FOR L=6:1:10
SET $PIECE(TP,"^",L)=$SELECT(+$PIECE(TO,"^",10)'<1:$PIECE(TO,"^",L)/$PIECE(TO,"^",10)*100,1:"")
+7 SET K=1
+8 SET I=2
FOR TIT="Tech (1019)","Dietitians (1018)","Wageboard (1008)","Clerical (1002)","Other"
SET TQ4=TQ2
DO LOOP
+9 SET X="Total Personal Cost"
SET K1=9
DO LAST
+10 SET I=0
SET K=6
FOR TIT="Subsistence (2610)","Operating Supp (2660)","All Other"
SET TQ4=TQ3
DO LOOP
+11 SET X="Total"
SET K1=10
DO LAST
+12 QUIT
LAST ; Print the Last Line
+1 SET TQ4=""
+2 WRITE !,X,?29
FOR I=1:1:4
Begin DoDot:1
+3 SET X=$SELECT($PIECE(T1(I+1),"^",K1):$PIECE(T1(I+1),"^",K1),1:"")
+4 if X
SET TQ4=TQ4+1
+5 WRITE $SELECT(X:$JUSTIFY(X,9,2),1:$JUSTIFY("",9))_" "
+6 WRITE $SELECT($PIECE(PER(I),"^",K1):$JUSTIFY($PIECE(PER(I),"^",K1),8,2),1:$JUSTIFY("",8))_" "
+7 QUIT
End DoDot:1
+8 WRITE ?110
SET X=$SELECT($PIECE(TO,"^",K1):$PIECE(TO,"^",K1),1:"")
SET X=$JUSTIFY($SELECT(TQ4:X/TQ4,1:""),0,2)
+9 WRITE $SELECT(X:$JUSTIFY(X,9,2),1:$JUSTIFY("",9))_" "
+10 WRITE $SELECT($PIECE(TP,"^",K1):$JUSTIFY($PIECE(TP,"^",K1),8,2),1:$JUSTIFY("",8))
+11 QUIT
LOOP ; Print title for each row along with the cost of the quarters.
+1 WRITE !
if I
WRITE ?I
WRITE TIT,?29
+2 FOR J=1:1:4
Begin DoDot:1
+3 SET X=$SELECT($PIECE(T1(J+1),"^",K):$PIECE(T1(J+1),"^",K),1:"")
+4 WRITE $SELECT(X:$JUSTIFY(X,9,2),1:$JUSTIFY("",9))_" "
+5 WRITE $SELECT($PIECE(PER(J),"^",K):$JUSTIFY($PIECE(PER(J),"^",K),8,2),1:$JUSTIFY("",8))_" "
+6 QUIT
End DoDot:1
+7 WRITE ?110
SET X=$SELECT($PIECE(TO,"^",K):$PIECE(TO,"^",K),1:"")
SET X=$JUSTIFY($SELECT(TQ4:X/TQ4,1:""),0,2)
+8 WRITE $SELECT(X:$JUSTIFY(X,9,2),1:$JUSTIFY("",9))_" "
+9 WRITE $SELECT($PIECE(TP,"^",K):$JUSTIFY($PIECE(TP,"^",K),8,2),1:$JUSTIFY("",8))
+10 SET K=K+1
+11 QUIT
HD WRITE !!!!,"S E C T I O N V D I E T E T I C C O S T"
QUIT
HDR ; Print Cost Per Meal Hdg
+1 WRITE !!!!,"COST PER MEAL"
+2 WRITE ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
+3 WRITE !!,"Average Cost Per Meal"
+4 QUIT
HDR1 ; Print Cost Per Diem Hdg
+1 if $Y'<(LIN-15)
DO HDR^FHADRPT
DO HD
+2 WRITE !!!!,"COST PER DIEM"
+3 WRITE ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
+4 WRITE !,?34,"Cost",?41,"% Cost",?54,"Cost",?61,"% Cost",?74,"Cost",?81,"% Cost",?94,"Cost",?101,"% Cost",?112,"Avg Tot",?122,"% Cost"
+5 WRITE !,"Personal Services"
QUIT
