FHPRF4.m

FHPRF4 ; HISC/REL - Print Other Meals ;4/27/93  13:41 

 ;;5.5;DIETETICS;;Jan 28, 2005

R1 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^FHPRF4",FHLST="" D EN2^FH G KIL

 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL

Q1 ; Print Other Meals

 D NOW^%DTC S DTP=% D DTP^FH

 W:$E(IOST,1,2)="C-" @IOF W !?29,"O T H E R   M E A L S"

 W !!?(79-$L(DTP)\2),DTP

 F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1  S X1=0 F NX=0:0 S NX=$O(^FH(119.72,P0,"B",NX)) Q:NX<1  S X=^(NX,0) D PR

 W ! Q

PR I $G(^FH(119.72,P0,"I"))="Y" Q

 G:X1 P1 S Y=$P(^FH(119.72,P0,0),"^",1),X1=1 W !!?(79-$L(Y)\2),Y

 W !!,"Diet",?32,"Meal",?40,"Sun  Mon  Tue  Wed  Thu  Fri  Sat"

P1 S NAM=$P(^FH(116.2,NX,0),"^",1) W !!,NAM

 F L=1:1:3 W:L>1 ! W ?32,$P("Brk^Noon^Even","^",L),?38 F K=1:1:7 S Z=$P(X,"^",K*3-2+L) W $S('Z:$J("",5),1:$J(Z,5))

 Q

KIL G KILL^XUSCLEAN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHPRF4   893     printed  Nov 22, 2024@17:04:39                                                                                                                                                                                                       Page 2

FHPRF4    ; HISC/REL - Print Other Meals ;4/27/93  13:41 

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

R1         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^FHPRF4"

               SET FHLST=""

               DO EN2^FH

               GOTO KIL

 +2        USE IO

           DO Q1

           DO ^%ZISC

           KILL %ZIS,IOP

           GOTO KIL

Q1        ; Print Other Meals

 +1        DO NOW^%DTC

           SET DTP=%

           DO DTP^FH

 +2        if $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF

           WRITE !?29,"O T H E R   M E A L S"

 +3        WRITE !!?(79-$LENGTH(DTP)\2),DTP

 +4        FOR P0=0:0

               SET P0=$ORDER(^FH(119.72,P0))

               if P0<1

                   QUIT 

               SET X1=0

               FOR NX=0:0

                   SET NX=$ORDER(^FH(119.72,P0,"B",NX))

                   if NX<1

                       QUIT 

                   SET X=^(NX,0)

                   DO PR

 +5        WRITE !

           QUIT 

PR         IF $GET(^FH(119.72,P0,"I"))="Y"

               QUIT 

 +1        if X1

               GOTO P1

           SET Y=$PIECE(^FH(119.72,P0,0),"^",1)

           SET X1=1

           WRITE !!?(79-$LENGTH(Y)\2),Y

 +2        WRITE !!,"Diet",?32,"Meal",?40,"Sun  Mon  Tue  Wed  Thu  Fri  Sat"

P1         SET NAM=$PIECE(^FH(116.2,NX,0),"^",1)

           WRITE !!,NAM

 +1        FOR L=1:1:3

               if L>1

                   WRITE !

               WRITE ?32,$PIECE("Brk^Noon^Even","^",L),?38

               FOR K=1:1:7

                   SET Z=$PIECE(X,"^",K*3-2+L)

                   WRITE $SELECT('Z:$JUSTIFY("",5),1:$JUSTIFY(Z,5))

 +2        QUIT 

KIL        GOTO KILL^XUSCLEAN