- FHSEL3 ; HISC/REL/NCA - Print Tabulated Preferences ;1/23/98 16:11
- ;;5.5;DIETETICS;;Jan 28, 2005
- K S S S1=38
- F K=0:0 S K=$O(D(K)) Q:K="" S X=^FH(119.72,K,0),N2=$P(X,"^",1),N3=$P(X,"^",4) S:N3="" N3=$E(N2,1,6) S S(N3,K)=$J(N3,8),S1=S1+8
- S:S1<80 S1=80
- F Z=0:0 S Z=$O(^TMP($J,"P",Z)) Q:Z<1 D C1
- S DTP=NOW D DTP^FH S H1=DTP,X=TIM D DOW^%DTC S DOW=Y+1 D SES,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
- KIL W ! Q
- L0 S CHK="" I 'SRT S LNOD="0" D L1 Q
- S LNOD="0" F L1=0:0 S LNOD=$O(^TMP($J,TP,LNOD)) Q:LNOD="" D L1
- Q
- L1 S X1=""
- L2 S X1=$O(^TMP($J,TP,LNOD,X1)) Q:X1=""
- D:$Y>(IOSL-6) HDR I SRT,CHK'=LNOD W !!,"Prod. Diet: ",LNOD,! S CHK=LNOD
- W !,$P(X1,"~",1),?31 S TOT=0
- S K1="" F S K1=$O(S(K1)) Q:K1="" F SP=0:0 S SP=$O(S(K1,SP)) Q:SP="" S N1=$G(^TMP($J,TP,LNOD,X1,SP)) W $J($S('N1:"",1:N1),6)," " S TOT=TOT+N1
- W $J($S(TOT:TOT,1:""),6)
- G L2
- SES S (PD,Y)="",P0=0
- S P0="" F S P0=$O(S(P0)) Q:P0="" F K=0:0 S K=$O(S(P0,K)) Q:K<1 S Y=$G(S(P0,K)),PD=PD_Y
- S PD=PD_" TOTAL"
- Q
- C1 S X=$G(^FH(115.2,Z,0)),TP=$P(X,"^",2)
- I TP="L" S X1=+$P(X,"^",4) G C3:D3,C31
- Q:TP'="D" S PD="" F LL=0:0 S PD=$O(^TMP($J,"P",Z,PD)) Q:PD="" D C2:D3,C22:'D3
- Q
- C2 F KK=0:0 S KK=$O(^FH(115.2,Z,"X",KK)) Q:KK<1 S X1=+^(KK,0) D C21
- Q
- C21 S X3=$O(^FH(116.1,FHX1,"RE","B",X1,0)) Q:X3<1
- S X1=$P(^FH(114,X1,0),"^",1)_"~"_X1
- F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",X3,"R",CAT)) Q:CAT<1 S X=$P($G(^(CAT,0)),"^",2) D
- .Q:X'[PD
- .F SP=0:0 S SP=$O(^TMP($J,"P",Z,PD,SP)) Q:SP<1 D C4
- .Q
- Q
- C22 S X1=$P(^FH(115.2,Z,0),"^",1)_"~"_Z
- F SP=0:0 S SP=$O(^TMP($J,"P",Z,PD,SP)) Q:SP<1 D C4
- Q
- C3 S X3=$O(^FH(116.1,FHX1,"RE","B",X1,0)) I X3<1 K ^TMP($J,"P",Z) Q
- S X1=$P(^FH(114,X1,0),"^",1)_"~"_X1
- S PD="" F LL=0:0 S PD=$O(^TMP($J,"P",Z,PD)) Q:PD="" D
- .F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",X3,"R",CAT)) Q:CAT<1 S X=$P($G(^(CAT,0)),"^",2) D
- ..Q:X'[PD
- ..F SP=0:0 S SP=$O(^TMP($J,"P",Z,PD,SP)) Q:SP<1 D C4
- ..Q
- .Q
- Q
- C31 S X1=$P(^FH(115.2,Z,0),"^",1)_"~"_Z
- S PD="" F LL=0:0 S PD=$O(^TMP($J,"P",Z,PD)) Q:PD="" F SP=0:0 S SP=$O(^TMP($J,"P",Z,PD,SP)) Q:SP<1 D C4
- Q
- C4 I $D(^TMP($J,"P",Z,PD,SP)) S X2=^(SP),CODE=$O(^FH(116.2,"C",PD,0)),CODE=$P($G(^FH(116.2,+CODE,0)),"^",1),LNOD=$S(SRT:$E(CODE,1,18),1:"0") S:'$D(^TMP($J,TP,LNOD,X1,SP)) ^TMP($J,TP,LNOD,X1,SP)=0 S ^(SP)=^(SP)+X2
- 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-8),"Page ",PG
- I D3 W !!?(S1-14\2),"MENU SPECIFIC"
- S DTP=TIM\1 D DTP^FH S X=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)_"DAY "_DTP_" "_$S(MEAL="B":"BREAKFAST",MEAL="N":"NOON",1:"EVENING")
- W:D3 ! W !?(S1+2-$L(X)\2),X
- W !! W $S('D3:"Preference",1:"Recipe"),?29,PD,!
- S LN="",$P(LN,"-",S1+1)="" W !,LN Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSEL3 2833 printed Mar 13, 2025@20:59:40 Page 2
- FHSEL3 ; HISC/REL/NCA - Print Tabulated Preferences ;1/23/98 16:11
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 KILL S
- SET S1=38
- +3 FOR K=0:0
- SET K=$ORDER(D(K))
- if K=""
- QUIT
- SET X=^FH(119.72,K,0)
- SET N2=$PIECE(X,"^",1)
- SET N3=$PIECE(X,"^",4)
- if N3=""
- SET N3=$EXTRACT(N2,1,6)
- SET S(N3,K)=$JUSTIFY(N3,8)
- SET S1=S1+8
- +4 if S1<80
- SET S1=80
- +5 FOR Z=0:0
- SET Z=$ORDER(^TMP($JOB,"P",Z))
- if Z<1
- QUIT
- DO C1
- +6 SET DTP=NOW
- DO DTP^FH
- SET H1=DTP
- SET X=TIM
- DO DOW^%DTC
- SET DOW=Y+1
- DO SES
- DO HDR
- +7 IF $DATA(^TMP($JOB,"L"))
- SET TP="L"
- WRITE !!?(S1-9\2),"L I K E S",!
- DO L0
- +8 IF $DATA(^TMP($JOB,"D"))
- SET TP="D"
- WRITE !!?(S1-15\2),"D I S L I K E S",!
- DO L0
- KIL WRITE !
- QUIT
- L0 SET CHK=""
- IF 'SRT
- SET LNOD="0"
- DO L1
- QUIT
- +1 SET LNOD="0"
- FOR L1=0:0
- SET LNOD=$ORDER(^TMP($JOB,TP,LNOD))
- if LNOD=""
- QUIT
- DO L1
- +2 QUIT
- L1 SET X1=""
- L2 SET X1=$ORDER(^TMP($JOB,TP,LNOD,X1))
- if X1=""
- QUIT
- +1 if $Y>(IOSL-6)
- DO HDR
- IF SRT
- IF CHK'=LNOD
- WRITE !!,"Prod. Diet: ",LNOD,!
- SET CHK=LNOD
- +2 WRITE !,$PIECE(X1,"~",1),?31
- SET TOT=0
- +3 SET K1=""
- FOR
- SET K1=$ORDER(S(K1))
- if K1=""
- QUIT
- FOR SP=0:0
- SET SP=$ORDER(S(K1,SP))
- if SP=""
- QUIT
- SET N1=$GET(^TMP($JOB,TP,LNOD,X1,SP))
- WRITE $JUSTIFY($SELECT('N1:"",1:N1),6)," "
- SET TOT=TOT+N1
- +4 WRITE $JUSTIFY($SELECT(TOT:TOT,1:""),6)
- +5 GOTO L2
- SES SET (PD,Y)=""
- SET P0=0
- +1 SET P0=""
- FOR
- SET P0=$ORDER(S(P0))
- if P0=""
- QUIT
- FOR K=0:0
- SET K=$ORDER(S(P0,K))
- if K<1
- QUIT
- SET Y=$GET(S(P0,K))
- SET PD=PD_Y
- +2 SET PD=PD_" TOTAL"
- +3 QUIT
- C1 SET X=$GET(^FH(115.2,Z,0))
- SET TP=$PIECE(X,"^",2)
- +1 IF TP="L"
- SET X1=+$PIECE(X,"^",4)
- if D3
- GOTO C3
- GOTO C31
- +2 if TP'="D"
- QUIT
- SET PD=""
- FOR LL=0:0
- SET PD=$ORDER(^TMP($JOB,"P",Z,PD))
- if PD=""
- QUIT
- if D3
- DO C2
- if 'D3
- DO C22
- +3 QUIT
- C2 FOR KK=0:0
- SET KK=$ORDER(^FH(115.2,Z,"X",KK))
- if KK<1
- QUIT
- SET X1=+^(KK,0)
- DO C21
- +1 QUIT
- C21 SET X3=$ORDER(^FH(116.1,FHX1,"RE","B",X1,0))
- if X3<1
- QUIT
- +1 SET X1=$PIECE(^FH(114,X1,0),"^",1)_"~"_X1
- +2 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,FHX1,"RE",X3,"R",CAT))
- if CAT<1
- QUIT
- SET X=$PIECE($GET(^(CAT,0)),"^",2)
- Begin DoDot:1
- +3 if X'[PD
- QUIT
- +4 FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"P",Z,PD,SP))
- if SP<1
- QUIT
- DO C4
- +5 QUIT
- End DoDot:1
- +6 QUIT
- C22 SET X1=$PIECE(^FH(115.2,Z,0),"^",1)_"~"_Z
- +1 FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"P",Z,PD,SP))
- if SP<1
- QUIT
- DO C4
- +2 QUIT
- C3 SET X3=$ORDER(^FH(116.1,FHX1,"RE","B",X1,0))
- IF X3<1
- KILL ^TMP($JOB,"P",Z)
- QUIT
- +1 SET X1=$PIECE(^FH(114,X1,0),"^",1)_"~"_X1
- +2 SET PD=""
- FOR LL=0:0
- SET PD=$ORDER(^TMP($JOB,"P",Z,PD))
- if PD=""
- QUIT
- Begin DoDot:1
- +3 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,FHX1,"RE",X3,"R",CAT))
- if CAT<1
- QUIT
- SET X=$PIECE($GET(^(CAT,0)),"^",2)
- Begin DoDot:2
- +4 if X'[PD
- QUIT
- +5 FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"P",Z,PD,SP))
- if SP<1
- QUIT
- DO C4
- +6 QUIT
- End DoDot:2
- +7 QUIT
- End DoDot:1
- +8 QUIT
- C31 SET X1=$PIECE(^FH(115.2,Z,0),"^",1)_"~"_Z
- +1 SET PD=""
- FOR LL=0:0
- SET PD=$ORDER(^TMP($JOB,"P",Z,PD))
- if PD=""
- QUIT
- FOR SP=0:0
- SET SP=$ORDER(^TMP($JOB,"P",Z,PD,SP))
- if SP<1
- QUIT
- DO C4
- +2 QUIT
- C4 IF $DATA(^TMP($JOB,"P",Z,PD,SP))
- SET X2=^(SP)
- SET CODE=$ORDER(^FH(116.2,"C",PD,0))
- SET CODE=$PIECE($GET(^FH(116.2,+CODE,0)),"^",1)
- SET LNOD=$SELECT(SRT:$EXTRACT(CODE,1,18),1:"0")
- if '$DATA(^TMP($JOB,TP,LNOD,X1,SP))
- SET ^TMP($JOB,TP,LNOD,X1,SP)=0
- SET ^(SP)=^(SP)+X2
- +1 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-8),"Page ",PG
- +1 IF D3
- WRITE !!?(S1-14\2),"MENU SPECIFIC"
- +2 SET DTP=TIM\1
- DO DTP^FH
- SET X=$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)_"DAY "_DTP_" "_$SELECT(MEAL="B":"BREAKFAST",MEAL="N":"NOON",1:"EVENING")
- +3 if D3
- WRITE !
- WRITE !?(S1+2-$LENGTH(X)\2),X
- +4 WRITE !!
- WRITE $SELECT('D3:"Preference",1:"Recipe"),?29,PD,!
- +5 SET LN=""
- SET $PIECE(LN,"-",S1+1)=""
- WRITE !,LN
- QUIT
