- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD 2194 printed Feb 18, 2025@23:19:44 Page 2
- 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
