FHNO1.m

FHNO1 ; HISC/REL - Supplement Feeding Management ;3/8/95  13:27

 ;;5.5;DIETETICS;;Jan 28, 2005

EN3 ; Edit Supplemental Feedings

 D NOW^%DTC S DT=%\1 K %,%H,%I

 W ! S (DIC,DIE)="^FH(118,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=118 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1

 S DA=+Y,DR=$S(DA>1:".01;",1:"")_"1;5//Y;6:20;22:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=118 D ^DIE K DA,DIE,DIDEL,DR G EN3

EN4 ; Edit Supp. Feeding Menus

 W ! S (DIC,DIE)="^FH(118.1,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=118.1 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN4:Y<1

 I +Y=1 W *7,!!,"You cannot edit INDIVIDUALIZED Supplemental Menu",! G EN4

 S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=118.1 D ^DIE G:'$D(DA) EN41

 S Y=$G(^FH(118.1,DA,1)),E=0

 F K=2:2:24 I $P(Y,"^",K),$P(Y,"^",K-1)="" S $P(Y,"^",K)="",E=1

 S:E ^FH(118.1,DA,1)=Y

EN41 K DA,DIE,DIDEL,DR,E,K,Y G EN4

EN6 ; List Supplemental Feedings

 W ! S L=0,DIC="^FH(118,",FLDS="[FHSFLST]",BY="NAME"

 S FR="",TO="",DHD="SUPPLEMENTAL FEEDINGS" D EN1^DIP,RSET Q

EN7 ; List Supplemental Feeding Menus

 W !!,"The list requires a 132 column printer.",!

 W ! S L=0,DIC="^FH(118.1,",FLDS="[FHSFMENU]",BY="NAME"

 S FR="",TO="",DHD="SUPPLEMENTAL FEEDING MENUS" D EN1^DIP,RSET Q

RSET K %ZIS S IOP="" D ^%ZIS

KIL G KILL^XUSCLEAN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHNO1   1292     printed  Apr 09, 2024@20:58:04                                                                                                                                                                                                       Page 2

FHNO1     ; HISC/REL - Supplement Feeding Management ;3/8/95  13:27

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

EN3       ; Edit Supplemental Feedings

 +1        DO NOW^%DTC

           SET DT=%\1

           KILL %,%H,%I

 +2        WRITE !

           SET (DIC,DIE)="^FH(118,"

           SET DIC(0)="AEQLM"

           SET DIC("DR")=".01"

           SET DLAYGO=118

           WRITE !

           DO ^DIC

           KILL DIC,DLAYGO

           if U[X!$DATA(DTOUT)

               GOTO KIL

           if Y<1

               GOTO EN3

 +3        SET DA=+Y

           SET DR=$SELECT(DA>1:".01;",1:"")_"1;5//Y;6:20;22:99"

           if $DATA(^XUSEC("FHMGR",DUZ))

               SET DIDEL=118

           DO ^DIE

           KILL DA,DIE,DIDEL,DR

           GOTO EN3

EN4       ; Edit Supp. Feeding Menus

 +1        WRITE !

           SET (DIC,DIE)="^FH(118.1,"

           SET DIC(0)="AEQLM"

           SET DIC("DR")=".01"

           SET DLAYGO=118.1

           WRITE !

           DO ^DIC

           KILL DIC,DLAYGO

           if U[X!$DATA(DTOUT)

               GOTO KIL

           if Y<1

               GOTO EN4

 +2        IF +Y=1

               WRITE *7,!!,"You cannot edit INDIVIDUALIZED Supplemental Menu",!

               GOTO EN4

 +3        SET DA=+Y

           SET DR=".01:99"

           if $DATA(^XUSEC("FHMGR",DUZ))

               SET DIDEL=118.1

           DO ^DIE

           if '$DATA(DA)

               GOTO EN41

 +4        SET Y=$GET(^FH(118.1,DA,1))

           SET E=0

 +5        FOR K=2:2:24

               IF $PIECE(Y,"^",K)

                   IF $PIECE(Y,"^",K-1)=""

                       SET $PIECE(Y,"^",K)=""

                       SET E=1

 +6        if E

               SET ^FH(118.1,DA,1)=Y

EN41       KILL DA,DIE,DIDEL,DR,E,K,Y

           GOTO EN4

EN6       ; List Supplemental Feedings

 +1        WRITE !

           SET L=0

           SET DIC="^FH(118,"

           SET FLDS="[FHSFLST]"

           SET BY="NAME"

 +2        SET FR=""

           SET TO=""

           SET DHD="SUPPLEMENTAL FEEDINGS"

           DO EN1^DIP

           DO RSET

           QUIT 

EN7       ; List Supplemental Feeding Menus

 +1        WRITE !!,"The list requires a 132 column printer.",!

 +2        WRITE !

           SET L=0

           SET DIC="^FH(118.1,"

           SET FLDS="[FHSFMENU]"

           SET BY="NAME"

 +3        SET FR=""

           SET TO=""

           SET DHD="SUPPLEMENTAL FEEDING MENUS"

           DO EN1^DIP

           DO RSET

           QUIT 

RSET       KILL %ZIS

           SET IOP=""

           DO ^%ZIS

KIL        GOTO KILL^XUSCLEAN