- FHPRC8 ; HISC/REL - Print Daily Diet Menus ;1/23/98 16:10
- ;;5.5;DIETETICS;;Jan 28, 2005
- S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G F1
- F0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
- K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 F0 S FHP=+Y
- F1 S %DT("A")="Select Date: ",%DT="AEX" W ! D ^%DT G:"^"[X!$D(DTOUT) KIL G:Y<1 F1 S D1=+Y
- L0 W !!,"The Menu requires a 132 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^FHPRC8",FHLST="D1^FHP" D EN2^FH G F1
- U IO D Q1 D ^%ZISC K %ZIS,IOP G F1
- Q1 ; Print the Daily Menu
- D ^FHDEV S X=220 X ^%ZOSF("RM") K ^TMP($J) S X1=D1 D SET
- Q:'$D(^TMP($J)) D NOW^%DTC S NOW=%,PG=0,DTP=D1 D DTP^FH S DTE=DTP,DTP=NOW D DTP^FH
- S X=D1 D DOW^%DTC S DTE=$P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",Y+1)_"day "_DTE
- S TYP=$P($G(^FH(119.71,FHP,0)),"^",2) W @FHIO("P16") D PRT 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,D1,0)) S X=^(0) F K3=2:1:4 I $P(X,"^",K3) S $P(X2,"^",K3)=$P(X,"^",K3)
- S RG=$P(^FH(116.2,1,0),"^",2)
- K M,M1 F K=0:0 S K=$O(^FH(116.2,K)) Q:K<1 S X=^(K,0),PD=$P(X,"^",2) I PD'="",K=1!($P(X,"^",7)="Y") S K4=$P(X,"^",6),K4=$S(K4<1:99,K4<10:"0"_K4,1:K4) S M(PD)=K4_PD,M1(K4_PD)=K
- S REG=M(RG)
- F K3=1:1:3 S X=$P(X2,"^",K3+1) I X D S1
- K M Q
- S1 K ^TMP($J,"R") F P1=0:0 S P1=$O(^FH(116.1,X,"RE",P1)) Q:P1<1 S Y0=^(P1,0) D S2
- S P1=0,NX="" F K=0:0 S NX=$O(^TMP($J,"R",NX)) Q:NX="" S X=^(NX) D S3
- K Y,Y0 Q
- S2 S L1=+Y0,Y=$G(^FH(114,L1,0)) Q:Y=""
- F CAT=0:0 S CAT=$O(^FH(116.1,X,"RE",P1,"R",CAT)) Q:CAT<1 S MCA=^(CAT,0) D
- .S K4=+MCA,K4=$P($G(^FH(114.1,+K4,0)),"^",3)
- .S K4=$S(K4<1:99,K4<10:"0"_K4,1:K4)_+MCA
- .S ^TMP($J,"R","A"_K4_$P(Y,"^",1))=$P(Y,"^",1)_"^"_$P(MCA,"^",2)_"^"_$P(Y,"^",3) Q
- Q
- S3 S L1=$P(X,"^",1),X1=$P(X,"^",2),P1=P1+1
- S P0=0 I X1[RG S:'$D(^TMP($J,"X",K3,REG,0)) ^TMP($J,"X",K3,REG,0)=0 S P0=^(0)+1,^(0)=P0,^TMP($J,"X",K3,REG,P0)=L1_"^"_$P(X,"^",3)
- F K4=1:1 S Z=$E($P(X1," ",K4),1,2) Q:Z="" I Z'=RG S Z=$S($D(M(Z)):M(Z),1:"") I Z'="" S:'$D(^TMP($J,"X",K3,Z,0)) ^TMP($J,"X",K3,Z,0)=0 S P2=^(0)+1,^(0)=P2,^TMP($J,"X",K3,Z,P2)=L1_"^"_P0
- Q
- PRT K M2 S N1=0,NX="" F K=0:0 S NX=$O(M1(NX)) Q:NX="" I NX'=REG S N1=N1+1,M2(N1)=NX
- S L2=0
- P0 Q:L2=N1 S L1=L2+1,L2=L1+4 S:L2>N1 L2=N1 D HDR F K3=1:1:3 S P1=0 D P1
- W ! G P0
- P1 S P1=P1+1,C=0,Y="|",NX="" S X=$G(^TMP($J,"X",K3,REG,P1)) S:X'="" C=1 S:X'=""&(TYP'="Y") X=$J(P1,2)_" "_X S Y=Y_" "_$E($P(X,"^",1)_$J("",30),1,30)_" | "_$E($P(X,"^",2)_$J("",15),1,15)_" |"
- F K4=L1:1:L2 S NX=M2(K4),X="",P2=0 S:$D(^TMP($J,"X",K3,NX,P1)) X=^(P1),P2=$P(X,"^",2),X=$P(X,"^",1),C=1 S:P2&(TYP'="Y") X=P2 S Y=Y_" "_$E(X_$J("",30),1,30)_" |"
- I C W !,Y G P1
- W !,LN Q
- HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,DTP,?90,"D A I L Y D I E T M E N U S",?210,"Page ",PG,!!?(216-$L(DTE)\2),DTE
- W !!?2,"REGULAR",?35,"Portion Size" S KK=20 F K4=L1:1:L2 S NX=$E(M2(K4),3,4),NX=$O(^FH(116.2,"C",NX,0)),X=$P($G(^FH(116.2,+NX,0)),"^",1) S KK=KK+33 W ?KK,$E(X,1,30)
- S LN="",$P(LN,"-",L2-L1+1*33+53)="" W !,LN Q
- KIL K ^TMP($J) G KILL^XUSCLEAN
- FHPRC8 ; HISC/REL - Print Daily Diet Menus ;1/23/98 16:10
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET FHP=$ORDER(^FH(119.71,0))
- IF FHP'<1
- IF $ORDER(^FH(119.71,FHP))<1
- GOTO F1
- F0 READ !!,"Select PRODUCTION FACILITY: ",X:DTIME
- IF '$TEST!("^"[X)
- GOTO KIL
- +1 KILL DIC
- SET DIC="^FH(119.71,"
- SET DIC(0)="EMQ"
- DO ^DIC
- IF Y<1
- GOTO F0
- SET FHP=+Y
- F1 SET %DT("A")="Select Date: "
- SET %DT="AEX"
- WRITE !
- DO ^%DT
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO F1
- SET D1=+Y
- L0 WRITE !!,"The Menu requires a 132 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^FHPRC8"
- SET FHLST="D1^FHP"
- DO EN2^FH
- GOTO F1
- +3 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO F1
- Q1 ; Print the Daily Menu
- +1 DO ^FHDEV
- SET X=220
- XECUTE ^%ZOSF("RM")
- KILL ^TMP($JOB)
- SET X1=D1
- DO SET
- +2 IF '$DATA(^TMP($JOB))
- QUIT
- DO NOW^%DTC
- SET NOW=%
- SET PG=0
- SET DTP=D1
- DO DTP^FH
- SET DTE=DTP
- SET DTP=NOW
- DO DTP^FH
- +3 SET X=D1
- DO DOW^%DTC
- SET DTE=$PIECE("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",Y+1)_"day "_DTE
- +4 SET TYP=$PIECE($GET(^FH(119.71,FHP,0)),"^",2)
- WRITE @FHIO("P16")
- DO PRT
- 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,D1,0))
- SET X=^(0)
- FOR K3=2:1:4
- IF $PIECE(X,"^",K3)
- SET $PIECE(X2,"^",K3)=$PIECE(X,"^",K3)
- +2 SET RG=$PIECE(^FH(116.2,1,0),"^",2)
- +3 KILL M,M1
- FOR K=0:0
- SET K=$ORDER(^FH(116.2,K))
- IF K<1
- QUIT
- SET X=^(K,0)
- SET PD=$PIECE(X,"^",2)
- IF PD'=""
- IF K=1!($PIECE(X,"^",7)="Y")
- SET K4=$PIECE(X,"^",6)
- SET K4=$SELECT(K4<1:99,K4<10:"0"_K4,1:K4)
- SET M(PD)=K4_PD
- SET M1(K4_PD)=K
- +4 SET REG=M(RG)
- +5 FOR K3=1:1:3
- SET X=$PIECE(X2,"^",K3+1)
- IF X
- DO S1
- +6 KILL M
- QUIT
- S1 KILL ^TMP($JOB,"R")
- FOR P1=0:0
- SET P1=$ORDER(^FH(116.1,X,"RE",P1))
- IF P1<1
- QUIT
- SET Y0=^(P1,0)
- DO S2
- +1 SET P1=0
- SET NX=""
- FOR K=0:0
- SET NX=$ORDER(^TMP($JOB,"R",NX))
- IF NX=""
- QUIT
- SET X=^(NX)
- DO S3
- +2 KILL Y,Y0
- QUIT
- S2 SET L1=+Y0
- SET Y=$GET(^FH(114,L1,0))
- IF Y=""
- QUIT
- +1 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,X,"RE",P1,"R",CAT))
- IF CAT<1
- QUIT
- SET MCA=^(CAT,0)
- Begin DoDot:1
- +2 SET K4=+MCA
- SET K4=$PIECE($GET(^FH(114.1,+K4,0)),"^",3)
- +3 SET K4=$SELECT(K4<1:99,K4<10:"0"_K4,1:K4)_+MCA
- +4 SET ^TMP($JOB,"R","A"_K4_$PIECE(Y,"^",1))=$PIECE(Y,"^",1)_"^"_$PIECE(MCA,"^",2)_"^"_$PIECE(Y,"^",3)
- QUIT
- End DoDot:1
- +5 QUIT
- S3 SET L1=$PIECE(X,"^",1)
- SET X1=$PIECE(X,"^",2)
- SET P1=P1+1
- +1 SET P0=0
- IF X1[RG
- IF '$DATA(^TMP($JOB,"X",K3,REG,0))
- SET ^TMP($JOB,"X",K3,REG,0)=0
- SET P0=^(0)+1
- SET ^(0)=P0
- SET ^TMP($JOB,"X",K3,REG,P0)=L1_"^"_$PIECE(X,"^",3)
- +2 FOR K4=1:1
- SET Z=$EXTRACT($PIECE(X1," ",K4),1,2)
- IF Z=""
- QUIT
- IF Z'=RG
- SET Z=$SELECT($DATA(M(Z)):M(Z),1:"")
- IF Z'=""
- IF '$DATA(^TMP($JOB,"X",K3,Z,0))
- SET ^TMP($JOB,"X",K3,Z,0)=0
- SET P2=^(0)+1
- SET ^(0)=P2
- SET ^TMP($JOB,"X",K3,Z,P2)=L1_"^"_P0
- +3 QUIT
- PRT KILL M2
- SET N1=0
- SET NX=""
- FOR K=0:0
- SET NX=$ORDER(M1(NX))
- IF NX=""
- QUIT
- IF NX'=REG
- SET N1=N1+1
- SET M2(N1)=NX
- +1 SET L2=0
- P0 IF L2=N1
- QUIT
- SET L1=L2+1
- SET L2=L1+4
- IF L2>N1
- SET L2=N1
- DO HDR
- FOR K3=1:1:3
- SET P1=0
- DO P1
- +1 WRITE !
- GOTO P0
- P1 SET P1=P1+1
- SET C=0
- SET Y="|"
- SET NX=""
- SET X=$GET(^TMP($JOB,"X",K3,REG,P1))
- IF X'=""
- SET C=1
- IF X'=""&(TYP'="Y")
- SET X=$JUSTIFY(P1,2)_" "_X
- SET Y=Y_" "_$EXTRACT($PIECE(X,"^",1)_$JUSTIFY("",30),1,30)_" | "_$EXTRACT($PIECE(X,"^",2)_$JUSTIFY("",15),1,15)_" |"
- +1 FOR K4=L1:1:L2
- SET NX=M2(K4)
- SET X=""
- SET P2=0
- IF $DATA(^TMP($JOB,"X",K3,NX,P1))
- SET X=^(P1)
- SET P2=$PIECE(X,"^",2)
- SET X=$PIECE(X,"^",1)
- SET C=1
- IF P2&(TYP'="Y")
- SET X=P2
- SET Y=Y_" "_$EXTRACT(X_$JUSTIFY("",30),1,30)_" |"
- +2 IF C
- WRITE !,Y
- GOTO P1
- +3 WRITE !,LN
- QUIT
- HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !,DTP,?90,"D A I L Y D I E T M E N U S",?210,"Page ",PG,!!?(216-$LENGTH(DTE)\2),DTE
- +1 WRITE !!?2,"REGULAR",?35,"Portion Size"
- SET KK=20
- FOR K4=L1:1:L2
- SET NX=$EXTRACT(M2(K4),3,4)
- SET NX=$ORDER(^FH(116.2,"C",NX,0))
- SET X=$PIECE($GET(^FH(116.2,+NX,0)),"^",1)
- SET KK=KK+33
- WRITE ?KK,$EXTRACT(X,1,30)
- +2 SET LN=""
- SET $PIECE(LN,"-",L2-L1+1*33+53)=""
- WRITE !,LN
- QUIT
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
