FHMTK21.m

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

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