FHPRC7 ; HISC/REL - Find Meals Containing a Recipe ;4/26/93 15:53
;;5.5;DIETETICS;;Jan 28, 2005
S (DIC,DIE)="^FH(114,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:U[X!$D(DTOUT),FHPRC7:Y<1 S FHX1=+Y
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^FHPRC7",FHLST="FHX1" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; List Meals Containing a Recipe
K ^TMP($J) D NOW^%DTC S DTP=% D DTP^FH
F M1=0:0 S M1=$O(^FH(116.1,M1)) Q:M1<1 F R1=0:0 S R1=$O(^FH(116.1,M1,"RE",R1)) Q:R1<1 S X=+$G(^FH(116.1,M1,"RE",R1,0)) S:X=FHX1 ^TMP($J,"M",M1)=""
F C1=0:0 S C1=$O(^FH(116,C1)) Q:C1<1 F D1=0:0 S D1=$O(^FH(116,C1,"DA",D1)) Q:D1<1 D Q2
S N1=$P(^FH(114,FHX1,0),"^",1),PG=0,LN="",$P(LN,"-",80)="" D HDR,P0
W ! Q
Q2 S X=$G(^FH(116,C1,"DA",D1,0)) Q:X=""
F K1=1:1:3 S Z=$P(X,"^",K1+1) I Z,$D(^TMP($J,"M",Z)) S ^TMP($J,"M",Z,"C",C1_"~"_D1_"~"_K1)=""
Q
P0 F M1=0:0 S M1=$O(^TMP($J,"M",M1)) Q:M1<1 S X=$P($G(^FH(116.1,M1,0)),"^",1) I X'="" D:$Y>(IOSL-9) HDR W !,X D P1
Q
P1 S A1="" F C1=0:0 S A1=$O(^TMP($J,"M",M1,"C",A1)) Q:A1="" D P2
Q
P2 S C1=+A1,D1=$P(A1,"~",2),K1=$P(A1,"~",3)
W ?31,$P(^FH(116,C1,0),"^",1),", Day ",D1,", ",$S(K1=1:"Breakfast",K1=2:"Noon",1:"Evening"),! D:$Y>(IOSL-6) HDR Q
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,DTP,?28,"R E C I P E U S A G E",?73,"Page ",PG
W !!?(80-$L(N1)\2),N1
W !!,"Meal",?31,"Cycle",!,LN,! Q
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC7 1478 printed Apr 09, 2024@20:58:51 Page 2
FHPRC7 ; HISC/REL - Find Meals Containing a Recipe ;4/26/93 15:53
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET (DIC,DIE)="^FH(114,"
SET DIC(0)="AEQM"
WRITE !
DO ^DIC
KILL DIC
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO FHPRC7
SET FHX1=+Y
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^FHPRC7"
SET FHLST="FHX1"
DO EN2^FH
GOTO KIL
+2 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; List Meals Containing a Recipe
+1 KILL ^TMP($JOB)
DO NOW^%DTC
SET DTP=%
DO DTP^FH
+2 FOR M1=0:0
SET M1=$ORDER(^FH(116.1,M1))
if M1<1
QUIT
FOR R1=0:0
SET R1=$ORDER(^FH(116.1,M1,"RE",R1))
if R1<1
QUIT
SET X=+$GET(^FH(116.1,M1,"RE",R1,0))
if X=FHX1
SET ^TMP($JOB,"M",M1)=""
+3 FOR C1=0:0
SET C1=$ORDER(^FH(116,C1))
if C1<1
QUIT
FOR D1=0:0
SET D1=$ORDER(^FH(116,C1,"DA",D1))
if D1<1
QUIT
DO Q2
+4 SET N1=$PIECE(^FH(114,FHX1,0),"^",1)
SET PG=0
SET LN=""
SET $PIECE(LN,"-",80)=""
DO HDR
DO P0
+5 WRITE !
QUIT
Q2 SET X=$GET(^FH(116,C1,"DA",D1,0))
if X=""
QUIT
+1 FOR K1=1:1:3
SET Z=$PIECE(X,"^",K1+1)
IF Z
IF $DATA(^TMP($JOB,"M",Z))
SET ^TMP($JOB,"M",Z,"C",C1_"~"_D1_"~"_K1)=""
+2 QUIT
P0 FOR M1=0:0
SET M1=$ORDER(^TMP($JOB,"M",M1))
if M1<1
QUIT
SET X=$PIECE($GET(^FH(116.1,M1,0)),"^",1)
IF X'=""
if $Y>(IOSL-9)
DO HDR
WRITE !,X
DO P1
+1 QUIT
P1 SET A1=""
FOR C1=0:0
SET A1=$ORDER(^TMP($JOB,"M",M1,"C",A1))
if A1=""
QUIT
DO P2
+1 QUIT
P2 SET C1=+A1
SET D1=$PIECE(A1,"~",2)
SET K1=$PIECE(A1,"~",3)
+1 WRITE ?31,$PIECE(^FH(116,C1,0),"^",1),", Day ",D1,", ",$SELECT(K1=1:"Breakfast",K1=2:"Noon",1:"Evening"),!
if $Y>(IOSL-6)
DO HDR
QUIT
HDR if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
WRITE !,DTP,?28,"R E C I P E U S A G E",?73,"Page ",PG
+1 WRITE !!?(80-$LENGTH(N1)\2),N1
+2 WRITE !!,"Meal",?31,"Cycle",!,LN,!
QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
