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 Oct 16, 2024@17:55:51 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
