- FHPRC3 ; HISC/REL - List Meal ;4/12/95 13:56
- ;;5.5;DIETETICS;;Jan 28, 2005
- S DIC="^FH(116.1,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:U[X!$D(DTOUT),FHPRC3:Y<1 S FHMN=+Y
- K IOP S %ZIS="MQ",%ZIS("A")="Select Listing Device: ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q1^FHPRC3",FHLST="FHMN" D EN2^FH G FHPRC3
- U IO D Q1 D ^%ZISC K %ZIS,IOP G FHPRC3
- Q1 ; Print Meal
- S Y=^FH(116.1,FHMN,0),N1=$P(Y,"^",1) W:$E(IOST,1,2)="C-" @IOF
- W !!?(77-$L(N1)\2),"Meal: ",N1,!!,"Recipe",?28,"Cat.",?34,"Production Diets"
- K ^TMP($J)
- F M=0:0 S M=$O(^FH(116.1,FHMN,"RE",M)) Q:M<1 S Y=$G(^(M,0)),L1=+Y D Q2
- S K4="" F P0=0:0 S K4=$O(^TMP($J,K4)) Q:K4="" F L1=0:0 S L1=$O(^TMP($J,K4,L1)) Q:L1<1 S X=^(L1) D Q3
- W ! G KIL
- Q2 S X=$G(^FH(114,L1,0)),N1=$P(X,"^",1) Q:N1="" S MCA=$O(^FH(116.1,FHMN,"RE",M,"R",0)),K4=$S(MCA:+$G(^FH(116.1,FHMN,"RE",M,"R",MCA,0)),1:99)
- S K4=$S($D(^FH(114.1,+K4,0)):$P(^(0),"^",3),1:99)
- S K4=$S(K4<1:99,K4<10:"0"_K4,1:K4)_$E(N1,1,28)
- S ^TMP($J,K4,L1)=N1_"^"_M Q
- Q3 W !!,$E($P(X,"^",1),1,27) S M=$P(X,"^",2)
- F CAT=0:0 S CAT=$O(^FH(116.1,FHMN,"RE",M,"R",CAT)) Q:CAT<1 S MCA=$G(^(CAT,0)),CODE=+MCA D
- .S CODE=$P($G(^FH(114.1,+CODE,0)),"^",2) D SRT
- .W ?29,$J(CODE,3) S X=$E(PD,1,200) D Q4 W !
- .Q
- G Q5
- Q4 I $L(X)<44 W ?34,X Q
- F N1=44:-1:1 Q:$E(X,N1)=" "
- W ?34,$E(X,1,N1-1) S X=$E(X,N1+1,999) I X'="" W ! G Q4
- Q
- Q5 Q:'$D(^FH(116.1,FHMN,"RE",M,"D"))
- F P1=0:0 S P1=$O(^FH(116.1,FHMN,"RE",M,"D",P1)) Q:P1<1 S X=^(P1,0),A1=$P(X,"^",2),X1=^FH(119.72,P1,0) D DP
- Q
- DP I $G(^FH(119.72,P1,"I"))="Y" Q
- S A2=$P(X1,"^",4) S:A2="" A2=$E($P(X1,"^",1),1,10) W !?3,A2
- S A2=$P(X1,"^",2) W ?15,$S(A2["C":"Cafe",1:"Tray")," ",$S(A1="":100,1:A1),"% " Q
- SRT S FHPD=$P(MCA,"^",2) K SR
- F LP=1:1 S FHX1=$P(FHPD," ",LP) Q:FHX1="" S PD=$P(FHX1,";",1) I PD'="" S Z=0,Z=$O(^FH(116.2,"C",PD,Z)) I Z D
- .S Z1=$P($G(^FH(116.2,+Z,0)),"^",6),Z1=$S(Z1<1:99,Z1<10:"0"_Z1,1:Z1)
- .S:'$D(SR(Z1_"~"_PD)) SR(Z1_"~"_PD)=FHX1 Q
- S (PD,XX)="" F S XX=$O(SR(XX)) Q:XX="" S Z=$G(SR(XX)) I Z'="" S:PD'="" PD=PD_" " S PD=PD_Z
- Q
- KIL K ^TMP($J) G KILL^XUSCLEAN
- FHPRC3 ; HISC/REL - List Meal ;4/12/95 13:56
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET DIC="^FH(116.1,"
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- KILL DIC
- IF U[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO FHPRC3
- SET FHMN=+Y
- +3 KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("A")="Select Listing Device: "
- SET %ZIS("B")="HOME"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- IF POP
- GOTO KIL
- +4 IF $DATA(IO("Q"))
- SET FHPGM="Q1^FHPRC3"
- SET FHLST="FHMN"
- DO EN2^FH
- GOTO FHPRC3
- +5 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO FHPRC3
- Q1 ; Print Meal
- +1 SET Y=^FH(116.1,FHMN,0)
- SET N1=$PIECE(Y,"^",1)
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 WRITE !!?(77-$LENGTH(N1)\2),"Meal: ",N1,!!,"Recipe",?28,"Cat.",?34,"Production Diets"
- +3 KILL ^TMP($JOB)
- +4 FOR M=0:0
- SET M=$ORDER(^FH(116.1,FHMN,"RE",M))
- IF M<1
- QUIT
- SET Y=$GET(^(M,0))
- SET L1=+Y
- DO Q2
- +5 SET K4=""
- FOR P0=0:0
- SET K4=$ORDER(^TMP($JOB,K4))
- IF K4=""
- QUIT
- FOR L1=0:0
- SET L1=$ORDER(^TMP($JOB,K4,L1))
- IF L1<1
- QUIT
- SET X=^(L1)
- DO Q3
- +6 WRITE !
- GOTO KIL
- Q2 SET X=$GET(^FH(114,L1,0))
- SET N1=$PIECE(X,"^",1)
- IF N1=""
- QUIT
- SET MCA=$ORDER(^FH(116.1,FHMN,"RE",M,"R",0))
- SET K4=$SELECT(MCA:+$GET(^FH(116.1,FHMN,"RE",M,"R",MCA,0)),1:99)
- +1 SET K4=$SELECT($DATA(^FH(114.1,+K4,0)):$PIECE(^(0),"^",3),1:99)
- +2 SET K4=$SELECT(K4<1:99,K4<10:"0"_K4,1:K4)_$EXTRACT(N1,1,28)
- +3 SET ^TMP($JOB,K4,L1)=N1_"^"_M
- QUIT
- Q3 WRITE !!,$EXTRACT($PIECE(X,"^",1),1,27)
- SET M=$PIECE(X,"^",2)
- +1 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,FHMN,"RE",M,"R",CAT))
- IF CAT<1
- QUIT
- SET MCA=$GET(^(CAT,0))
- SET CODE=+MCA
- Begin DoDot:1
- +2 SET CODE=$PIECE($GET(^FH(114.1,+CODE,0)),"^",2)
- DO SRT
- +3 WRITE ?29,$JUSTIFY(CODE,3)
- SET X=$EXTRACT(PD,1,200)
- DO Q4
- WRITE !
- +4 QUIT
- End DoDot:1
- +5 GOTO Q5
- Q4 IF $LENGTH(X)<44
- WRITE ?34,X
- QUIT
- +1 FOR N1=44:-1:1
- IF $EXTRACT(X,N1)=" "
- QUIT
- +2 WRITE ?34,$EXTRACT(X,1,N1-1)
- SET X=$EXTRACT(X,N1+1,999)
- IF X'=""
- WRITE !
- GOTO Q4
- +3 QUIT
- Q5 IF '$DATA(^FH(116.1,FHMN,"RE",M,"D"))
- QUIT
- +1 FOR P1=0:0
- SET P1=$ORDER(^FH(116.1,FHMN,"RE",M,"D",P1))
- IF P1<1
- QUIT
- SET X=^(P1,0)
- SET A1=$PIECE(X,"^",2)
- SET X1=^FH(119.72,P1,0)
- DO DP
- +2 QUIT
- DP IF $GET(^FH(119.72,P1,"I"))="Y"
- QUIT
- +1 SET A2=$PIECE(X1,"^",4)
- IF A2=""
- SET A2=$EXTRACT($PIECE(X1,"^",1),1,10)
- WRITE !?3,A2
- +2 SET A2=$PIECE(X1,"^",2)
- WRITE ?15,$SELECT(A2["C":"Cafe",1:"Tray")," ",$SELECT(A1="":100,1:A1),"% "
- QUIT
- SRT SET FHPD=$PIECE(MCA,"^",2)
- KILL SR
- +1 FOR LP=1:1
- SET FHX1=$PIECE(FHPD," ",LP)
- IF FHX1=""
- QUIT
- SET PD=$PIECE(FHX1,";",1)
- IF PD'=""
- SET Z=0
- SET Z=$ORDER(^FH(116.2,"C",PD,Z))
- IF Z
- Begin DoDot:1
- +2 SET Z1=$PIECE($GET(^FH(116.2,+Z,0)),"^",6)
- SET Z1=$SELECT(Z1<1:99,Z1<10:"0"_Z1,1:Z1)
- +3 IF '$DATA(SR(Z1_"~"_PD))
- SET SR(Z1_"~"_PD)=FHX1
- QUIT
- End DoDot:1
- +4 SET (PD,XX)=""
- FOR
- SET XX=$ORDER(SR(XX))
- IF XX=""
- QUIT
- SET Z=$GET(SR(XX))
- IF Z'=""
- IF PD'=""
- SET PD=PD_" "
- SET PD=PD_Z
- +5 QUIT
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
