FHMTK21 ; HISC/NCA - List Diet Patterns (cont.) ;5/1/95 11:46
;;5.5;DIETETICS;;Jan 28, 2005
L1 ; List the Diet Pattern(s)
K ^TMP($J) D NOW^%DTC S DTP=% D DTP^FH S PG=0,RES="" D HDR
I ANS'?1"Y".E S MP=+FHDA,X=$G(^FH(111.1,MP,0)) D L2 G PRT
F MP=0:0 S MP=$O(^FH(111.1,MP)) Q:MP<1 S X=$G(^(MP,0)) D L2
G PRT
L2 S PD=$P(X,"^",7) Q:'PD
S NAM=$P(X,"^",1),FHPD=$P($G(^FH(116.2,PD,0)),"^",1),NM=$P(X,"^",8),SF=$P($G(^FH(118.1,+NM,0)),"^",1)
S P0=$P($G(^FH(116.2,PD,0)),"^",6),P0=$S('P0:99,P0<10:"0"_P0,1:P0)
S P0=P0_"~"_FHPD
S:'$D(^TMP($J,"FHPD",P0)) ^TMP($J,"FHPD",P0)=PD S M0=NAM
S ^TMP($J,"FHO",PD,M0)=MP_"^"_SF
F MEAL="B","N","E" D L3
F MEAL="BS","NS","ES" D L5
F R1=0:0 S R1=$O(^FH(111.1,MP,"RES",R1)) Q:R1<1 S FP=$G(^(R1,0)) D
.Q:$P(FP,"^",2)=""
.S K1=99_R1,K1=K1_"~"_$E($P($G(^FH(115.2,+FP,0)),"^",1),1,30)
.F MEAL="B","N","E" I $P(FP,"^",2)[MEAL S ^TMP($J,"FHFP",MP,MEAL,K1)=""
.Q
Q
L3 ; Get Diet pattern in print order
S LP=0
L4 S LP=$O(^FH(111.1,MP,MEAL,LP)) Q:LP<1 S R1=$G(^(LP,0))
S K1=$P($G(^FH(114.1,+R1,0)),"^",3)
S K1=$S('K1:99,K1<10:"0"_K1,1:K1)
S K1=K1_"~"_$E($P($G(^FH(114.1,+R1,0)),"^",1),1,15)
S ^TMP($J,"FHMP",MP,MEAL,K1)=$P(R1,"^",2)_"^"_+R1
G L4
L5 ; Get Standing Orders associated with Diet pattern
S LP=0
L6 S LP=$O(^FH(111.1,MP,MEAL,LP)) Q:LP<1 S R1=$G(^(LP,0))
S K1=99_LP,K1=K1_"~"_$E($P($G(^FH(118.3,+R1,0)),"^",1),1,30)
S ^TMP($J,"FHMP",MP,$E(MEAL,1),K1)=$P(R1,"^",2)_"^"_+R1
G L6
PRT ; Print Diet Pattern
S P0="" F S P0=$O(^TMP($J,"FHPD",P0)) Q:P0=""!(RES="^") S PD=+$G(^(P0)),M0="" F S M0=$O(^TMP($J,"FHO",PD,M0)) Q:M0="" S MP=+$G(^(M0)),SF=$P($G(^(M0)),"^",2) D P1,P2 Q:RES="^"
Q
P1 K MM S CTR=0 F MEAL="B","N","E" S N1=0,CTR=CTR+1 D
.S NX="" F S NX=$O(^TMP($J,"FHMP",MP,MEAL,NX)) Q:NX="" S QTY=$G(^(NX)) D
..S QTY=$S(QTY="":1,1:+QTY),N1=N1+1
..S PAD=$E(" ",1,4-$L(QTY)),MM(N1,CTR)=PAD_QTY_" "_$E($P(NX,"~",2),1,21)
..;S MM(N1,CTR)=$S(QTY#1>0:$J(QTY,3,1),1:QTY_" ")_" "_$E($P(NX,"~",2),1,21)
..Q
.S R1="" F S R1=$O(^TMP($J,"FHFP",MP,MEAL,R1)) Q:R1="" S N1=N1+1,MM(N1,CTR)=$J("",4)_$E($P(R1,"~",2),1,21)
.Q
Q
P2 I $Y'<(IOSL-8) D HDR Q:RES="^"
W !!,"Production Diet: ",$P(P0,"~",2),!,"Diet Order: ",M0
W !,"Associated Supp. Fdgs. Menu: ",$E(SF,1,30),!
W ! F N1=1:1 W ! Q:'$D(MM(N1))!(RES="^") F CTR=1:1:3 I $D(MM(N1,CTR)) D Q:RES="^"
.I $Y'<(IOSL-6) D HDR Q:RES="^"
.W ?$S(CTR=1:0,CTR=2:27,1:54),MM(N1,CTR) Q
Q
HDR D PAUSE Q:RES="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
S PG=PG+1 W !,DTP,?23,"D I E T P A T T E R N L I S T",?73,"Page ",PG
W !,"-------------------------------------------------------------------------------",!
W ! F CT=1:1:3 W ?$S(CT=1:8,CT=2:38,1:63),$S(CT=1:"BREAKFAST",CT=2:"NOON",1:"EVENING")
W ! Q
PAUSE ; Check to pause for reading
I PG,IOST?1"C-".E R !!,"Press RETURN to continue or ""^"" to exit. ",RES:DTIME S:'$T!(RES["^") RES="^" Q:RES="^" I "^"'[RES W !,"Enter Return or ""^""." G PAUSE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK21 2974 printed Dec 13, 2024@01:48:11 Page 2
FHMTK21 ; HISC/NCA - List Diet Patterns (cont.) ;5/1/95 11:46
+1 ;;5.5;DIETETICS;;Jan 28, 2005
L1 ; List the Diet Pattern(s)
+1 KILL ^TMP($JOB)
DO NOW^%DTC
SET DTP=%
DO DTP^FH
SET PG=0
SET RES=""
DO HDR
+2 IF ANS'?1"Y".E
SET MP=+FHDA
SET X=$GET(^FH(111.1,MP,0))
DO L2
GOTO PRT
+3 FOR MP=0:0
SET MP=$ORDER(^FH(111.1,MP))
if MP<1
QUIT
SET X=$GET(^(MP,0))
DO L2
+4 GOTO PRT
L2 SET PD=$PIECE(X,"^",7)
if 'PD
QUIT
+1 SET NAM=$PIECE(X,"^",1)
SET FHPD=$PIECE($GET(^FH(116.2,PD,0)),"^",1)
SET NM=$PIECE(X,"^",8)
SET SF=$PIECE($GET(^FH(118.1,+NM,0)),"^",1)
+2 SET P0=$PIECE($GET(^FH(116.2,PD,0)),"^",6)
SET P0=$SELECT('P0:99,P0<10:"0"_P0,1:P0)
+3 SET P0=P0_"~"_FHPD
+4 if '$DATA(^TMP($JOB,"FHPD",P0))
SET ^TMP($JOB,"FHPD",P0)=PD
SET M0=NAM
+5 SET ^TMP($JOB,"FHO",PD,M0)=MP_"^"_SF
+6 FOR MEAL="B","N","E"
DO L3
+7 FOR MEAL="BS","NS","ES"
DO L5
+8 FOR R1=0:0
SET R1=$ORDER(^FH(111.1,MP,"RES",R1))
if R1<1
QUIT
SET FP=$GET(^(R1,0))
Begin DoDot:1
+9 if $PIECE(FP,"^",2)=""
QUIT
+10 SET K1=99_R1
SET K1=K1_"~"_$EXTRACT($PIECE($GET(^FH(115.2,+FP,0)),"^",1),1,30)
+11 FOR MEAL="B","N","E"
IF $PIECE(FP,"^",2)[MEAL
SET ^TMP($JOB,"FHFP",MP,MEAL,K1)=""
+12 QUIT
End DoDot:1
+13 QUIT
L3 ; Get Diet pattern in print order
+1 SET LP=0
L4 SET LP=$ORDER(^FH(111.1,MP,MEAL,LP))
if LP<1
QUIT
SET R1=$GET(^(LP,0))
+1 SET K1=$PIECE($GET(^FH(114.1,+R1,0)),"^",3)
+2 SET K1=$SELECT('K1:99,K1<10:"0"_K1,1:K1)
+3 SET K1=K1_"~"_$EXTRACT($PIECE($GET(^FH(114.1,+R1,0)),"^",1),1,15)
+4 SET ^TMP($JOB,"FHMP",MP,MEAL,K1)=$PIECE(R1,"^",2)_"^"_+R1
+5 GOTO L4
L5 ; Get Standing Orders associated with Diet pattern
+1 SET LP=0
L6 SET LP=$ORDER(^FH(111.1,MP,MEAL,LP))
if LP<1
QUIT
SET R1=$GET(^(LP,0))
+1 SET K1=99_LP
SET K1=K1_"~"_$EXTRACT($PIECE($GET(^FH(118.3,+R1,0)),"^",1),1,30)
+2 SET ^TMP($JOB,"FHMP",MP,$EXTRACT(MEAL,1),K1)=$PIECE(R1,"^",2)_"^"_+R1
+3 GOTO L6
PRT ; Print Diet Pattern
+1 SET P0=""
FOR
SET P0=$ORDER(^TMP($JOB,"FHPD",P0))
if P0=""!(RES="^")
QUIT
SET PD=+$GET(^(P0))
SET M0=""
FOR
SET M0=$ORDER(^TMP($JOB,"FHO",PD,M0))
if M0=""
QUIT
SET MP=+$GET(^(M0))
SET SF=$PIECE($GET(^(M0)),"^",2)
DO P1
DO P2
if RES="^"
QUIT
+2 QUIT
P1 KILL MM
SET CTR=0
FOR MEAL="B","N","E"
SET N1=0
SET CTR=CTR+1
Begin DoDot:1
+1 SET NX=""
FOR
SET NX=$ORDER(^TMP($JOB,"FHMP",MP,MEAL,NX))
if NX=""
QUIT
SET QTY=$GET(^(NX))
Begin DoDot:2
+2 SET QTY=$SELECT(QTY="":1,1:+QTY)
SET N1=N1+1
+3 SET PAD=$EXTRACT(" ",1,4-$LENGTH(QTY))
SET MM(N1,CTR)=PAD_QTY_" "_$EXTRACT($PIECE(NX,"~",2),1,21)
+4 ;S MM(N1,CTR)=$S(QTY#1>0:$J(QTY,3,1),1:QTY_" ")_" "_$E($P(NX,"~",2),1,21)
+5 QUIT
End DoDot:2
+6 SET R1=""
FOR
SET R1=$ORDER(^TMP($JOB,"FHFP",MP,MEAL,R1))
if R1=""
QUIT
SET N1=N1+1
SET MM(N1,CTR)=$JUSTIFY("",4)_$EXTRACT($PIECE(R1,"~",2),1,21)
+7 QUIT
End DoDot:1
+8 QUIT
P2 IF $Y'<(IOSL-8)
DO HDR
if RES="^"
QUIT
+1 WRITE !!,"Production Diet: ",$PIECE(P0,"~",2),!,"Diet Order: ",M0
+2 WRITE !,"Associated Supp. Fdgs. Menu: ",$EXTRACT(SF,1,30),!
+3 WRITE !
FOR N1=1:1
WRITE !
if '$DATA(MM(N1))!(RES="^")
QUIT
FOR CTR=1:1:3
IF $DATA(MM(N1,CTR))
Begin DoDot:1
+4 IF $Y'<(IOSL-6)
DO HDR
if RES="^"
QUIT
+5 WRITE ?$SELECT(CTR=1:0,CTR=2:27,1:54),MM(N1,CTR)
QUIT
End DoDot:1
if RES="^"
QUIT
+6 QUIT
HDR DO PAUSE
if RES="^"
QUIT
if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+1 SET PG=PG+1
WRITE !,DTP,?23,"D I E T P A T T E R N L I S T",?73,"Page ",PG
+2 WRITE !,"-------------------------------------------------------------------------------",!
+3 WRITE !
FOR CT=1:1:3
WRITE ?$SELECT(CT=1:8,CT=2:38,1:63),$SELECT(CT=1:"BREAKFAST",CT=2:"NOON",1:"EVENING")
+4 WRITE !
QUIT
PAUSE ; Check to pause for reading
+1 IF PG
IF IOST?1"C-".E
READ !!,"Press RETURN to continue or ""^"" to exit. ",RES:DTIME
if '$TEST!(RES["^")
SET RES="^"
if RES="^"
QUIT
IF "^"'[RES
WRITE !,"Enter Return or ""^""."
GOTO PAUSE
+2 QUIT
