12:19 PM  26-OCT-98
PATCH #2 FOR DIETETICS V3.16
FHASS
FHASS ; GLRISC/REL - Nutritional Assessment ; 22-May-88  11:45 am ;  [ 10/18/94  12:17 PM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 ;
 ;IHS/ORDC/LJF 10/17/94 start of code for PATCH #1
 I '$D(FHZRVN) D
 .S FHNULL="",(FHZRVN,FHZRVF)="FHNULL"
 .I $D(^%ZIS(2,IOST(0),5)) S FHZRVN=$P(^(5),U,4),FHZRVF=$P(^(5),U,5)
 ;IHS/ORDC/LJF 10/17/94 end of code for PATCH #1
 ;
 W @IOF,@FHZRVN,!!?18,"N U T R I T I O N A L   A S S E S S M E N T",?78,"",@FHZRVF,!! S X="T" D ^%DT S DT=Y  ;IHS/ANMC/LJF 9/25/89 added reverse video
F1 ; Select Patient
 S ALL=1,AUPNLK("ALL")="" D ^FHDPA K AUPNLK("ALL") G PAT:X="*",KIL:'DFN S NAM=$P(Y(0),U,1),SEX=$P(Y(0),U,2),AGE=$P(Y(0),U,3) G:SEX=""!(AGE="") P1  ;IHS/ANMC/LJF 5/22/90 added set of AUPNLK("ALL") for universal lookup
 S AGE=$E(DT,1,3)-$E(AGE,1,3)-($E(DT,4,7)<$E(AGE,4,7))
 I AGE<18 W *7,!!?5,"Calories may be inaccurate for ages less than 18!"
F4 R !!,"Height in Inches: ",HGT:DTIME G:"^"[HGT KIL I HGT'?.N.1".".N!(HGT<30)!(HGT>90) W *7,"  Valid range is 30-90" G F4
F5 R !,"Weight in Pounds: ",WGT:DTIME G:"^"[WGT KIL I WGT'?.N.1".".N!(WGT<60)!(WGT>400) W *7,"  Valid range is 60-400" G F5
F50 W !,"Usual Weight in Pounds: ",WGT," // " R UWGT:DTIME G:'$T KIL S:UWGT="" UWGT=WGT G:UWGT="^" KIL I UWGT'?.N.1".".N!(UWGT<60)!(UWGT>400) W *7," ??" G F50
F51 R !,"Frame Size (SMALL, MEDIUM, LARGE) MED// ",FRM:DTIME G:'$T!(FRM="^") KIL S:FRM="" FRM="M" I $P("SMALL",FRM,1)'="",$P("MEDIUM",FRM,1)'="",$P("LARGE",FRM,1)'="" W *7," ??" G F51
 S FRM=$E(FRM,1) S A1=$S(FRM="S":0.9,FRM="L":1.1,1:1)
 I SEX="M" S IBW=HGT-60*6+106*A1
 I SEX="F" S IBW=HGT-60*5+100*A1
TYP R !,"Is Patient an In-Patient? (Y/N): ",TYP:DTIME G:'$T!("^"[TYP) KIL I $P("YES",TYP,1)'="",$P("NO",TYP,1)'="" W *7," ??" G TYP
 S TYP=$E(TYP,1)
F7 R !,"Does Patient have an Amputation? NO// ",AMP:DTIME G:'$T!(AMP="^") KIL S:AMP="" AMP="N" I $P("YES",AMP,1)'="",$P("NO",AMP,1)'="" G F7
 S AMP=$E(AMP,1),AMP=AMP="Y" G:'AMP F9
F71 W !!,"Amputee Types: (may be multiple, e.g: 2,2,5)",!!?2,"1  Upper Leg (11.6%)",?40,"5  Hand (0.8%)",!?2,"2  Below Knee (5.8%)",?40,"6  Forearm (2.3%)"
 W !?2,"3  Above Knee (8.4%)",?40,"7  Upper Arm (3.6%)",!?2,"4  Foot (1.8%)"
F8 S AMP=1 R !!?2,"Type: ",X:DTIME F K=1:1 S Y=$P(X,",",K) Q:Y=""  G:Y'?1N!(Y<1)!(Y>7) F81 S AMP=AMP-$P(".116,.058,.084,.018,.008,.023,.036",",",Y)
 S IBW=$J(AMP*IBW,0,0) G F9
F81 W *7," ?? Enter digits 1-7 separated by commas" G F71
F9 S OPT=$S(.9*IBW'<WGT:"G",1.1*IBW<WGT:"L",1:"M")
 W !!,"Comparison with IBW indicates need for ",$S(OPT="M":"MAINTENANCE",OPT="L":"WEIGHT LOSS",1:"WEIGHT GAIN")
F10 W !!,"Select Option (GAIN WT, LOSE WT, MAINTAIN WT): ",$S(OPT="M":"MAINTAIN",OPT="G":"GAIN",1:"LOSE"),"// " R XX:DTIME G:'$T!(XX="^") KIL
 I $P("GAIN WT",XX,1)'="",$P("LOSE WT",XX,1)'="",$P("MAINTAIN WT",XX,1)'="" W *7,"  Enter G, L, or M" G F10
 S XX=$E(XX,1) S:XX'="" OPT=XX
F11 R !!,"Do you wish Lab/Skinfold Assessment? NO// ",EXT:DTIME G:'$T KIL S:EXT="" EXT="N" G:EXT="^" KIL I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7," ??" G F11
 S EXT=$E(EXT,1) D:EXT="Y" ^FHASS2 G KIL:EXT="K",^FHASS1
KIL ; Final variable kill
 K %IS,A1,A2,A3,ACT,AF,AGC,AGE,ALL,AMP,BEE,DFN,EXT,DTP,FF,FRM,HGT,IBW,IF,J,K,KCAL,NAM,NIT,OPT,Q,POP,PRO,RTE,SEX,SXC,TAB,TYP,UWGT,WGT,X,XX,Y Q
PAT R !!,"Enter Patient's Name: ",NAM:DTIME G:"^"[NAM KIL
 I NAM["?"!(NAM'?.ANP)!(NAM["^") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
P1 R !,"Sex: ",SEX:DTIME G:"^"[SEX KIL I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7,"  Enter M or F" G P1
 S SEX=$E(SEX,1)
P2 R !,"Age: ",AGE:DTIME G:"^"[AGE KIL I AGE'?1N.N!(AGE<18)!(AGE>124) W !?5,"Enter Age in years between 18 and 124" G P2
 G F4

FHNU10
FHNU10 ; GLRISC/REL - Print RDA Values ; 26-Feb-87  11:28 am  [ 10/18/94  9:34 AM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 W !!!,?10,"Remember, this report prints using 132 columns!",!!  ;IHS/ANMC/LJF 3/27/90 added line
 K IOP,%IS S %IS("A")="Select LIST PRINTER: ",%IS="Q" D ^%ZIS K %IS,IOP G:POP KIL  ;IHS/ANMC/LJF 3/27/90 removed M from set of %IS
 I $D(IO("Q")) S FHPGM="Q1^FHNU10",FHLST="" D EN2^FH G KIL
 U IO D Q1 U IO(0) X ^%ZIS("C") S IOP="" D ^%ZIS K %IS,IOP G KIL
Q1 S %DT="XT",X="N" D ^%DT S DTP=Y D DTP^FH
 S X=132 X ^%ZOSF("RM")  ;IHS/ANMC/LJF 3/27/90 added line to force 132 column width
 S PG=0 D HD1,HD2 S ITMS=$T(ITMS+1)
 S NM="" F KK=0:0 S NM=$O(^FH(112.2,"B",NM)) Q:NM=""  F FN=0:0 S FN=$N(^FH(112.2,"B",NM,FN)) Q:FN<1  D L1
 I IOST?1"C-".E R !!,"Hit <return> when ready to continue.",FHX:DTIME  ;IHS/ANMC/LJF 3/27/90 added line for printing to CRT
 D HD1,HD3 S ITMS=$T(ITMS+2)
 S NM="" F KK=0:0 S NM=$O(^FH(112.2,"B",NM)) Q:NM=""  F FN=0:0 S FN=$N(^FH(112.2,"B",NM,FN)) Q:FN<1  D L1
 W ! Q
L1 S X=$S($D(^FH(112.2,FN,0)):^(0),1:"") W !,$E($P(X,"^",1),1,30)
 S X=$S($D(^FH(112.2,FN,1)):^(1),1:"")
 F LL=3:1 S Y=$P(ITMS,";",LL) Q:Y=""  S P1=$P(Y,",",1),P2=$P(Y,",",2),P3=$P(Y,",",3),P4=$P(Y,",",4),Y=$P(X,"^",P1) W:Y'="" ?P2,$J(Y,P3,P4)
 Q
HD1 S PG=PG+1 W @IOF,"RDA VALUES",?104,DTP,?125,"Page ",PG Q
HD2 W !?32,"Protein",?41,"Vitamin",?50,"Vitamin",?59,"Vitamin",?68,"Thiamin",?77,"Riboflavin",?89,"Niacin",?97,"Vitamin",?106,"Folate",?115,"Vitamin" ;IHS/ORDC/LJF 10/18/94 PATCH #1
 W !,"Name",?36,"Gm.",?44,"A IU",?53,"E Mg",?62,"C Mg",?73,"Mg",?85,"Mg",?93,"Mg",?99,"B6 Mg",?110,"Mcg",?115,"B12 Mcg"
 D LN Q
HD3 W !?32,"Calcium",?41,"Phosphorus",?53,"Magnesium",?64,"Iron",?70,"Zinc",?76,"Pantothenic",?89,"Copper",?97,"Manganese",?108,"Sodium",?116,"Potassium"
 W !,"Name",?37,"Mg",?49,"Mg",?60,"Mg",?66,"Mg",?72,"Mg",?80,"Acid Mg",?93,"Mg",?104,"Mg",?112,"Mg",?123,"Mg"
 D LN Q
ITMS ;;Piece,?Tab,Size,Dec
 ;;1,32,6,1;2,41,6,0;3,50,5,0;4,59,5,0;5,68,5,1;6,77,7,1;7,89,4,0;8,97,5,1;9,106,5,0;10,115,5,1;
 ;;11,32,6,0;12,41,7,0;13,53,6,0;14,64,3,0;15,70,3,0;16,76,7,1;17,89,5,2;18,97,7,2;19,108,5,0;20,116,7,0;
LN W !,"-----------------------------------------------------------------------------------------------------------------------------------",! Q
KIL S X=80 X ^%ZOSF("RM") K %DT,%IS,DTP,FN,ITMS,KK,LL,NM,P1,P2,P3,P4,PG,POP,X,Y,FHX Q  ;IHS/ANMC/LJF 3/27/90 added code to change right margin back to 80; 5/22/90 added FHX to kill

FHNU12
FHNU12 ; GLRISC/REL - Recipe Analysis Output ; 30-Jan-88  11:55 am ;  [ 10/18/94  9:34 AM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 ;IHS/ORDC/LJF 10/18/94 PATCH #1 changed folacin to folate in listing
 ;                               under line label COM
 K A,B F K=1:1:32 S A(K)=0,B(K)=0
 S NX=0,SUM=0
D1 S NX=$N(FHM(NX)) I NX=-1 G D2
 S AMT=+FHM(NX) I TYP="C" S WT=$P(FHM(NX),",",3),AMT=AMT*WT
 S SUM=SUM+AMT
 S AMT=AMT/100,Y=$S($D(^FHNU(NX,1)):^(1),1:"") F K=1:1:20 S Z1=$P(Y,"^",K) I Z1'="" S A(K)=Z1*AMT+A(K),B(K)=B(K)+1
 S Y=$S($D(^FHNU(NX,2)):^(2),1:"") F K=21:1:32 S Z1=$P(Y,"^",K-20) I Z1'="" S A(K)=Z1*AMT+A(K),B(K)=B(K)+1
 G D1
D2 Q:'SUM  S PW=+$J(SUM/POR,0,2),SUM=SUM/100 F K=1:1:32 S:B(K) A(K)=A(K)/SUM,A(K)=+$J(A(K),0,3)
 W @IOF,!?23,"--- Analysis of Recipe Portion ---",!!?(80-$L(TIT)\2),TIT,!
 S SUM=PW/100 F K=1:1:32 S Y=$T(COM+K) W:K#2 ! S T1=$S(K#2:0,1:42),Z1=$P(Y,";",3),Z2=$P(Y,";",7) W ?T1,$P(Y,";",4)," (",B(Z1),")" I B(Z1) W ?(T1+19),$J(A(Z1)*SUM,8,$P(Y,";",6))," ",$P(Y,";",5)
 W !!,"Grams/Portion: ",PW
D3 R !!,"Do you wish to STORE this recipe in FOOD NUTRIENT File? ",YN:DTIME G FIN:'$T!("^"[YN) I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7,"  Answer YES or NO" G D3
 G FIN:YN?1"N".E
 K DIC,DINUM S DLAYGO=112,(DIC,DIE)="^FHNU(",DIC(0)="L",X=TIT D FILE^DICN G:Y<1 FIN  ;IHS/ANMC/LJF 5/22/90 added DLAYGO
 S DA=+Y,DR=".01;2//^S X=""svg."";3//^S X=PW;4;4.2;S:X="""" Y=99;4.4;99" W ! D ^DIE
 S (Z1,Z2)="" F K=1:1:20 S:B(K) $P(Z1,"^",K)=A(K)
 F K=21:1:32 S:B(K) $P(Z2,"^",K-20)=A(K)
 S ^FHNU(DA,1)=Z1,^(2)=Z2
FIN W ! K A,B,T1,Z1,Z2 Q
COM ;;
 ;;4;Calories;K;0;0
 ;;18;Vitamin A;IU;2;2
 ;;1;Protein;Gms;1;1
 ;;19;Ascorbic Acid;Mg;2;4
 ;;3;Carbohydrate;Gms;1;0
 ;;17;Vitamin E;Mg;2;3
 ;;2;Fat;Gms;1;0
 ;;21;Riboflavin;Mg;2;6
 ;;13;Sodium;Mg;2;19
 ;;20;Thiamin;Mg;2;5
 ;;12;Potassium;Mg;2;20
 ;;22;Niacin;Mg;2;7
 ;;8;Calcium;Mg;2;11
 ;;24;Vitamin B6;Mg;2;8
 ;;11;Phosphorus;Mg;2;12
 ;;26;Vitamin B12;Mcg;2;10
 ;;9;Iron;Mg;2;14
 ;;25;Folate;Mcg;2;9
 ;;14;Zinc;Mg;2;15
 ;;23;Pantothenic Ac;Mg;2;16
 ;;10;Magnesium;Mg;2;13
 ;;29;Cholesterol;Mg;1;0
 ;;16;Manganese;Mg;2;18
 ;;27;Linoleic Acid;Gms;1;0
 ;;15;Copper;Mg;2;17
 ;;28;Linolenic Acid;Gms;1;0
 ;;6;Crude Fiber;Gms;1;0
 ;;31;Monounsat. Fat;Gms;1;0
 ;;7;Dietary Fiber;Gms;1;0
 ;;32;Polyunsat. Fat;Gms;1;0
 ;;5;Water;Ml;1;0
 ;;30;Saturated Fat;Gms;1;0

FHNU6
FHNU6 ; GLRISC/REL - Abbreviated Analysis Output ; 13-Aug-85  8:19 pm  [ 10/18/94  9:35 AM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 ;IHS/ORDC/LJF 10/18/94 PATCH #1 changed folacin to folate in listing
 ;                               under line label COM
 K A,B F K=1:1:32 S A(K)=0,B(K)=0
 S NX=0
D1 S NX=$N(FHM(NX)) I NX=-1 G D2
 S AMT=+FHM(NX) I TYP="C" S WT=$P(FHM(NX),",",3),AMT=AMT*WT
 S AMT=AMT/100,Y=$S($D(^FHNU(NX,1)):^(1),1:"") F K=1:1:20 S Z1=$P(Y,"^",K) I Z1'="" S A(K)=Z1*AMT+A(K),B(K)=B(K)+1
 S Y=$S($D(^FHNU(NX,2)):^(2),1:"") F K=21:1:32 S Z1=$P(Y,"^",K-20) I Z1'="" S A(K)=Z1*AMT+A(K),B(K)=B(K)+1
 G D1
D2 S ZR=$S(RDA:^FH(112.2,RDA,1),1:"")
 W @IOF,!?28,"--- Analysis of Menu ---",!!?(80-$L(TIT)\2),TIT,!!?32,"RDA %",?74,"RDA %",!
 F K=1:1:32 S Y=$T(COM+K) W:K#2 ! S T1=$S(K#2:0,1:42),Z1=$P(Y,";",3),Z2=$P(Y,";",7) W ?T1,$P(Y,";",4)," (",B(Z1),")" I B(Z1) W ?(T1+19),$J(A(Z1),8,$P(Y,";",6))," ",$P(Y,";",5) I Z2,ZR'="" S Z2=A(Z1)/$P(ZR,U,Z2) W ?(T1+32),$J(Z2*100,5,1)
 W ! K A,B,T1,Z1,Z2,ZR Q
COM ;;
 ;;4;Calories;K;0;0
 ;;18;Vitamin A;IU;2;2
 ;;1;Protein;Gms;1;1
 ;;19;Ascorbic Acid;Mg;2;4
 ;;3;Carbohydrate;Gms;1;0
 ;;17;Vitamin E;Mg;2;3
 ;;2;Fat;Gms;1;0
 ;;21;Riboflavin;Mg;2;6
 ;;13;Sodium;Mg;2;19
 ;;20;Thiamin;Mg;2;5
 ;;12;Potassium;Mg;2;20
 ;;22;Niacin;Mg;2;7
 ;;8;Calcium;Mg;2;11
 ;;24;Vitamin B6;Mg;2;8
 ;;11;Phosphorus;Mg;2;12
 ;;26;Vitamin B12;Mcg;2;10
 ;;9;Iron;Mg;2;14
 ;;25;Folate;Mcg;2;9
 ;;14;Zinc;Mg;2;15
 ;;23;Pantothenic Ac;Mg;2;16
 ;;10;Magnesium;Mg;2;13
 ;;29;Cholesterol;Mg;1;0
 ;;16;Manganese;Mg;2;18
 ;;27;Linoleic Acid;Gms;1;0
 ;;15;Copper;Mg;2;17
 ;;28;Linolenic Acid;Gms;1;0
 ;;6;Crude Fiber;Gms;1;0
 ;;31;Monounsat. Fat;Gms;1;0
 ;;7;Dietary Fiber;Gms;1;0
 ;;32;Polyunsat. Fat;Gms;1;0
 ;;5;Water;Ml;1;0
 ;;30;Saturated Fat;Gms;1;0

FHZIN001
FHZIN001 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 Q:'DIFQ(112)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(112,0,"GL")
 ;;=^FHNU(
 ;;^DIC("B","FOOD NUTRIENTS",112)
 ;;=
 ;;^DIC(112,"%D",0)
 ;;=^^3^3^2901101^^^^
 ;;^DIC(112,"%D",1,0)
 ;;=This file contains both standard USDA nutreint data based upon
 ;;^DIC(112,"%D",2,0)
 ;;=Handbook 456 and Revised Handbook 8 as well as user entered data.
 ;;^DIC(112,"%D",3,0)
 ;;=The standard data includes 32 common nutrients.
 ;;^DD(112,0)
 ;;=FIELD^^99^41
 ;;^DD(112,0,"IX","AC",112,4)
 ;;=
 ;;^DD(112,0,"IX","AD",112,4.2)
 ;;=
 ;;^DD(112,0,"IX","AE",112,4.4)
 ;;=
 ;;^DD(112,0,"IX","AQ",112,.01)
 ;;=
 ;;^DD(112,0,"IX","B",112,.01)
 ;;=
 ;;^DD(112,0,"IX","B",112,4.2)
 ;;=
 ;;^DD(112,0,"IX","C",112,1)
 ;;=
 ;;^DD(112,0,"NM","FOOD NUTRIENTS")
 ;;=
 ;;^DD(112,0,"PT",112.63,.01)
 ;;=
 ;;^DD(112,.01,0)
 ;;=NAME^RF^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>60!($L(X)<3)!'(X'?1P.E)!(X'?.ANP) X
 ;;^DD(112,.01,1,0)
 ;;=^.1
 ;;^DD(112,.01,1,1,0)
 ;;=112^B
 ;;^DD(112,.01,1,1,1)
 ;;=S ^FHNU("B",$E(X,1,30),DA)=""
 ;;^DD(112,.01,1,1,2)
 ;;=K ^FHNU("B",$E(X,1,30),DA)
 ;;^DD(112,.01,1,2,0)
 ;;=112^AQ^MUMPS
 ;;^DD(112,.01,1,2,1)
 ;;=I $D(^FHNU(DA,.6)),$P(^(.6),"^",1)="Y" S ^FHNU("AQ",$E(X,1,30),DA)=""
 ;;^DD(112,.01,1,2,2)
 ;;=K ^FHNU("AQ",$E(X,1,30),DA)
 ;;^DD(112,.01,3)
 ;;=ANSWER MUST BE 3-60 CHARACTERS IN LENGTH
 ;;^DD(112,.01,21,0)
 ;;=^^1^1^2880717^
 ;;^DD(112,.01,21,1,0)
 ;;=This field contains the name of the food nutrient item.
 ;;^DD(112,.01,"DEL",1,0)
 ;;=I DUZ(0)'["#",DUZ(0)'["@"
 ;;^DD(112,.01,"DT")
 ;;=2850406
 ;;^DD(112,35,0)
 ;;=FOLATE; MCG/100G^NJ9,3^^2;5^K:+X'=X!(X>99999)!(X<0)!(X?.E1"."4N.N) X
 ;;^DD(112,35,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 99999
 ;;^DD(112,35,21,0)
 ;;=^^1^1^2880710^
 ;;^DD(112,35,21,1,0)
 ;;=This is the value per 100 grams for this nutrient.
 ;;^DD(112,35,"DT")
 ;;=2941017

FHZIN002
FHZIN002 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 Q:'DIFQ(112.2)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(112.2,0,"GL")
 ;;=^FH(112.2,
 ;;^DIC("B","RDA VALUES",112.2)
 ;;=
 ;;^DIC(112.2,"%D",0)
 ;;=^^4^4^2871125^
 ;;^DIC(112.2,"%D",1,0)
 ;;=This file contains the values of the Recommended Dietary Allowances,
 ;;^DIC(112.2,"%D",2,0)
 ;;=1989. Where ranges were originally specified, the file contains
 ;;^DIC(112.2,"%D",3,0)
 ;;=the mid-point. 'Estimated safe and adequate' values are used where
 ;;^DIC(112.2,"%D",4,0)
 ;;=no formal RDA exists.
 ;;^DD(112.2,0)
 ;;=FIELD^^22^24
 ;;^DD(112.2,0,"DT")
 ;;=2941017
 ;;^DD(112.2,0,"IX","B",112.2,.01)
 ;;=
 ;;^DD(112.2,0,"IX","C",112.2,.5)
 ;;=
 ;;^DD(112.2,0,"NM","RDA VALUES")
 ;;=
 ;;^DD(112.2,.01,0)
 ;;=NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E)!(X'?.ANP) X
 ;;^DD(112.2,.01,1,0)
 ;;=^.1
 ;;^DD(112.2,.01,1,1,0)
 ;;=112.2^B
 ;;^DD(112.2,.01,1,1,1)
 ;;=S ^FH(112.2,"B",$E(X,1,30),DA)=""
 ;;^DD(112.2,.01,1,1,2)
 ;;=K ^FH(112.2,"B",$E(X,1,30),DA)
 ;;^DD(112.2,.01,1,1,"%D",0)
 ;;=^^1^1^2911118^
 ;;^DD(112.2,.01,1,1,"%D",1,0)
 ;;=This is the normal B cross-reference of the NAME field.
 ;;^DD(112.2,.01,3)
 ;;=NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION
 ;;^DD(112.2,.01,21,0)
 ;;=^^2^2^2880717^
 ;;^DD(112.2,.01,21,1,0)
 ;;=This field contains the name of a category of people for whom
 ;;^DD(112.2,.01,21,2,0)
 ;;=Recommended Dietary Allowance values have been published.
 ;;^DD(112.2,.01,"DEL",1,0)
 ;;=I DUZ(0)'["@",'$D(^XUSEC("FHMGR",DUZ))
 ;;^DD(112.2,.5,0)
 ;;=MEMONIC^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>8!($L(X)<1) X
 ;;^DD(112.2,.5,1,0)
 ;;=^.1
 ;;^DD(112.2,.5,1,1,0)
 ;;=112.2^C
 ;;^DD(112.2,.5,1,1,1)
 ;;=S ^FH(112.2,"C",$E(X,1,30),DA)=""
 ;;^DD(112.2,.5,1,1,2)
 ;;=K ^FH(112.2,"C",$E(X,1,30),DA)
 ;;^DD(112.2,.5,3)
 ;;=ANSWER MUST BE 1-8 CHARACTERS IN LENGTH
 ;;^DD(112.2,.5,21,0)
 ;;=^^2^2^2880717^
 ;;^DD(112.2,.5,21,1,0)
 ;;=This is a short name, or memonic, for the RDA category of
 ;;^DD(112.2,.5,21,2,0)
 ;;=persons.
 ;;^DD(112.2,.5,"DT")
 ;;=2841005
 ;;^DD(112.2,1,0)
 ;;=PROTEIN GM.^NJ5,1^^1;1^K:+X'=X!(X>100)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,1,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 100
 ;;^DD(112.2,1,21,0)
 ;;=^^2^2^2880717^^^
 ;;^DD(112.2,1,21,1,0)
 ;;=This field represents the recommended amount of Protein per
 ;;^DD(112.2,1,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,2,0)
 ;;=VITAMIN A IU^NJ4,0^^1;2^K:+X'=X!(X>6000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,2,3)
 ;;=Type a Number between 0 and 6000, 0 Decimal Digits
 ;;^DD(112.2,2,21,0)
 ;;=^^2^2^2891211^^^^
 ;;^DD(112.2,2,21,1,0)
 ;;=This field represents the recommended amount of Vitamin A in
 ;;^DD(112.2,2,21,2,0)
 ;;=Retinol Equivalents per day for this RDA group.
 ;;^DD(112.2,2,"DT")
 ;;=2941017
 ;;^DD(112.2,3,0)
 ;;=VITAMIN E MG^NJ3,0^^1;3^K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,3,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 100
 ;;^DD(112.2,3,21,0)
 ;;=^^2^2^2880717^^^
 ;;^DD(112.2,3,21,1,0)
 ;;=This field represents the recommended amount of Vitamin E per
 ;;^DD(112.2,3,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,4,0)
 ;;=VITAMIN C MG^NJ3,0^^1;4^K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,4,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 100
 ;;^DD(112.2,4,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,4,21,1,0)
 ;;=This field represents the recommended amount of Vitamin C per
 ;;^DD(112.2,4,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,5,0)
 ;;=THIAMIN MG^NJ3,1^^1;5^K:+X'=X!(X>3)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,5,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 3
 ;;^DD(112.2,5,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,5,21,1,0)
 ;;=This field represents the recommended amount of Thiamin per
 ;;^DD(112.2,5,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,6,0)
 ;;=RIBOFLAVIN MG^NJ3,1^^1;6^K:+X'=X!(X>3)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,6,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 3
 ;;^DD(112.2,6,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,6,21,1,0)
 ;;=This field represents the recommended amount of Riboflavin per
 ;;^DD(112.2,6,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,7,0)
 ;;=NIACIN MG^NJ2,0^^1;7^K:+X'=X!(X>50)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,7,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 50
 ;;^DD(112.2,7,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,7,21,1,0)
 ;;=This field represents the recommended amount of Niacin per
 ;;^DD(112.2,7,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,8,0)
 ;;=VITAMIN B6 MG^NJ3,1^^1;8^K:+X'=X!(X>5)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,8,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 5
 ;;^DD(112.2,8,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,8,21,1,0)
 ;;=This field represents the recommended amount of Vitamin B6 per
 ;;^DD(112.2,8,21,2,0)
 ;;=day for this RDA group.

FHZIN003
FHZIN003 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 Q:'DIFQ(112.2)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(112.2,9,0)
 ;;=FOLATE MCG^NJ4,0^^1;9^K:+X'=X!(X>1000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,9,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 1000
 ;;^DD(112.2,9,21,0)
 ;;=^^2^2^2891117^^^
 ;;^DD(112.2,9,21,1,0)
 ;;=This field represents the recommended amount of Folate per
 ;;^DD(112.2,9,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,10,0)
 ;;=VITAMIN B12 MCG^NJ3,1^^1;10^K:+X'=X!(X>5)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,10,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 5
 ;;^DD(112.2,10,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,10,21,1,0)
 ;;=This field represents the recommended amount of Vitamin B12 per
 ;;^DD(112.2,10,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,11,0)
 ;;=CALCIUM MG^NJ4,0^^1;11^K:+X'=X!(X>2000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,11,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 2000
 ;;^DD(112.2,11,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,11,21,1,0)
 ;;=This field represents the recommended amount of Calcium per
 ;;^DD(112.2,11,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,12,0)
 ;;=PHOSPHORUS MG^NJ4,0^^1;12^K:+X'=X!(X>2000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,12,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 2000
 ;;^DD(112.2,12,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,12,21,1,0)
 ;;=This field represents the recommended amount of Phosphorus per
 ;;^DD(112.2,12,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,13,0)
 ;;=MAGNESIUM MG^NJ4,0^^1;13^K:+X'=X!(X>1000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,13,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 1000
 ;;^DD(112.2,13,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,13,21,1,0)
 ;;=This field represents the recommended amount of Magnesium per
 ;;^DD(112.2,13,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,14,0)
 ;;=IRON MG^NJ3,0^^1;14^K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,14,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 100
 ;;^DD(112.2,14,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,14,21,1,0)
 ;;=This field represents the recommended amount of Iron per
 ;;^DD(112.2,14,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,15,0)
 ;;=ZINC MG^NJ2,0^^1;15^K:+X'=X!(X>50)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,15,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 50
 ;;^DD(112.2,15,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,15,21,1,0)
 ;;=This field represents the recommended amount of Zinc per
 ;;^DD(112.2,15,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,16,0)
 ;;=PANTOTHENIC ACID MG^NJ4,1^^1;16^K:+X'=X!(X>20)!(X<0)!(X?.E1"."2N.N) X
 ;;^DD(112.2,16,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 20
 ;;^DD(112.2,16,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,16,21,1,0)
 ;;=This field represents the recommended amount of Pantothenic Acid per
 ;;^DD(112.2,16,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,17,0)
 ;;=COPPER MG^NJ5,2^^1;17^K:+X'=X!(X>10)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(112.2,17,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 10
 ;;^DD(112.2,17,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,17,21,1,0)
 ;;=This field represents the recommended amount of Copper per
 ;;^DD(112.2,17,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,18,0)
 ;;=MANGANESE MG^NJ5,2^^1;18^K:+X'=X!(X>20)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(112.2,18,3)
 ;;=TYPE A NUMBER BETWEEN 0 AND 20
 ;;^DD(112.2,18,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,18,21,1,0)
 ;;=This field represents the recommended amount of Manganese per
 ;;^DD(112.2,18,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,19,0)
 ;;=SODIUM MG^NJ4,0^^1;19^K:+X'=X!(X>5000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,19,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 5000
 ;;^DD(112.2,19,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,19,21,1,0)
 ;;=This field represents the recommended amount of Sodium per
 ;;^DD(112.2,19,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,20,0)
 ;;=POTASSIUM MG^NJ5,0^^1;20^K:+X'=X!(X>20000)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(112.2,20,3)
 ;;=TYPE A WHOLE NUMBER BETWEEN 0 AND 20000
 ;;^DD(112.2,20,21,0)
 ;;=^^2^2^2880717^^
 ;;^DD(112.2,20,21,1,0)
 ;;=This field represents the recommended amount of Potassium per
 ;;^DD(112.2,20,21,2,0)
 ;;=day for this RDA group.
 ;;^DD(112.2,21,0)
 ;;=VITAMIN K MCG^NJ6,2^^1;21^K:+X'=X!(X>999)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(112.2,21,3)
 ;;=Type a Number between 0 and 999, 2 Decimal Digits
 ;;^DD(112.2,21,21,0)
 ;;=^^2^2^2921107^
 ;;^DD(112.2,21,21,1,0)
 ;;=This field represents the recommended amount of Vitamin K
 ;;^DD(112.2,21,21,2,0)
 ;;=per day for this RDA group.
 ;;^DD(112.2,21,"DT")
 ;;=2920704
 ;;^DD(112.2,22,0)
 ;;=SELENIUM MCG^NJ6,2^^1;22^K:+X'=X!(X>999)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(112.2,22,3)
 ;;=Type a Number between 0 and 999, 2 Decimal Digits
 ;;^DD(112.2,22,21,0)
 ;;=^^2^2^2921107^^
 ;;^DD(112.2,22,21,1,0)
 ;;=This field represents the recommended amount of Selenium

FHZIN004
FHZIN004 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 Q:'DIFQ(112.2)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(112.2,22,21,2,0)
 ;;=per day for this RDA group.
 ;;^DD(112.2,22,"DT")
 ;;=2920704

FHZIN005
FHZIN005 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 Q:'DIFQ(112.6)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(112.6,0,"GL")
 ;;=^FHUM(
 ;;^DIC("B","USER MENU",112.6)
 ;;=
 ;;^DIC(112.6,"%D",0)
 ;;=^^2^2^2900618^^^^
 ;;^DIC(112.6,"%D",1,0)
 ;;=This file contains menus of food items, classified by day and meal,
 ;;^DIC(112.6,"%D",2,0)
 ;;=which are saved for nutrient analysis.
 ;;^DD(112.6,0)
 ;;=FIELD^^1^5
 ;;^DD(112.6,0,"DT")
 ;;=2941017
 ;;^DD(112.6,0,"ID",.7)
 ;;=W:$D(^("0")) "   ",$E($P(^("0"),U,3),4,5)_"-"_$E($P(^("0"),U,3),6,7)_"-"_$E($P(^("0"),U,3),2,3)
 ;;^DD(112.6,0,"IX","B",112.6,.01)
 ;;=
 ;;^DD(112.6,0,"NM","USER MENU")
 ;;=
 ;;^DD(112.6,.01,0)
 ;;=NAME^RV^^0;1^Q
 ;;^DD(112.6,.01,1,0)
 ;;=^.1
 ;;^DD(112.6,.01,1,1,0)
 ;;=112.6^B
 ;;^DD(112.6,.01,1,1,1)
 ;;=S ^FHUM("B",$E(X,1,30),DA)=""
 ;;^DD(112.6,.01,1,1,2)
 ;;=K ^FHUM("B",$E(X,1,30),DA)
 ;;^DD(112.6,.01,3)
 ;;=
 ;;^DD(112.6,.01,21,0)
 ;;=^^3^3^2880717^
 ;;^DD(112.6,.01,21,1,0)
 ;;=This field contains the name of a user menu. This is a list of
 ;;^DD(112.6,.01,21,2,0)
 ;;=food items, and amounts, that a user wishes to have analyzed
 ;;^DD(112.6,.01,21,3,0)
 ;;=for nutrient content.
 ;;^DD(112.6,.01,"DT")
 ;;=2900403
 ;;^DD(112.6,.01,"V",0)
 ;;=^.12P^2^2
 ;;^DD(112.6,.01,"V",1,0)
 ;;=9000001^Patient-linked Menu^1^PT^n^n
 ;;^DD(112.6,.01,"V",2,0)
 ;;=9002260^General Menu^2^GEN^n^y

FHZIN006
FHZIN006 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 I DSEC F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(112,0,"DD")
 ;;=@
 ;;^DIC(112,0,"DEL")
 ;;=f
 ;;^DIC(112,0,"LAYGO")
 ;;=f
 ;;^DIC(112,0,"RD")
 ;;=F
 ;;^DIC(112,0,"WR")
 ;;=f
 ;;^DIC(112.2,0,"DD")
 ;;=@
 ;;^DIC(112.2,0,"DEL")
 ;;=#
 ;;^DIC(112.2,0,"LAYGO")
 ;;=#
 ;;^DIC(112.2,0,"RD")
 ;;=F
 ;;^DIC(112.2,0,"WR")
 ;;=#
 ;;^DIC(112.6,0,"DD")
 ;;=@
 ;;^DIC(112.6,0,"DEL")
 ;;=F
 ;;^DIC(112.6,0,"LAYGO")
 ;;=F
 ;;^DIC(112.6,0,"RD")
 ;;=F
 ;;^DIC(112.6,0,"WR")
 ;;=F

FHZIN007
FHZIN007 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"DIE",629,0)
 ;;=FHZEDIT^2870729^f^112^^f
 ;;^UTILITY(U,$J,"DIE",629,"DR",1,112)
 ;;=1;2;3;4;4.2;4.4;11;12;13;14;15;16;17;18;19;20;21;22;23;24;25;26;27;28;29;30;31;32;33;34;35;36;37;38;39;40;41;42;
 ;;^UTILITY(U,$J,"PKG",266,0)
 ;;=N&D PATCHES^FHZ^PACKAGE ENTRY USED TO PATCH DIETETICS SOFTWARE
 ;;^UTILITY(U,$J,"PKG",266,4,0)
 ;;=^9.44PA^3^3
 ;;^UTILITY(U,$J,"PKG",266,4,1,0)
 ;;=112.2
 ;;^UTILITY(U,$J,"PKG",266,4,1,222)
 ;;=y^y^^n^^^n
 ;;^UTILITY(U,$J,"PKG",266,4,2,0)
 ;;=112.6
 ;;^UTILITY(U,$J,"PKG",266,4,2,1,0)
 ;;=^9.45A^1^1
 ;;^UTILITY(U,$J,"PKG",266,4,2,1,1,0)
 ;;=NAME
 ;;^UTILITY(U,$J,"PKG",266,4,2,1,"B","NAME",1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,4,2,222)
 ;;=y^y^^n^^^n
 ;;^UTILITY(U,$J,"PKG",266,4,3,0)
 ;;=112
 ;;^UTILITY(U,$J,"PKG",266,4,3,1,0)
 ;;=^9.45A^1^1
 ;;^UTILITY(U,$J,"PKG",266,4,3,1,1,0)
 ;;=FOLATE; MCG/100G
 ;;^UTILITY(U,$J,"PKG",266,4,3,1,"B","FOLATE; MCG/100G",1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,4,3,222)
 ;;=y^y^^n^^^n
 ;;^UTILITY(U,$J,"PKG",266,4,"B",112,3)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,4,"B",112.2,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,4,"B",112.6,2)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,22,0)
 ;;=^9.49I^1^1
 ;;^UTILITY(U,$J,"PKG",266,22,1,0)
 ;;=3.16^2941018
 ;;^UTILITY(U,$J,"PKG",266,22,"B",3.16,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",266,"INIT")
 ;;=FHZPOST^
 ;;^UTILITY(U,$J,"SBF",112,112)
 ;;=
 ;;^UTILITY(U,$J,"SBF",112.2,112.2)
 ;;=
 ;;^UTILITY(U,$J,"SBF",112.6,112.6)
 ;;=

FHZINIT
FHZINIT ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S U="^",DIFQ=0,DIFROM="3.16" W !,"This version (#3.16) of 'FHZINIT' was created on 18-OCT-1994"
 W !?9,"(at ORDC, by VA FileMan V.19.0)",!
 I $D(^DD("VERSION")),^("VERSION")'<19 G GO:$N(^("VERSION","19.0"))<0 W !,"BUT I'M OBSOLETE!!" G Q
 W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<19 W !,"BUT I NEED VERSION 19 OF THE VA FILEMAN!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^FHZINIT"_$E("5",DIFRIR) D @DIFRRTN
 W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:6 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="3.16" D PKG:'$D(DIFROM(0)),^FHZINIT1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:6 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^FHZINIT2,^FHZINIT3
 L  S DUZ=DIDUZ W:1 !,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 D ^FHZPOST,NOW^%DTC S DIFROM("INIT")=%
 I DIFROM F DIF=1:2:6 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^FHZINIT2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W *7,!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W *7,!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,*7,"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W *7,!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;N&D PATCHES^FHZ;10
ERX W *7,!!,"This INIT was built as a Network Mail Message and can ONLY be installed",!,"within the Mail system!!" G Q

FHZINIT1
FHZINIT1 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 F X="DIE" D W Q:'$D(DIFQ)
 Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$N(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^FHZIN" F R=1001:1:1007 D ROU W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$N(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$N(^UTILITY(U,$J,DDF(1),D0)) Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;SCREEN TEMPLATE
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$N(^DD(D,DIK)) Q:DIK<0  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
ROU I R<2000 D @(DN_$E(R,2,4)) Q
 I R=2000 S R=2016
 S %C=R#36+48,%B=R-2016\36+48 S:%B>57 %B=%B+7 S:%C>57 %C=%C+7
 I $C(%B)?1N,$C(%C)?1N S R=R+1 G ROU
 D @(DN_$C(48,%B,%C))
 Q
MSG ;
 I $P(^XMB(3.9,XMZ,0),U,7)'="X" Q
 S X=$S($D(^XMB(3.9,XMZ,2,XCN,0)):^(0),1:"") Q:X=""
M0 D M1 Q:$P(X,"$END MESSAGE")=""  D SAVE,NT G M0
NT S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:XCN'?1.N  S X=^(XCN,0) Q
SAVE D NT Q:$E(X)="$"  S Y=X D NT Q:$E(X)="$"
 I $A(X)=126 S A0=X D NT S X=A0_$E(X,2,999) K A0
 S:% @Y=$E(X,2,999) G SAVE
 Q
M1 S Y=$E(X,2,4),%=0 I Y="DDD" S D=+$P(X,"(#",2),%=DIFQ(D) Q:D  S:$P(X,"(#",2)["FILE SECURITY" %=DSEC Q
 Q:Y="END"
 I Y="DTA" S %=DIFQR(D) Q
 I (Y="OR ")!(Y="PKG") S %=1 Q
 I $T(@Y)]"" S %=1 Q
 Q

FHZINIT2
FHZINIT2 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$N(^UTILITY(U,$J,N,R)) Q:R<0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$N(^UTILITY("DIFROM",$J,N,R)) Q:R<0  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$N(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

FHZINIT3
FHZINIT3 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$N(^UTILITY("DIFROM",$J,N,X)) Q:X<0  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$N(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^FHZINIT4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X),^DIC(19,"AD",+I,DA,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q

FHZINIT4
FHZINIT4 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$N(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

FHZINIT5
FHZINIT5 ; ; 18-OCT-1994
 ;;3.16;N&D PATCHES;;OCT 18, 1994
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:6 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;N&D PATCHES^FHZ
 ;;112;FOOD NUTRIENTS;^FHNU(;1;y;y;;n;;;n
 ;;
 ;;112.2;RDA VALUES;^FH(112.2,;0;y;y;;n;;;n
 ;;
 ;;112.6IV;USER MENU;^FHUM(;1;y;y;;n;;;n
 ;;

FHZPOST
FHZPOST ;IHS/ORDC/LJF - POST INIT;  [ 10/18/94  9:35 AM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 ;
 ;Deletes FHZ entry in package file; used only to install patches
 S DA=$O(^DIC(9.4,"C","FHZ",0)) Q:DA=""
 S DIK="^DIC(9.4," D ^DIK
 K DA,DIK Q

FHZVARS
FHZVARS ;IHS/ANMC/LJF - MAIN MENU ENTRY ACTIONS ; [ 10/18/94  9:33 AM ]
 ;;3.16;DIETETICS;**1**;NOV 01, 1990
 ;
 ;set FHPAR - site parameter variable
 S X=^DD("SITE",1),FHPAR=$S($D(^FH(119.9,X,0)):^(0),1:"")
 ;
RVON ;set reverse video variables
 S FHNULL="",(FHZRVN,FHZRVF)="FHNULL"
 I $D(^%ZIS(2,IOST(0),5)) S FHZRVN=$P(^(5),"^",4),FHZRVF=$P(^(5),"^",5)
 ;
L1 D ^XBCLS W !?33,"*************",!,?29,"****",?46,"****" ;IHS/ORDC/LJF 10/17/94 PATCH #1
 W !,?27,"****",?48,"****"
L2 W !,?25,"***"," INDIAN HEALTH SERVICE ","***"
 W !,?26,"***  "," DIETETICS SYSTEM "," ***"
 S X=$O(^DIC(9.4,"C","FH",0))
 I X="" W !!,"VERSION ERROR; NOTIFY YOUR SITE MANAGER!",!! Q
VERS W !,?27,"***   "," VERSION ",^DIC(9.4,X,"VERSION")," ","  ***"
 W !,?29,"****",?46,"****",!,?31,"****",?44,"****",!?34,"**********"
 ;
SITE I '$D(DUZ(2)) W !!,"YOU MUST SIGN ON PROPERLY THROUGH THE KERNEL TO USE THIS PACKAGE!" S XQUIT=1 Q
 S X=$S($D(^DIC(4,DUZ(2),0))#2:$P(^(0),"^"),1:"") W !!,?80-$L(X)\2,X
 I X="" W !!,"INVALID FACILITY; NOTIFY YOUR SITE MANAGER!" S XQUIT="" Q
 S SITE=$S($D(^AUTTSITE(1,0)):$P(^(0),"^"),1:"")
 I SITE="" W *7,!!,"RPMS SITE IS NOT DEFINED",!,"NOTIFY YOUR SITE MANGER" S XQUIT=1 Q
 I DUZ(2)'=SITE W *7,!!,"YOU ARE NOT SIGNED ON TO THE RPMS SITE",!,"NOTIFY YOUR SITE MANAGER" S XQUIT=1
 K SITE,X Q
 ;
EXIT K FHZRVN,FHZRVF,FHPAR,FHNULL Q

FH
FH ; GLRISC/REL - Dietetics System ; 8/6/88  10:48 ; [ 10/26/1998  11:13 AM ]
 ;;3.16;DIETETICS;**2**;;1NOV90
 D EN4 S FHA1=1 D ^FHVER K FHA1
OP K G F I=1:1 S A=$P($T(PGMS+I),";",3,99) Q:A=""  I @$P(A,";",2) S G($E(A,1,2))=A
 W !! Q:$O(G(""))=""  S A="" F I=0:0 S A=$O(G(A)) Q:A=""  W !?6,$P(G(A),";",1)
O1 R !!?6,"Select Option: ",A:DTIME Q:'$T!("^"[A)  I A'?2U W *7,"  Enter 2 Letters of Option" G O1
 I '$D(G(A)) W *7,"  ??" G O1
 S X=$P(G(A),";",3) K A,I,G D @X G OP
EN0 ; Set Dietetics Patient File Entry
 Q:'$D(^FH(119.9))  ;IHS/ANMC/LJF 9/19/90 needed for ver 3.16
SET I '$D(^FHPT(DA(1))) S ^FHPT(DA(1),0)=DA(1),$P(^FHPT(0),"^",3)=DA(1),$P(^FHPT(0),"^",4)=$P(^(0),"^",4)+1,^FHPT(DA(1),"DA",0)="^115.01^"
 I $D(^FHPT(DA(1),"DA",DA)) S $P(^(DA,0),"^",1)=X Q
 S $P(^FHPT(DA(1),"DA",0),"^",3)=DA,$P(^(0),"^",4)=$P(^(0),"^",4)+1
 S ^FHPT(DA(1),"DA",DA,0)=X_"^1^^^^^^^"_DUZ
 S ^FHPT(DA(1),"DA",DA,"AC",X,0)=X_"^1",^FHPT(DA(1),"DA",DA,"AC",0)="^115.14^"_X_"^1",^FHPT(DA(1),"DA",DA,"DI",0)="^115.02A^1^1"
 S FHX1=$P(^FH(119.9,^DD("SITE",1),0),"^",4)
 I 'FHX1 S ^FHPT(DA(1),"DA",DA,"DI",1,0)="1^^^^^^X^^"_X_"^^"_DUZ_"^"_X G SK1
 S FHX2=$S($D(^FH(111,FHX1,0)):$P(^(0),"^",5),1:"")
 S ^FHPT(DA(1),"DA",DA,"DI",1,0)="1^"_FHX1_"^^^^^^T^"_X_"^^"_DUZ_"^"_X_"^"_FHX2
SK1 K FHX1,FHX2 Q
EN2 ; Queue a task
 K IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN=FHPGM,ZTSAVE("FHPAR")=""
 F V3=1:1 S V1=$P(FHLST,"^",V3) Q:V1=""  S ZTSAVE(V1)=""
 D ^%ZTLOAD W !,"Request Queued",! K V1,V3,FHPGM,FHLST,ZTSK Q
EN4 ; Kill System Variables
 S DUZ(0)=$S($D(FHDUZ):FHDUZ,1:DUZ(0)) K FHPAR,FHDUZ Q
DTP ; Printable Date/Time
 ;BEGINNING Y2K FIX
 ;S %1=DTP,DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_$E(DTP,2,3)
 S %1=DTP,DTP=$$FMTE^XLFDT($P(DTP,".",1),1)  ;Y2000
 ;END Y2K FIX BLOCK
 S:%1#1 %2=+$E(%1_"0",9,10),DTP=DTP_$J($S(%2>12:%2-12,1:%2),3)_":"_$E(%1_"000",11,12)_$S(%2<12:"am",%2<24:"pm",1:"m") K %1,%2 Q
PGMS ;;
 ;;CD  Clinical Dietetics;1;^FHCLN
 ;;AD  Dietetic Administration;1;^FHADM
 ;;SY  System Management;1;^FHSYS
 ;;DM  Dump Patient Data;1;^FHDMP