FHPRC2 ; HISC/REL - List Weekly Menu ;1/23/98 16:09
;;5.5;DIETETICS;;Jan 28, 2005
F0 R !!,"Select PRODUCTION DIET (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHX1=0
E K DIC S DIC="^FH(116.2,",DIC(0)="EQM" D ^DIC G:Y<1 F0 S FHX1=+Y
F1 S %DT("A")="Select SUNDAY Date: ",%DT="AEX" D ^%DT Q:"^"[X!$D(DTOUT) G:Y<1 F1
S (D1,X)=Y D DOW^%DTC I Y'=0 W *7," .. Not a Sunday" G F1
L0 W !!,"The Menu requires a 132 column compressed printer.",!
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^FHPRC2",FHLST="D1^FHX1" D EN2^FH G F0
U IO D Q1 D ^%ZISC K %ZIS,IOP G F0
Q1 ; Print Weekly Menu
D ^FHDEV S X=220 X ^%ZOSF("RM") K D S D(1)=D1 F K=2:1:7 S X1=D(K-1),X2=1 D C^%DTC S D(K)=X
S PG=0 I FHX1 D Q2 Q
F NN=0:0 S NN=$O(^FH(116.2,"AP",NN)) Q:NN<1 F FHX1=0:0 S FHX1=$O(^FH(116.2,"AP",NN,FHX1)) Q:FHX1<1 D Q2
Q
Q2 S FHPD=$P(^FH(116.2,FHX1,0),"^",2) K ^TMP($J)
F KK=1:1:7 S X1=D(KK) D SET
Q:'$D(^TMP($J)) W @FHIO("P16") D HDR F K3=1:1:3 D PRT
W ! W @FHIO("P10") Q
SET D E1^FHPRC1 S X2="" I FHCY>0,$D(^FH(116,FHCY,"DA",FHDA,0)) S X2=^(0)
I $D(^FH(116.3,+D(KK),0)) S X=^(0) F K3=2:1:4 I $P(X,"^",K3) S $P(X2,"^",K3)=$P(X,"^",K3)
F K3=1:1:3 S X=$P(X2,"^",K3+1) I X D S1
Q
S1 K M F P1=0:0 S P1=$O(^FH(116.1,X,"RE",P1)) Q:P1<1 S L1=^(P1,0),L1=+L1,Y=^FH(114,L1,0) D
.F CAT=0:0 S CAT=$O(^FH(116.1,X,"RE",P1,"R",CAT)) Q:CAT<1 S MCA=$G(^(CAT,0)) I $P(MCA,"^",2)[FHPD D
..S K4=+MCA,K4=$P($G(^FH(114.1,+K4,0)),"^",3) S K4=$S('K4:99,K4<10:"0"_K4,1:K4),M("A"_K4_$P(Y,"^",1))=""
..Q
.Q
S P1=0,K4="" F L1=0:0 S K4=$O(M(K4)) Q:K4="" S P1=P1+1,^TMP($J,K3,KK,P1)=$E(K4,4,99)
K M,Y Q
PRT S P1=0
P1 S P1=P1+1,C=0,Y="|" F KK=1:1:7 S X="" S:$D(^TMP($J,K3,KK,P1)) X=^(P1),C=1 S Y=Y_" "_$E(X_$J("",27),1,27)_" |"
I C W !,Y G P1
W ! F P1=1:1:211 W "-"
Q
HDR S DTP=D1 D DTP^FH S Y=$P(^FH(116.2,FHX1,0),"^",1) W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W !?94,"W E E K L Y M E N U",!!?(210-$L(Y)\2),Y,!!?96,"Week Of ",DTP
W !!?2,"S U N D A Y",?32,"M O N D A Y",?62,"T U E S D A Y",?92,"W E D N E S D A Y",?122,"T H U R S D A Y",?152,"F R I D A Y",?182,"S A T U R D A Y",!
F K=1:1:211 W "-"
Q
KIL K ^TMP($J) G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC2 2251 printed Apr 09, 2024@21:01:08 Page 2
FHPRC2 ; HISC/REL - List Weekly Menu ;1/23/98 16:09
+1 ;;5.5;DIETETICS;;Jan 28, 2005
F0 READ !!,"Select PRODUCTION DIET (or ALL): ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
if X="all"
DO TR^FH
IF X="ALL"
SET FHX1=0
+1 IF '$TEST
KILL DIC
SET DIC="^FH(116.2,"
SET DIC(0)="EQM"
DO ^DIC
if Y<1
GOTO F0
SET FHX1=+Y
F1 SET %DT("A")="Select SUNDAY Date: "
SET %DT="AEX"
DO ^%DT
if "^"[X!$DATA(DTOUT)
QUIT
if Y<1
GOTO F1
+1 SET (D1,X)=Y
DO DOW^%DTC
IF Y'=0
WRITE *7," .. Not a Sunday"
GOTO F1
L0 WRITE !!,"The Menu requires a 132 column compressed printer.",!
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHPRC2"
SET FHLST="D1^FHX1"
DO EN2^FH
GOTO F0
+3 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO F0
Q1 ; Print Weekly Menu
+1 DO ^FHDEV
SET X=220
XECUTE ^%ZOSF("RM")
KILL D
SET D(1)=D1
FOR K=2:1:7
SET X1=D(K-1)
SET X2=1
DO C^%DTC
SET D(K)=X
+2 SET PG=0
IF FHX1
DO Q2
QUIT
+3 FOR NN=0:0
SET NN=$ORDER(^FH(116.2,"AP",NN))
if NN<1
QUIT
FOR FHX1=0:0
SET FHX1=$ORDER(^FH(116.2,"AP",NN,FHX1))
if FHX1<1
QUIT
DO Q2
+4 QUIT
Q2 SET FHPD=$PIECE(^FH(116.2,FHX1,0),"^",2)
KILL ^TMP($JOB)
+1 FOR KK=1:1:7
SET X1=D(KK)
DO SET
+2 if '$DATA(^TMP($JOB))
QUIT
WRITE @FHIO("P16")
DO HDR
FOR K3=1:1:3
DO PRT
+3 WRITE !
WRITE @FHIO("P10")
QUIT
SET DO E1^FHPRC1
SET X2=""
IF FHCY>0
IF $DATA(^FH(116,FHCY,"DA",FHDA,0))
SET X2=^(0)
+1 IF $DATA(^FH(116.3,+D(KK),0))
SET X=^(0)
FOR K3=2:1:4
IF $PIECE(X,"^",K3)
SET $PIECE(X2,"^",K3)=$PIECE(X,"^",K3)
+2 FOR K3=1:1:3
SET X=$PIECE(X2,"^",K3+1)
IF X
DO S1
+3 QUIT
S1 KILL M
FOR P1=0:0
SET P1=$ORDER(^FH(116.1,X,"RE",P1))
if P1<1
QUIT
SET L1=^(P1,0)
SET L1=+L1
SET Y=^FH(114,L1,0)
Begin DoDot:1
+1 FOR CAT=0:0
SET CAT=$ORDER(^FH(116.1,X,"RE",P1,"R",CAT))
if CAT<1
QUIT
SET MCA=$GET(^(CAT,0))
IF $PIECE(MCA,"^",2)[FHPD
Begin DoDot:2
+2 SET K4=+MCA
SET K4=$PIECE($GET(^FH(114.1,+K4,0)),"^",3)
SET K4=$SELECT('K4:99,K4<10:"0"_K4,1:K4)
SET M("A"_K4_$PIECE(Y,"^",1))=""
+3 QUIT
End DoDot:2
+4 QUIT
End DoDot:1
+5 SET P1=0
SET K4=""
FOR L1=0:0
SET K4=$ORDER(M(K4))
if K4=""
QUIT
SET P1=P1+1
SET ^TMP($JOB,K3,KK,P1)=$EXTRACT(K4,4,99)
+6 KILL M,Y
QUIT
PRT SET P1=0
P1 SET P1=P1+1
SET C=0
SET Y="|"
FOR KK=1:1:7
SET X=""
if $DATA(^TMP($JOB,K3,KK,P1))
SET X=^(P1)
SET C=1
SET Y=Y_" "_$EXTRACT(X_$JUSTIFY("",27),1,27)_" |"
+1 IF C
WRITE !,Y
GOTO P1
+2 WRITE !
FOR P1=1:1:211
WRITE "-"
+3 QUIT
HDR SET DTP=D1
DO DTP^FH
SET Y=$PIECE(^FH(116.2,FHX1,0),"^",1)
if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+1 WRITE !?94,"W E E K L Y M E N U",!!?(210-$LENGTH(Y)\2),Y,!!?96,"Week Of ",DTP
+2 WRITE !!?2,"S U N D A Y",?32,"M O N D A Y",?62,"T U E S D A Y",?92,"W E D N E S D A Y",?122,"T H U R S D A Y",?152,"F R I D A Y",?182,"S A T U R D A Y",!
+3 FOR K=1:1:211
WRITE "-"
+4 QUIT
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
