source: FOIAVistA/trunk/r/DIETETICS-FH/FHNU10.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1FHNU10 ; HISC/REL - Print DRI Values ;3/8/95 13:26
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 W !!,"The list requires a 132 column printer.",!
4 W ! K IOP,%ZIS S %ZIS("A")="Select LIST PRINTER: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
5 I $D(IO("Q")) S FHPGM="Q1^FHNU10",FHLST="" D EN2^FH G KIL
6 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
7Q1 ; Print the DRI Values
8 D NOW^%DTC S DTP=% D DTP^FH
9 S PG=0 D HD1,HD2 S ITMS=$T(ITMS+1)
10 S MNE="" F S MNE=$O(^FH(112.2,"C",MNE)) Q:MNE="" S FN=$O(^FH(112.2,"C",MNE,0)) D L1
11 D HD1,HD3 S ITMS=$T(ITMS+2)
12 S MNE="" F S MNE=$O(^FH(112.2,"C",MNE)) Q:MNE="" S FN=$O(^FH(112.2,"C",MNE,0)) D L1
13 D HD1,HD4 S ITMS=$T(ITMS+3)
14 S MNE="" F S MNE=$O(^FH(112.2,"C",MNE)) Q:MNE="" S FN=$O(^FH(112.2,"C",MNE,0)) D L1
15 W ! Q
16L1 S X=$G(^FH(112.2,FN,0)) W !,$E($P(X,"^",1),1,30)
17 S X=$G(^FH(112.2,FN,1))
18 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)
19 Q
20HD1 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,"DRI VALUES",?104,DTP,?125,"Page ",PG Q
21HD2 W !?32,"Protein",?42,"Vitamin A",?54,"Vitamin E",?66,"Vitamin C",?77,"Thiamin",?87,"Riboflavin",?99,"Niacin",?108,"Vitamin B6",?121,"Folate"
22 W !,"Name",?35,"Gm.",?46,"RE",?58,"Mg",?70,"Mg",?80,"Mg",?91,"Mg",?101,"Mg",?112,"Mg",?123,"Mcg"
23 D LN Q
24HD3 W !?32,"Vitamin B12",?46,"Calcium",?57,"Phosphorus",?70,"Magnesium",?84,"Iron",?93,"Zinc",?101,"Pantothenic",?117,"Copper"
25 W !,"Name",?36,"Mcg",?49,"Mg",?61,"Mg",?74,"Mg",?85,"Mg",?94,"Mg",?104,"Acid Mg",?118,"Mg"
26 D LN Q
27HD4 W !?32,"Manganese",?45,"Sodium",?56,"Potassium",?69,"Biotin",?80,"Selenium",?92,"Choline",?103,"Vitamin D",?116,"Fluoride"
28 W !,"Name",?36,"Mg",?47,"Mg",?60,"Mg",?71,"Mcg",?83,"Mcg",?95,"Mg",?107,"Mcg",?119,"Mg"
29 D LN Q
30ITMS ;;Piece,?Tab,Size,Dec
31 ;;1,32,6,1;2,43,6,0;3,55,5,0;4,66,5,0;5,77,5,1;6,86,7,1;7,99,4,0;8,110,5,1;9,121,5,0;
32 ;;10,34,5,1;11,46,6,0;12,57,7,0;13,70,6,0;14,84,3,0;15,93,3,0;16,102,7,1;17,117,4,2;
33 ;;18,32,7,2;19,45,5,0;20,56,7,0;21,69,4,0;22,79,6,0;23,93,4,0;24,105,4,0;25,116,6,2;
34LN W !,"-----------------------------------------------------------------------------------------------------------------------------------",! Q
35KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.