- FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53
- ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3
- ;
- ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old
- ; Clinician field
- EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics)
- W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: "
- S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR I $D(DIRUT) G KIL
- I Y'=-1 S FHANS=Y
- I FHANS="W" D EN2WRD Q
- I FHANS="O" D EN2OL Q
- Q
- EN2WRD ;Ward locations
- K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1
- ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3"
- ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field)
- S DA=+Y,DR=".01;2:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2
- EN2OL ;Outpatient locations
- K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1
- S DA=+Y,DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2
- EN3 ; Enter/Edit Production Diets
- K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1
- S DA=+Y,DR=$S(DA=1:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=116.2 D ^DIE I '$D(DA) D KIL G EN3
- S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3
- EN4 ; List Production Diets
- W !!,"The list requires a 132 column printer.",!
- W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01"
- S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q
- EN5 ; Enter/Edit Production Facilities
- K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1
- S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5
- EN6 ; Enter/Edit Service Points
- K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1
- S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6
- S DA(1)=DA S DIK="^FH(119.72,DA(1),""A""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"A",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,8)?."^" D ^DIK
- S DIK="^FH(119.72,DA(1),""B""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"B",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,22)?."^" D ^DIK
- D KIL G EN6
- EN7 ; Enter/Edit Communication Offices
- K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1
- S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7
- EN8 ; Enter/Edit Supplemental Feeding Sites
- K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74
- S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1
- S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8
- RSET K %ZIS S IOP="" D ^%ZIS
- KIL G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRO 3351 printed Feb 18, 2025@23:20:55 Page 2
- FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53
- +1 ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3
- +2 ;
- +3 ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old
- +4 ; Clinician field
- EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics)
- +1 WRITE !
- KILL DIR,DIC
- SET DIR("A")="Select WARD or OUTPATIENT Location: "
- +2 SET DIR(0)="SAO^W:Ward Location;O:Outpatient Location"
- DO ^DIR
- IF $DATA(DIRUT)
- GOTO KIL
- +3 IF Y'=-1
- SET FHANS=Y
- +4 IF FHANS="W"
- DO EN2WRD
- QUIT
- +5 IF FHANS="O"
- DO EN2OL
- QUIT
- +6 QUIT
- EN2WRD ;Ward locations
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.6,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.6
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN2
- +3 ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3"
- +4 ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field)
- +5 SET DA=+Y
- SET DR=".01;2:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.6
- DO ^DIE
- DO KIL
- GOTO EN2
- EN2OL ;Outpatient locations
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.6,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.6
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN2
- +3 SET DA=+Y
- SET DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.6
- DO ^DIE
- DO KIL
- GOTO EN2
- EN3 ; Enter/Edit Production Diets
- +1 KILL DIC
- SET (DIC,DIE)="^FH(116.2,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=116.2
- +2 SET DIC("DR")=".01"
- 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:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99")
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=116.2
- DO ^DIE
- IF '$DATA(DA)
- DO KIL
- GOTO EN3
- +4 if $ORDER(^FH(116.2,DA,"R",0))<1
- SET $PIECE(^FH(116.2,DA,0),"^",4)="N"
- DO KIL
- GOTO EN3
- EN4 ; List Production Diets
- +1 WRITE !!,"The list requires a 132 column printer.",!
- +2 WRITE !
- SET L=0
- SET DIC="^FH(116.2,"
- SET FLDS="[FHPROD]"
- SET BY="8,.01"
- +3 SET FR="@"
- SET TO=""
- SET DHD="PRODUCTION DIETS"
- DO EN1^DIP
- DO RSET
- QUIT
- EN5 ; Enter/Edit Production Facilities
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.71,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.71
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN5
- +3 SET DA=+Y
- SET DR=".01:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.71
- DO ^DIE
- DO KIL
- GOTO EN5
- EN6 ; Enter/Edit Service Points
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.72,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.72
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN6
- +3 SET DA=+Y
- SET DR=".01:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.72
- DO ^DIE
- IF '$DATA(DA)
- DO KIL
- GOTO EN6
- +4 SET DA(1)=DA
- SET DIK="^FH(119.72,DA(1),""A"","
- FOR DA=0:0
- SET DA=$ORDER(^FH(119.72,DA(1),"A",DA))
- if DA'>0
- QUIT
- IF $PIECE($GET(^(DA,0)),"^",2,8)?."^"
- DO ^DIK
- +5 SET DIK="^FH(119.72,DA(1),""B"","
- FOR DA=0:0
- SET DA=$ORDER(^FH(119.72,DA(1),"B",DA))
- if DA'>0
- QUIT
- IF $PIECE($GET(^(DA,0)),"^",2,22)?."^"
- DO ^DIK
- +6 DO KIL
- GOTO EN6
- EN7 ; Enter/Edit Communication Offices
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.73,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.73
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN7
- +3 SET DA=+Y
- SET DR=".01:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.73
- DO ^DIE
- DO KIL
- GOTO EN7
- EN8 ; Enter/Edit Supplemental Feeding Sites
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.74,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=119.74
- +2 SET DIC("DR")=".01"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN8
- +3 SET DA=+Y
- SET DR=".01:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.74
- DO ^DIE
- DO KIL
- GOTO EN8
- RSET KILL %ZIS
- SET IOP=""
- DO ^%ZIS
- KIL GOTO KILL^XUSCLEAN