FHORD.m

FHORD ; HISC/REL/NCA - Diet Order Entry ;8/9/96  12:29 ;

 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53

EN1 ; Edit Diets

 S CHK=0,TYP="D",EVENT="UPD",REC=1,(NOD1,NOD2)="" K ^TMP($J,"FHNOD3")

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

 S FHOLDLB=$P($G(^FH(111,+Y,0)),U,7)

 S IEN=Y,NOD1=$P($G(^FH(111,+IEN,0)),"^",1,4),NOD2=$G(^FH(111,+IEN,"I"))

 F IEN1=0:0 S IEN1=$O(^FH(111,+IEN,"AN",IEN1)) Q:IEN1<1  S:'$D(^TMP($J,"FHNOD3",IEN1)) ^TMP($J,"FHNOD3",IEN1)=$G(^FH(111,+IEN,"AN",IEN1,0))

 ;DR STRING MODIFIED TO ONLY EDIT INACTIVE STATUS IF DIET ORDER INACTIVE

 S DA=+Y,DR="I $G(^FH(111,+IEN,""I""))=""Y"" S Y=99;"_$S(DA'=1:".01:99",1:"1;2;5;6;10"),DIE("NO^")="" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=111 D ^DIE K DIC,DIE,DIDEL I $D(^ORD(101.43)) D UPDATE^FHWOR6

 S FHNEWLB=$P($G(^FH(111,+IEN,0)),U,7)

 I FHOLDLB'=FHNEWLB,FHOLDLB'="" W !!,"The Abbreviated Label for this Diet has been changed to ",$P($G(^FH(111,+IEN,0)),U,7),".",!,"Diet Patterns containing this Diet will now be updated to reflect this change:",! H 2 D UPDPAT

 G EN1

EN2 ; List Diets

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

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

 S FR="",TO="",DHD="DIETS LIST" D EN1^DIP,RSET Q

KIL K ^TMP($J),%,ADM,ALL,C,CHK,D,DA,DIC,DIE,DR,FHDFN,DFN,EVENT,FHDR,FHK,I,IEN,IEN1,FHNEWLB,FHNEWNM,FHOLDLB,FHOLDNM,FHFH,FHFND,FHDPIEN,FLG,FHX1,FHX2,FHWF,FHPV,COM,NOD1,NOD2,NOD3,NOW,POP,REC,STR,STR1,TYP,WARD,X Q

RSET K %ZIS S IOP="" D ^%ZIS K %ZIS,IOP,BY,DA,FHDFN,DFN,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y Q

 ;

UPDPAT ; Update Diet Pattern names

 S FLG=0 F FHDPIEN=0:0 S FHDPIEN=$O(^FH(111.1,FHDPIEN)) Q:FHDPIEN'>0  D

 .S FHFND=0,FHOLDNM=$P($G(^FH(111.1,FHDPIEN,0)),U,1)

 .S FHDPDTS=$P($G(^FH(111.1,FHDPIEN,0)),U,2,6)

 .F FHFH=1:1:5 I $P(FHDPDTS,U,FHFH)=+IEN S FHFND=FHFH

 .Q:FHFND=0

 .S FLG=1,FHNEWNM=FHOLDNM S $P(FHNEWNM,",",FHFND)=" "_FHNEWLB

 .I $E(FHNEWNM,1)=" " S FHNEWNM=$E(FHNEWNM,2,99)

 .W !,FHOLDNM," will change to ",FHNEWNM

 .K DIE S DIE="^FH(111.1,",DA=FHDPIEN,DR=".01////^S X=FHNEWNM" D ^DIE

 W !!,$S(FLG=1:"...Diet Patterns have been updated!",1:"...No Diet Patterns needed updating.") Q

FHORD     ; HISC/REL/NCA - Diet Order Entry ;8/9/96  12:29 ;

 +1       ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53

EN1       ; Edit Diets

 +1        SET CHK=0

           SET TYP="D"

           SET EVENT="UPD"

           SET REC=1

           SET (NOD1,NOD2)=""

           KILL ^TMP($JOB,"FHNOD3")

 +2        SET (DIC,DIE)="^FH(111,"

           SET DIC(0)="AEQLM"

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

           SET DLAYGO=111

           WRITE !

           DO ^DIC

           KILL DIC,DLAYGO

           IF U[X!$DATA(DTOUT)

               GOTO KIL

           IF Y<1

               GOTO EN1

 +3        SET FHOLDLB=$PIECE($GET(^FH(111,+Y,0)),U,7)

 +4        SET IEN=Y

           SET NOD1=$PIECE($GET(^FH(111,+IEN,0)),"^",1,4)

           SET NOD2=$GET(^FH(111,+IEN,"I"))

 +5        FOR IEN1=0:0

               SET IEN1=$ORDER(^FH(111,+IEN,"AN",IEN1))

               IF IEN1<1

                   QUIT 

               IF '$DATA(^TMP($JOB,"FHNOD3",IEN1))

                   SET ^TMP($JOB,"FHNOD3",IEN1)=$GET(^FH(111,+IEN,"AN",IEN1,0))

 +6       ;DR STRING MODIFIED TO ONLY EDIT INACTIVE STATUS IF DIET ORDER INACTIVE

 +7        SET DA=+Y

           SET DR="I $G(^FH(111,+IEN,""I""))=""Y"" S Y=99;"_$SELECT(DA'=1:".01:99",1:"1;2;5;6;10")

           SET DIE("NO^")=""

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

               SET DIDEL=111

           DO ^DIE

           KILL DIC,DIE,DIDEL

           IF $DATA(^ORD(101.43))

               DO UPDATE^FHWOR6

 +8        SET FHNEWLB=$PIECE($GET(^FH(111,+IEN,0)),U,7)

 +9        IF FHOLDLB'=FHNEWLB

               IF FHOLDLB'=""

                   WRITE !!,"The Abbreviated Label for this Diet has been changed to ",$PIECE($GET(^FH(111,+IEN,0)),U,7),".",!,"Diet Patterns containing this Diet will now be updated to reflect this change:",!

                   HANG 2

                   DO UPDPAT

 +10       GOTO EN1

EN2       ; List Diets

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

 +2        WRITE !

           SET L=0

           SET DIC="^FH(111,"

           SET FLDS="[FHDIETL]"

           SET BY="NAME"

 +3        SET FR=""

           SET TO=""

           SET DHD="DIETS LIST"

           DO EN1^DIP

           DO RSET

           QUIT 

KIL        KILL ^TMP($JOB),%,ADM,ALL,C,CHK,D,DA,DIC,DIE,DR,FHDFN,DFN,EVENT,FHDR,FHK,I,IEN,IEN1,FHNEWLB,FHNEWNM,FHOLDLB,FHOLDNM,FHFH,FHFND,FHDPIEN,FLG,FHX1,FHX2,FHWF,FHPV,COM,NOD1,NOD2,NOD3,NOW,POP,REC,STR,STR1,TYP,WARD,X

           QUIT 

RSET       KILL %ZIS

           SET IOP=""

           DO ^%ZIS

           KILL %ZIS,IOP,BY,DA,FHDFN,DFN,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y

           QUIT 

 +1       ;

UPDPAT    ; Update Diet Pattern names

 +1        SET FLG=0

           FOR FHDPIEN=0:0

               SET FHDPIEN=$ORDER(^FH(111.1,FHDPIEN))

               IF FHDPIEN'>0

                   QUIT 

               Begin DoDot:1

 +2                SET FHFND=0

                   SET FHOLDNM=$PIECE($GET(^FH(111.1,FHDPIEN,0)),U,1)

 +3                SET FHDPDTS=$PIECE($GET(^FH(111.1,FHDPIEN,0)),U,2,6)

 +4                FOR FHFH=1:1:5

                       IF $PIECE(FHDPDTS,U,FHFH)=+IEN

                           SET FHFND=FHFH

 +5                IF FHFND=0

                       QUIT 

 +6                SET FLG=1

                   SET FHNEWNM=FHOLDNM

                   SET $PIECE(FHNEWNM,",",FHFND)=" "_FHNEWLB

 +7                IF $EXTRACT(FHNEWNM,1)=" "

                       SET FHNEWNM=$EXTRACT(FHNEWNM,2,99)

 +8                WRITE !,FHOLDNM," will change to ",FHNEWNM

 +9                KILL DIE

                   SET DIE="^FH(111.1,"

                   SET DA=FHDPIEN

                   SET DR=".01////^S X=FHNEWNM"

                   DO ^DIE

               End DoDot:1

 +10       WRITE !!,$SELECT(FLG=1:"...Diet Patterns have been updated!",1:"...No Diet Patterns needed updating.")

           QUIT