- FHSEL4 ; HISC/REL/NCA - Tabulate Food Preferences ;4/27/93 13:09
- ;;5.5;DIETETICS;;Jan 28, 2005
- S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
- D0 R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
- E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
- R1 R !!,"Select MEAL (B,N,E or ALL): ",MEAL:DTIME G:'$T!("^"[MEAL) KIL S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="A"
- I "BNEA"'[MEAL!(MEAL'?1U) W *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals" G R1
- D1 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^FHSEL4",FHLST="FHP^MEAL" D EN2^FH G KIL
- U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
- Q1 D NOW^%DTC S NOW=%,PG=0 K ^TMP($J)
- F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0),D2=+$P(X,"^",8) I D2,'FHP!(FHP=D2) S ^TMP($J,"W",D2,WRD)=""
- F D2=0:0 S D2=$O(^TMP($J,"W",D2)) Q:D2<1 D W0
- S DTP=NOW\1 D DTP^FH S H1=DTP D SES
- I MEAL'="A" D Q2 Q
- F MEAL="B","N","E" D Q2
- Q
- Q2 K ^TMP($J,"L"),^TMP($J,"D") F Z=0:0 S Z=$O(^TMP($J,"P",MEAL,Z)) Q:Z<1 D C1
- D HDR I $D(^TMP($J,"L")) S TP="L" W !!?(S1-9\2),"L I K E S",! D L0
- I $D(^TMP($J,"D")) S TP="D" W !!?(S1-15\2),"D I S L I K E S",! D L0
- W ! Q
- L0 S X1="" F LL=0:0 S X1=$O(^TMP($J,TP,X1)) Q:X1="" S Z=^(X1) I $D(^TMP($J,"P",MEAL,Z)) D L1
- Q
- L1 D:$Y>(IOSL-6) HDR S TOT=0 W !,$P(^FH(115.2,Z,0),"^",1)
- F D2=0:0 S D2=$O(^TMP($J,"P",MEAL,Z,D2)) Q:D2<1 S N1=^(D2) W ?(30+P(D2)),$J(N1,6) S TOT=TOT+N1
- W ?S2,$J(TOT,7) Q
- SES K N,P S PD="",P0=0,N=0
- F K=2:11 S P0=$O(^TMP($J,"W",P0)) Q:P0<1 S Y=$E($P(^FH(119.73,P0,0),"^",1),1,9),PD=PD_$J(Y_$E(" ",1,10-$L(Y)\2),9)_" ",P(P0)=K,N=N+1
- S S2=31+$L(PD),S1=S2+7 Q
- C1 S X=$G(^FH(115.2,Z,0)),TP=$P(X,"^",2)
- Q:TP="" S ^TMP($J,TP,$P(X,"^",1)_Z)=Z Q
- HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,H1,?(S1-29\2),"M E A L P R E F E R E N C E S",?(S1-6),"Page ",PG
- S X=$S(MEAL="B":"B R E A K F A S T",MEAL="N":"N O O N",1:"E V E N I N G") W !!?(S1-$L(X)\2),X
- W !!,"Preference",?32,PD," TOTAL"
- S LN="",$P(LN,"-",S1+8)="" W !,LN Q
- KIL K ^TMP($J) G KILL^XUSCLEAN
- W0 F WRD=0:0 S WRD=$O(^TMP($J,"W",D2,WRD)) Q:WRD<1 D W2
- Q
- W2 Q:$O(^FHPT("AW",WRD,0))<1 S WRDN=$P($G(^FH(119.6,WRD,0)),"^",1)
- F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=^FHPT("AW",WRD,FHDFN) I ADM>0 D W3
- Q
- W3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
- F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S Z=^(K,0),Z2=$P(Z,"^",2),QTY=$P(Z,"^",3),Z=+Z D W4
- Q
- W4 I MEAL'="A" Q:Z2'[MEAL S:'$D(^TMP($J,"P",MEAL,Z,D2)) ^TMP($J,"P",MEAL,Z,D2)=0 S ^(D2)=^(D2)+$S(QTY:QTY,1:1) Q
- F LL="B","N","E" I Z2[LL S:'$D(^TMP($J,"P",LL,Z,D2)) ^TMP($J,"P",LL,Z,D2)=0 S ^(D2)=^(D2)+$S(QTY:QTY,1:1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSEL4 2793 printed Jan 18, 2025@02:56:15 Page 2
- FHSEL4 ; HISC/REL/NCA - Tabulate Food Preferences ;4/27/93 13:09
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET FHP=$ORDER(^FH(119.73,0))
- IF FHP'<1
- IF $ORDER(^FH(119.73,FHP))<1
- SET FHP=0
- GOTO R1
- D0 READ !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME
- if '$TEST!("^"[X)
- GOTO KIL
- if X="all"
- DO TR^FH
- IF X="ALL"
- SET FHP=0
- +1 IF '$TEST
- KILL DIC
- SET DIC="^FH(119.73,"
- SET DIC(0)="EMQ"
- DO ^DIC
- if Y<1
- GOTO D0
- SET FHP=+Y
- R1 READ !!,"Select MEAL (B,N,E or ALL): ",MEAL:DTIME
- if '$TEST!("^"[MEAL)
- GOTO KIL
- SET X=MEAL
- DO TR^FH
- SET MEAL=X
- if $PIECE("ALL",MEAL,1)=""
- SET MEAL="A"
- +1 IF "BNEA"'[MEAL!(MEAL'?1U)
- WRITE *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals"
- GOTO R1
- D1 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^FHSEL4"
- SET FHLST="FHP^MEAL"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- Q1 DO NOW^%DTC
- SET NOW=%
- SET PG=0
- KILL ^TMP($JOB)
- +1 FOR WRD=0:0
- SET WRD=$ORDER(^FH(119.6,WRD))
- if WRD<1
- QUIT
- SET X=^(WRD,0)
- SET D2=+$PIECE(X,"^",8)
- IF D2
- IF 'FHP!(FHP=D2)
- SET ^TMP($JOB,"W",D2,WRD)=""
- +2 FOR D2=0:0
- SET D2=$ORDER(^TMP($JOB,"W",D2))
- if D2<1
- QUIT
- DO W0
- +3 SET DTP=NOW\1
- DO DTP^FH
- SET H1=DTP
- DO SES
- +4 IF MEAL'="A"
- DO Q2
- QUIT
- +5 FOR MEAL="B","N","E"
- DO Q2
- +6 QUIT
- Q2 KILL ^TMP($JOB,"L"),^TMP($JOB,"D")
- FOR Z=0:0
- SET Z=$ORDER(^TMP($JOB,"P",MEAL,Z))
- if Z<1
- QUIT
- DO C1
- +1 DO HDR
- IF $DATA(^TMP($JOB,"L"))
- SET TP="L"
- WRITE !!?(S1-9\2),"L I K E S",!
- DO L0
- +2 IF $DATA(^TMP($JOB,"D"))
- SET TP="D"
- WRITE !!?(S1-15\2),"D I S L I K E S",!
- DO L0
- +3 WRITE !
- QUIT
- L0 SET X1=""
- FOR LL=0:0
- SET X1=$ORDER(^TMP($JOB,TP,X1))
- if X1=""
- QUIT
- SET Z=^(X1)
- IF $DATA(^TMP($JOB,"P",MEAL,Z))
- DO L1
- +1 QUIT
- L1 if $Y>(IOSL-6)
- DO HDR
- SET TOT=0
- WRITE !,$PIECE(^FH(115.2,Z,0),"^",1)
- +1 FOR D2=0:0
- SET D2=$ORDER(^TMP($JOB,"P",MEAL,Z,D2))
- if D2<1
- QUIT
- SET N1=^(D2)
- WRITE ?(30+P(D2)),$JUSTIFY(N1,6)
- SET TOT=TOT+N1
- +2 WRITE ?S2,$JUSTIFY(TOT,7)
- QUIT
- SES KILL N,P
- SET PD=""
- SET P0=0
- SET N=0
- +1 FOR K=2:11
- SET P0=$ORDER(^TMP($JOB,"W",P0))
- if P0<1
- QUIT
- SET Y=$EXTRACT($PIECE(^FH(119.73,P0,0),"^",1),1,9)
- SET PD=PD_$JUSTIFY(Y_$EXTRACT(" ",1,10-$LENGTH(Y)\2),9)_" "
- SET P(P0)=K
- SET N=N+1
- +2 SET S2=31+$LENGTH(PD)
- SET S1=S2+7
- QUIT
- C1 SET X=$GET(^FH(115.2,Z,0))
- SET TP=$PIECE(X,"^",2)
- +1 if TP=""
- QUIT
- SET ^TMP($JOB,TP,$PIECE(X,"^",1)_Z)=Z
- QUIT
- HDR if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !,H1,?(S1-29\2),"M E A L P R E F E R E N C E S",?(S1-6),"Page ",PG
- +1 SET X=$SELECT(MEAL="B":"B R E A K F A S T",MEAL="N":"N O O N",1:"E V E N I N G")
- WRITE !!?(S1-$LENGTH(X)\2),X
- +2 WRITE !!,"Preference",?32,PD," TOTAL"
- +3 SET LN=""
- SET $PIECE(LN,"-",S1+8)=""
- WRITE !,LN
- QUIT
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
- W0 FOR WRD=0:0
- SET WRD=$ORDER(^TMP($JOB,"W",D2,WRD))
- if WRD<1
- QUIT
- DO W2
- +1 QUIT
- W2 if $ORDER(^FHPT("AW",WRD,0))<1
- QUIT
- SET WRDN=$PIECE($GET(^FH(119.6,WRD,0)),"^",1)
- +1 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))
- if FHDFN<1
- QUIT
- SET ADM=^FHPT("AW",WRD,FHDFN)
- IF ADM>0
- DO W3
- +2 QUIT
- W3 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
- QUIT
- +1 FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"P",K))
- if K<1
- QUIT
- SET Z=^(K,0)
- SET Z2=$PIECE(Z,"^",2)
- SET QTY=$PIECE(Z,"^",3)
- SET Z=+Z
- DO W4
- +2 QUIT
- W4 IF MEAL'="A"
- if Z2'[MEAL
- QUIT
- if '$DATA(^TMP($JOB,"P",MEAL,Z,D2))
- SET ^TMP($JOB,"P",MEAL,Z,D2)=0
- SET ^(D2)=^(D2)+$SELECT(QTY:QTY,1:1)
- QUIT
- +1 FOR LL="B","N","E"
- IF Z2[LL
- if '$DATA(^TMP($JOB,"P",LL,Z,D2))
- SET ^TMP($JOB,"P",LL,Z,D2)=0
- SET ^(D2)=^(D2)+$SELECT(QTY:QTY,1:1)
- +2 QUIT