FHNO6 ; HISC/REL/NCA - Supplemental Feeding Costs ;2/13/95 13:32
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;3/7/06 -P5- added outpatient SFs.
W @IOF,!!?27,"SUPPLEMENTAL FEEDING COSTS",!!
D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL
I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0
I XX="S" S WRD=$O(^FH(119.74,0)) I WRD'<1,$O(^FH(119.74,WRD))<1 G S0
I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G S0
I XX="S" G D2
F1 R !!,"Select WARD (or ALL): ",X:DTIME G:'$T!("^"[X) KIL I X="ALL" S WRD=0
E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC G:Y<1 F1 S WRD=+Y
G S0
D2 R !!,"Select SUPPLEMENTAL FEEDING SITE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL I X="ALL" S WRD=0
I X'="ALL" K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S WRD=+Y
S0 S X="N" I 'WRD R !!,"SUMMARY only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G S0
S SUM=X?1"Y".E
L0 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^FHNO6",FHLST="XX^WRD^SUM" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Print Supplemental Feeding Cost Report
S (FHSUMHD,FHSUM)=0 D NOW^%DTC S DTP=% D DTP^FH S PTIM=DTP,PG=0 K ^TMP($J)
I 'SUM,'WRD S FHSUM=1
F KK=0:0 S KK=$O(^FH(119.6,KK)) Q:KK<1 S X0=$G(^(KK,0)) D
.I XX="W",WRD,WRD'=KK Q
.I XX="S",WRD,$P(X0,"^",9)'=WRD Q
.S P0=$P(X0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),TNOD=$S(SUM:"0",XX="S":"99~"_$P($G(^FH(119.74,+$P(X0,"^",9),0)),"^",1),1:P0_"~"_$P(X0,"^",1))
.F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",KK,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",KK,FHDFN)) I ADM>0 D
..S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",1)=$P($G(^TMP($J,"FH","GRAND TOTAL",0)),"^",1)+1
..S (NO,Y)="" I $D(^FHPT(FHDFN,"A",ADM,0)) S NO=$P(^(0),"^",7)
..Q:'NO S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0))
..S PD=$P(Y,"^",29) S:PD="" PD="D"
..S $P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)=$P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)+1
..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
..F L=5:2:28 S Z=$P(Y,"^",L),Q=$P(Y,"^",L+1) I Z'="" S:'Q Q=1 S:'$D(^TMP($J,"T",TNOD,Z,PD)) ^TMP($J,"T",TNOD,Z,PD)=0 S ^(PD)=^(PD)+Q I FHSUM D
...S:'$D(^TMP($J,"FH","GRAND TOTAL",Z,PD)) ^TMP($J,"FH","GRAND TOTAL",Z,PD)=0 S ^(PD)=^(PD)+Q
..Q
.Q
;
S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
S TNOD="" F S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD="" D
.S FHOUT=0
.Q:$O(^TMP($J,"T",TNOD,0))="" D HDR S (T1,T2)=0
.S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"T",TNOD,Z)) Q
..S A1=$G(^TMP($J,"T",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
.D:$Y>(IOSL-13) HDR W !!,"Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
.S CTR=$G(^TMP($J,"T",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
.W !!,"Cost/Patient:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
.W !,"Cost/Recipient:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
.W !!,"Recipient %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
I FHSUM D GRD
;
SFO ;process outpt SFs.
K ^TMP($J) S (FHSUM,FHSUMHD)=0
S FHDFNSV="",FHOUT=1
I 'SUM,'WRD S FHSUM=1
F FHI=DT-1:0 S FHI=$O(^FHPT("RM",FHI)) Q:(FHI'>0)!(FHI>DT) F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHI,FHDFN)) Q:FHDFN'>0 D
.F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0 I ($P($G(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C") D
..S FHDA15=$G(^FHPT(FHDFN,"OP",FHJ,0))
..S FHMEAL=$P(FHDA15,U,4),FHLOC=$P(FHDA15,U,3) Q:'$G(FHLOC)
..S FHLOX0=$G(^FH(119.6,FHLOC,0))
..I XX="W",WRD,WRD'=FHLOC Q
..I XX="S",WRD,$P(FHLOX0,"^",9)'=WRD Q
..S P0=$P(FHLOX0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),TNOD=$S(SUM:"0",XX="S":"99~"_$P($G(^FH(119.74,+$P(FHLOX0,"^",9),0)),"^",1),1:P0_"~"_$P(FHLOX0,"^",1))
..;I FHDFNSV'=FHDFN S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
..S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",1)=$P($G(^TMP($J,"FH","GRAND TOTAL",0)),"^",1)+1
..S:$D(^FHPT(FHDFN,"OP",FHJ,"SF",0)) FHSF=$P(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
..Q:'$G(FHSF)
..S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
..Q:$P(FHDA15SF,U,32)
..S PD=$P(FHDA15SF,"^",29) S:PD="" PD="D"
..;S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
..S $P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)=$P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)+1
..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
..F L=5:2:28 S Z=$P(FHDA15SF,"^",L),Q=$P(FHDA15SF,"^",L+1) I Z'="" S:'Q Q=1 S:'$D(^TMP($J,"T",TNOD,Z,PD)) ^TMP($J,"T",TNOD,Z,PD)=0 S ^(PD)=^(PD)+Q I FHSUM D
...S:'$D(^TMP($J,"FH","GRAND TOTAL",Z,PD)) ^TMP($J,"FH","GRAND TOTAL",Z,PD)=0 S ^(PD)=^(PD)+Q
..S FHDFNSV=FHDFN
;
S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
S TNOD="" F S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD="" D
.Q:$O(^TMP($J,"T",TNOD,0))="" D HDR S (T1,T2)=0
.S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"T",TNOD,Z)) Q
..S A1=$G(^TMP($J,"T",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
.D:$Y>(IOSL-13) HDR W !!,"Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
.S CTR=$G(^TMP($J,"T",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
.W !!,"SF Cost/Patient Meal:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
.W !,"SF Cost/Recipient Meal:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
.W !!,"Recipient Meal %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
I FHSUM D OGRD
Q
GRD S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
S FHSUMHD=1
S TNOD="" F S TNOD=$O(^TMP($J,"FH",TNOD)) Q:TNOD="" D
.S FHOUT=0
.Q:$O(^TMP($J,"FH",TNOD,0))="" D HDR S (T1,T2)=0
.S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"FH",TNOD,Z)) Q
..S A1=$G(^TMP($J,"FH",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
.D:$Y>(IOSL-13) HDR W !!,"Grand Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
.S CTR=$G(^TMP($J,"FH",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
.W !!,"Cost/Patient:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
.W !,"Cost/Recipient:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
.W !!,"Recipient %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
Q
;
OGRD S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
S FHSUMHD=1
S TNOD="" F S TNOD=$O(^TMP($J,"FH",TNOD)) Q:TNOD="" D
.Q:$O(^TMP($J,"FH",TNOD,0))="" D HDR S (T1,T2)=0
.S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"FH",TNOD,Z)) Q
..S A1=$G(^TMP($J,"FH",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
.D:$Y>(IOSL-13) HDR W !!,"Grand Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
.S CTR=$G(^TMP($J,"FH",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
.W !!,"SF Cost/Patient Meal:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
.W !,"SF Cost/Recipient Meal:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
.W !!,"Recipient Meal %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
Q
;
HDR ; Print Header
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W !,PTIM,!!?11,"S U P P L E M E N T A L F E E D I N G C O S T S",?73,"Page ",PG
W !!,$S(FHOUT=1:"***OUTPATIENT***",1:"***INPATIENT***")
I 'FHSUMHD S Y=$S(SUM:"CONSOLIDATED",1:$P(TNOD,"~",2)) W ?(80-$L(Y)\2),Y
I FHSUMHD S Y="GRAND TOTAL" W ?(80-$L(Y)\2),Y
W !!?38,"DIETARY",?52,"THERAPEUTIC",?71,"TOTAL",!,"Supplemental Feeding",?28,"Cost Qty Total Qty Total Qty Total",! Q
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNO6 9751 printed Dec 13, 2024@01:52:23 Page 2
FHNO6 ; HISC/REL/NCA - Supplemental Feeding Costs ;2/13/95 13:32
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;3/7/06 -P5- added outpatient SFs.
+3 WRITE @IOF,!!?27,"SUPPLEMENTAL FEEDING COSTS",!!
D0 READ !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME
if '$TEST!("^"[XX)
GOTO KIL
+1 IF XX'?1U!("SW"'[XX)
WRITE *7," Enter S or W"
GOTO D0
+2 IF XX="S"
SET WRD=$ORDER(^FH(119.74,0))
IF WRD'<1
IF $ORDER(^FH(119.74,WRD))<1
GOTO S0
+3 IF XX="W"
SET WRD=$ORDER(^FH(119.6,0))
IF WRD'<1
IF $ORDER(^FH(119.6,WRD))<1
GOTO S0
+4 IF XX="S"
GOTO D2
F1 READ !!,"Select WARD (or ALL): ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
IF X="ALL"
SET WRD=0
+1 IF '$TEST
KILL DIC
SET DIC="^FH(119.6,"
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO F1
SET WRD=+Y
+2 GOTO S0
D2 READ !!,"Select SUPPLEMENTAL FEEDING SITE (or ALL): ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
IF X="ALL"
SET WRD=0
+1 IF X'="ALL"
KILL DIC
SET DIC="^FH(119.74,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO D2
SET WRD=+Y
S0 SET X="N"
IF 'WRD
READ !!,"SUMMARY only? Y// ",X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
SET X="Y"
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7," Answer YES or NO"
GOTO S0
+1 SET SUM=X?1"Y".E
L0 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^FHNO6"
SET FHLST="XX^WRD^SUM"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Print Supplemental Feeding Cost Report
+1 SET (FHSUMHD,FHSUM)=0
DO NOW^%DTC
SET DTP=%
DO DTP^FH
SET PTIM=DTP
SET PG=0
KILL ^TMP($JOB)
+2 IF 'SUM
IF 'WRD
SET FHSUM=1
+3 FOR KK=0:0
SET KK=$ORDER(^FH(119.6,KK))
if KK<1
QUIT
SET X0=$GET(^(KK,0))
Begin DoDot:1
+4 IF XX="W"
IF WRD
IF WRD'=KK
QUIT
+5 IF XX="S"
IF WRD
IF $PIECE(X0,"^",9)'=WRD
QUIT
+6 SET P0=$PIECE(X0,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
SET TNOD=$SELECT(SUM:"0",XX="S":"99~"_$PIECE($GET(^FH(119.74,+$PIECE(X0,"^",9),0)),"^",1),1:P0_"~"_$PIECE(X0,"^",1))
+7 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",KK,FHDFN))
if FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",KK,FHDFN))
IF ADM>0
Begin DoDot:2
+8 SET $PIECE(^TMP($JOB,"T",TNOD,0),"^",1)=$PIECE($GET(^TMP($JOB,"T",TNOD,0)),"^",1)+1
+9 IF FHSUM
SET $PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",1)=$PIECE($GET(^TMP($JOB,"FH","GRAND TOTAL",0)),"^",1)+1
+10 SET (NO,Y)=""
IF $DATA(^FHPT(FHDFN,"A",ADM,0))
SET NO=$PIECE(^(0),"^",7)
+11 if 'NO
QUIT
SET Y=$GET(^FHPT(FHDFN,"A",ADM,"SF",NO,0))
+12 SET PD=$PIECE(Y,"^",29)
if PD=""
SET PD="D"
+13 SET $PIECE(^TMP($JOB,"T",TNOD,0),"^",PD'="D"+2)=$PIECE(^TMP($JOB,"T",TNOD,0),"^",PD'="D"+2)+1
+14 IF FHSUM
SET $PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
+15 FOR L=5:2:28
SET Z=$PIECE(Y,"^",L)
SET Q=$PIECE(Y,"^",L+1)
IF Z'=""
if 'Q
SET Q=1
if '$DATA(^TMP($JOB,"T",TNOD,Z,PD))
SET ^TMP($JOB,"T",TNOD,Z,PD)=0
SET ^(PD)=^(PD)+Q
IF FHSUM
Begin DoDot:3
+16 if '$DATA(^TMP($JOB,"FH","GRAND TOTAL",Z,PD))
SET ^TMP($JOB,"FH","GRAND TOTAL",Z,PD)=0
SET ^(PD)=^(PD)+Q
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 ;
+20 SET NAM=""
FOR
SET NAM=$ORDER(^FH(118,"B",NAM))
if NAM=""
QUIT
FOR Z=0:0
SET Z=$ORDER(^FH(118,"B",NAM,Z))
if Z<1
QUIT
IF $ORDER(^(Z,0))=""
SET REC=$PIECE($GET(^FH(118,Z,0)),"^",7)
SET CU=$PIECE($GET(^FH(114,+REC,0)),"^",13)
SET ^TMP($JOB,"P",NAM_"~"_Z)=CU
+21 SET TNOD=""
FOR
SET TNOD=$ORDER(^TMP($JOB,"T",TNOD))
if TNOD=""
QUIT
Begin DoDot:1
+22 SET FHOUT=0
+23 if $ORDER(^TMP($JOB,"T",TNOD,0))=""
QUIT
DO HDR
SET (T1,T2)=0
+24 SET NAM=""
FOR
SET NAM=$ORDER(^TMP($JOB,"P",NAM))
if NAM=""
QUIT
SET CU=^(NAM)
Begin DoDot:2
+25 SET Z=$PIECE(NAM,"~",2)
IF '$DATA(^TMP($JOB,"T",TNOD,Z))
QUIT
+26 SET A1=$GET(^TMP($JOB,"T",TNOD,Z,"D"))
SET A2=$GET(^("T"))
SET T1=A1*CU+T1
SET T2=A2*CU+T2
if $Y>(IOSL-8)
DO HDR
+27 WRITE !,$EXTRACT($PIECE(NAM,"~",1),1,24),?25,$JUSTIFY(CU,7,3),$JUSTIFY(A1,7),$JUSTIFY(A1*CU,8,2),$JUSTIFY(A2,8),$JUSTIFY(A2*CU,8,2),$JUSTIFY(A1+A2,8),$JUSTIFY(A1+A2*CU,8,2)
QUIT
End DoDot:2
+28 if $Y>(IOSL-13)
DO HDR
WRITE !!,"Total",?39,$JUSTIFY(T1,8,2),$JUSTIFY(T2,16,2),$JUSTIFY(T1+T2,16,2)
+29 SET CTR=$GET(^TMP($JOB,"T",TNOD,0))
SET WP=$PIECE(CTR,"^",1)
SET WPD=$PIECE(CTR,"^",2)
SET WPT=$PIECE(CTR,"^",3)
+30 WRITE !!,"Cost/Patient:",?32,$JUSTIFY(WP,7),?39,$JUSTIFY(T1/WP,8,2),?47,$JUSTIFY(WP,8),?55,$JUSTIFY(T2/WP,8,2),?63,$JUSTIFY(WP,8),?71,$JUSTIFY(T1+T2/WP,8,2)
+31 WRITE !,"Cost/Recipient:"
if WPD
WRITE ?32,$JUSTIFY(WPD,7),?39,$JUSTIFY(T1/WPD,8,2)
if WPT
WRITE ?47,$JUSTIFY(WPT,8),?55,$JUSTIFY(T2/WPT,8,2)
if (WPD+WPT)
WRITE ?63,$JUSTIFY(WPD+WPT,8),?71,$JUSTIFY(T1+T2/(WPD+WPT),8,2)
+32 WRITE !!,"Recipient %:"
if WPD
WRITE ?39,$JUSTIFY(WPD/WP*100,8,0)
if WPT
WRITE ?55,$JUSTIFY(WPT/WP*100,8,0)
if (WPD+WPT)
WRITE ?71,$JUSTIFY(WPD+WPT/WP*100,8,0)
WRITE !
QUIT
End DoDot:1
+33 IF FHSUM
DO GRD
+34 ;
SFO ;process outpt SFs.
+1 KILL ^TMP($JOB)
SET (FHSUM,FHSUMHD)=0
+2 SET FHDFNSV=""
SET FHOUT=1
+3 IF 'SUM
IF 'WRD
SET FHSUM=1
+4 FOR FHI=DT-1:0
SET FHI=$ORDER(^FHPT("RM",FHI))
if (FHI'>0)!(FHI>DT)
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHI,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:1
+5 FOR FHJ=0:0
SET FHJ=$ORDER(^FHPT("RM",FHI,FHDFN,FHJ))
if FHJ'>0
QUIT
IF ($PIECE($GET(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C")
Begin DoDot:2
+6 SET FHDA15=$GET(^FHPT(FHDFN,"OP",FHJ,0))
+7 SET FHMEAL=$PIECE(FHDA15,U,4)
SET FHLOC=$PIECE(FHDA15,U,3)
if '$GET(FHLOC)
QUIT
+8 SET FHLOX0=$GET(^FH(119.6,FHLOC,0))
+9 IF XX="W"
IF WRD
IF WRD'=FHLOC
QUIT
+10 IF XX="S"
IF WRD
IF $PIECE(FHLOX0,"^",9)'=WRD
QUIT
+11 SET P0=$PIECE(FHLOX0,"^",4)
SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
SET TNOD=$SELECT(SUM:"0",XX="S":"99~"_$PIECE($GET(^FH(119.74,+$PIECE(FHLOX0,"^",9),0)),"^",1),1:P0_"~"_$PIECE(FHLOX0,"^",1))
+12 ;I FHDFNSV'=FHDFN S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
+13 SET $PIECE(^TMP($JOB,"T",TNOD,0),"^",1)=$PIECE($GET(^TMP($JOB,"T",TNOD,0)),"^",1)+1
+14 IF FHSUM
SET $PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",1)=$PIECE($GET(^TMP($JOB,"FH","GRAND TOTAL",0)),"^",1)+1
+15 if $DATA(^FHPT(FHDFN,"OP",FHJ,"SF",0))
SET FHSF=$PIECE(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
+16 if '$GET(FHSF)
QUIT
+17 SET FHDA15SF=$GET(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
+18 if $PIECE(FHDA15SF,U,32)
QUIT
+19 SET PD=$PIECE(FHDA15SF,"^",29)
if PD=""
SET PD="D"
+20 ;S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
+21 SET $PIECE(^TMP($JOB,"T",TNOD,0),"^",PD'="D"+2)=$PIECE(^TMP($JOB,"T",TNOD,0),"^",PD'="D"+2)+1
+22 IF FHSUM
SET $PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$PIECE(^TMP($JOB,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
+23 FOR L=5:2:28
SET Z=$PIECE(FHDA15SF,"^",L)
SET Q=$PIECE(FHDA15SF,"^",L+1)
IF Z'=""
if 'Q
SET Q=1
if '$DATA(^TMP($JOB,"T",TNOD,Z,PD))
SET ^TMP($JOB,"T",TNOD,Z,PD)=0
SET ^(PD)=^(PD)+Q
IF FHSUM
Begin DoDot:3
+24 if '$DATA(^TMP($JOB,"FH","GRAND TOTAL",Z,PD))
SET ^TMP($JOB,"FH","GRAND TOTAL",Z,PD)=0
SET ^(PD)=^(PD)+Q
End DoDot:3
+25 SET FHDFNSV=FHDFN
End DoDot:2
End DoDot:1
+26 ;
+27 SET NAM=""
FOR
SET NAM=$ORDER(^FH(118,"B",NAM))
if NAM=""
QUIT
FOR Z=0:0
SET Z=$ORDER(^FH(118,"B",NAM,Z))
if Z<1
QUIT
IF $ORDER(^(Z,0))=""
SET REC=$PIECE($GET(^FH(118,Z,0)),"^",7)
SET CU=$PIECE($GET(^FH(114,+REC,0)),"^",13)
SET ^TMP($JOB,"P",NAM_"~"_Z)=CU
+28 SET TNOD=""
FOR
SET TNOD=$ORDER(^TMP($JOB,"T",TNOD))
if TNOD=""
QUIT
Begin DoDot:1
+29 if $ORDER(^TMP($JOB,"T",TNOD,0))=""
QUIT
DO HDR
SET (T1,T2)=0
+30 SET NAM=""
FOR
SET NAM=$ORDER(^TMP($JOB,"P",NAM))
if NAM=""
QUIT
SET CU=^(NAM)
Begin DoDot:2
+31 SET Z=$PIECE(NAM,"~",2)
IF '$DATA(^TMP($JOB,"T",TNOD,Z))
QUIT
+32 SET A1=$GET(^TMP($JOB,"T",TNOD,Z,"D"))
SET A2=$GET(^("T"))
SET T1=A1*CU+T1
SET T2=A2*CU+T2
if $Y>(IOSL-8)
DO HDR
+33 WRITE !,$EXTRACT($PIECE(NAM,"~",1),1,24),?25,$JUSTIFY(CU,7,3),$JUSTIFY(A1,7),$JUSTIFY(A1*CU,8,2),$JUSTIFY(A2,8),$JUSTIFY(A2*CU,8,2),$JUSTIFY(A1+A2,8),$JUSTIFY(A1+A2*CU,8,2)
QUIT
End DoDot:2
+34 if $Y>(IOSL-13)
DO HDR
WRITE !!,"Total",?39,$JUSTIFY(T1,8,2),$JUSTIFY(T2,16,2),$JUSTIFY(T1+T2,16,2)
+35 SET CTR=$GET(^TMP($JOB,"T",TNOD,0))
SET WP=$PIECE(CTR,"^",1)
SET WPD=$PIECE(CTR,"^",2)
SET WPT=$PIECE(CTR,"^",3)
+36 WRITE !!,"SF Cost/Patient Meal:",?32,$JUSTIFY(WP,7),?39,$JUSTIFY(T1/WP,8,2),?47,$JUSTIFY(WP,8),?55,$JUSTIFY(T2/WP,8,2),?63,$JUSTIFY(WP,8),?71,$JUSTIFY(T1+T2/WP,8,2)
+37 WRITE !,"SF Cost/Recipient Meal:"
if WPD
WRITE ?32,$JUSTIFY(WPD,7),?39,$JUSTIFY(T1/WPD,8,2)
if WPT
WRITE ?47,$JUSTIFY(WPT,8),?55,$JUSTIFY(T2/WPT,8,2)
if (WPD+WPT)
WRITE ?63,$JUSTIFY(WPD+WPT,8),?71,$JUSTIFY(T1+T2/(WPD+WPT),8,2)
+38 WRITE !!,"Recipient Meal %:"
if WPD
WRITE ?39,$JUSTIFY(WPD/WP*100,8,0)
if WPT
WRITE ?55,$JUSTIFY(WPT/WP*100,8,0)
if (WPD+WPT)
WRITE ?71,$JUSTIFY(WPD+WPT/WP*100,8,0)
WRITE !
QUIT
End DoDot:1
+39 IF FHSUM
DO OGRD
+40 QUIT
GRD SET NAM=""
FOR
SET NAM=$ORDER(^FH(118,"B",NAM))
if NAM=""
QUIT
FOR Z=0:0
SET Z=$ORDER(^FH(118,"B",NAM,Z))
if Z<1
QUIT
IF $ORDER(^(Z,0))=""
SET REC=$PIECE($GET(^FH(118,Z,0)),"^",7)
SET CU=$PIECE($GET(^FH(114,+REC,0)),"^",13)
SET ^TMP($JOB,"P",NAM_"~"_Z)=CU
+1 SET FHSUMHD=1
+2 SET TNOD=""
FOR
SET TNOD=$ORDER(^TMP($JOB,"FH",TNOD))
if TNOD=""
QUIT
Begin DoDot:1
+3 SET FHOUT=0
+4 if $ORDER(^TMP($JOB,"FH",TNOD,0))=""
QUIT
DO HDR
SET (T1,T2)=0
+5 SET NAM=""
FOR
SET NAM=$ORDER(^TMP($JOB,"P",NAM))
if NAM=""
QUIT
SET CU=^(NAM)
Begin DoDot:2
+6 SET Z=$PIECE(NAM,"~",2)
IF '$DATA(^TMP($JOB,"FH",TNOD,Z))
QUIT
+7 SET A1=$GET(^TMP($JOB,"FH",TNOD,Z,"D"))
SET A2=$GET(^("T"))
SET T1=A1*CU+T1
SET T2=A2*CU+T2
if $Y>(IOSL-8)
DO HDR
+8 WRITE !,$EXTRACT($PIECE(NAM,"~",1),1,24),?25,$JUSTIFY(CU,7,3),$JUSTIFY(A1,7),$JUSTIFY(A1*CU,8,2),$JUSTIFY(A2,8),$JUSTIFY(A2*CU,8,2),$JUSTIFY(A1+A2,8),$JUSTIFY(A1+A2*CU,8,2)
QUIT
End DoDot:2
+9 if $Y>(IOSL-13)
DO HDR
WRITE !!,"Grand Total",?39,$JUSTIFY(T1,8,2),$JUSTIFY(T2,16,2),$JUSTIFY(T1+T2,16,2)
+10 SET CTR=$GET(^TMP($JOB,"FH",TNOD,0))
SET WP=$PIECE(CTR,"^",1)
SET WPD=$PIECE(CTR,"^",2)
SET WPT=$PIECE(CTR,"^",3)
+11 WRITE !!,"Cost/Patient:",?32,$JUSTIFY(WP,7),?39,$JUSTIFY(T1/WP,8,2),?47,$JUSTIFY(WP,8),?55,$JUSTIFY(T2/WP,8,2),?63,$JUSTIFY(WP,8),?71,$JUSTIFY(T1+T2/WP,8,2)
+12 WRITE !,"Cost/Recipient:"
if WPD
WRITE ?32,$JUSTIFY(WPD,7),?39,$JUSTIFY(T1/WPD,8,2)
if WPT
WRITE ?47,$JUSTIFY(WPT,8),?55,$JUSTIFY(T2/WPT,8,2)
if (WPD+WPT)
WRITE ?63,$JUSTIFY(WPD+WPT,8),?71,$JUSTIFY(T1+T2/(WPD+WPT),8,2)
+13 WRITE !!,"Recipient %:"
if WPD
WRITE ?39,$JUSTIFY(WPD/WP*100,8,0)
if WPT
WRITE ?55,$JUSTIFY(WPT/WP*100,8,0)
if (WPD+WPT)
WRITE ?71,$JUSTIFY(WPD+WPT/WP*100,8,0)
WRITE !
QUIT
End DoDot:1
+14 QUIT
+15 ;
OGRD SET NAM=""
FOR
SET NAM=$ORDER(^FH(118,"B",NAM))
if NAM=""
QUIT
FOR Z=0:0
SET Z=$ORDER(^FH(118,"B",NAM,Z))
if Z<1
QUIT
IF $ORDER(^(Z,0))=""
SET REC=$PIECE($GET(^FH(118,Z,0)),"^",7)
SET CU=$PIECE($GET(^FH(114,+REC,0)),"^",13)
SET ^TMP($JOB,"P",NAM_"~"_Z)=CU
+1 SET FHSUMHD=1
+2 SET TNOD=""
FOR
SET TNOD=$ORDER(^TMP($JOB,"FH",TNOD))
if TNOD=""
QUIT
Begin DoDot:1
+3 if $ORDER(^TMP($JOB,"FH",TNOD,0))=""
QUIT
DO HDR
SET (T1,T2)=0
+4 SET NAM=""
FOR
SET NAM=$ORDER(^TMP($JOB,"P",NAM))
if NAM=""
QUIT
SET CU=^(NAM)
Begin DoDot:2
+5 SET Z=$PIECE(NAM,"~",2)
IF '$DATA(^TMP($JOB,"FH",TNOD,Z))
QUIT
+6 SET A1=$GET(^TMP($JOB,"FH",TNOD,Z,"D"))
SET A2=$GET(^("T"))
SET T1=A1*CU+T1
SET T2=A2*CU+T2
if $Y>(IOSL-8)
DO HDR
+7 WRITE !,$EXTRACT($PIECE(NAM,"~",1),1,24),?25,$JUSTIFY(CU,7,3),$JUSTIFY(A1,7),$JUSTIFY(A1*CU,8,2),$JUSTIFY(A2,8),$JUSTIFY(A2*CU,8,2),$JUSTIFY(A1+A2,8),$JUSTIFY(A1+A2*CU,8,2)
QUIT
End DoDot:2
+8 if $Y>(IOSL-13)
DO HDR
WRITE !!,"Grand Total",?39,$JUSTIFY(T1,8,2),$JUSTIFY(T2,16,2),$JUSTIFY(T1+T2,16,2)
+9 SET CTR=$GET(^TMP($JOB,"FH",TNOD,0))
SET WP=$PIECE(CTR,"^",1)
SET WPD=$PIECE(CTR,"^",2)
SET WPT=$PIECE(CTR,"^",3)
+10 WRITE !!,"SF Cost/Patient Meal:",?32,$JUSTIFY(WP,7),?39,$JUSTIFY(T1/WP,8,2),?47,$JUSTIFY(WP,8),?55,$JUSTIFY(T2/WP,8,2),?63,$JUSTIFY(WP,8),?71,$JUSTIFY(T1+T2/WP,8,2)
+11 WRITE !,"SF Cost/Recipient Meal:"
if WPD
WRITE ?32,$JUSTIFY(WPD,7),?39,$JUSTIFY(T1/WPD,8,2)
if WPT
WRITE ?47,$JUSTIFY(WPT,8),?55,$JUSTIFY(T2/WPT,8,2)
if (WPD+WPT)
WRITE ?63,$JUSTIFY(WPD+WPT,8),?71,$JUSTIFY(T1+T2/(WPD+WPT),8,2)
+12 WRITE !!,"Recipient Meal %:"
if WPD
WRITE ?39,$JUSTIFY(WPD/WP*100,8,0)
if WPT
WRITE ?55,$JUSTIFY(WPT/WP*100,8,0)
if (WPD+WPT)
WRITE ?71,$JUSTIFY(WPD+WPT/WP*100,8,0)
WRITE !
QUIT
End DoDot:1
+13 QUIT
+14 ;
HDR ; Print Header
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+2 WRITE !,PTIM,!!?11,"S U P P L E M E N T A L F E E D I N G C O S T S",?73,"Page ",PG
+3 WRITE !!,$SELECT(FHOUT=1:"***OUTPATIENT***",1:"***INPATIENT***")
+4 IF 'FHSUMHD
SET Y=$SELECT(SUM:"CONSOLIDATED",1:$PIECE(TNOD,"~",2))
WRITE ?(80-$LENGTH(Y)\2),Y
+5 IF FHSUMHD
SET Y="GRAND TOTAL"
WRITE ?(80-$LENGTH(Y)\2),Y
+6 WRITE !!?38,"DIETARY",?52,"THERAPEUTIC",?71,"TOTAL",!,"Supplemental Feeding",?28,"Cost Qty Total Qty Total Qty Total",!
QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
