source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHSL.m@ 975

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1TIUHSL ;;SLC/AJB,AGP - Main List Manager for TIUHS ROutines; 10/25/02
2 ;;1.0;TEXT INTEGRATION UTILITIES;**135**;Jun 20, 1997
3EN ; -- main entry point for TIUHSLSM
4 N CENTER,GMTSHDR,GMTSN,POP,VALMBCK,VALMSG,X
5 D EN^VALM("TIUHSLSM")
6 Q
7 ;
8HDR ; -- header code
9 N CENTER,HEADER,TITLE,VALMHDR,VALMSG
10 S TITLE="TIU Health Summary Object."
11 S CENTER=(IOM-$L(TITLE))/2
12 S HEADER=$$SETSTR^VALM1(TITLE,"",CENTER,$L(TITLE))
13 S VALMHDR(1)=HEADER
14 ;display help option
15 S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
16 D XQORM
17 Q
18 ;
19INIT ; -- init variables and list array
20 N DIS,IEN,LINE,HSNAME,HSOBIEN,HSTYPE,NAME,NUM,TMP
21 K TMP($J)
22 S (LINE,NUM)=0
23 ;
24 ;searches file 8925.1 for hs obj and places into temp array
25 S IEN="" F S IEN=$O(^TIU(8925.1,"AT","O",IEN)) Q:IEN="" I $G(^TIU(8925.1,IEN,9))["GMTSOBJ" D
26 .S NAME=$P($G(^TIU(8925.1,IEN,0)),U)
27 .S HSOBIEN=$P($P($G(^TIU(8925.1,IEN,9)),",",2),")")
28 .S HSTYPE=$P($G(^GMT(142.5,HSOBIEN,0)),U,3)
29 .I $G(HSTYPE)'=""&($D(^GMT(142.5,HSOBIEN,0))>0) S HSTYPE=$$GET1^DIQ(142,HSTYPE,.01)
30 .I $G(HSTYPE)="" S HSTYPE="No Health Summary Type Found"
31 .S TMP($J,NAME)=IEN_U_HSTYPE
32 ;
33 ;sort temp array in alpha order and display output
34 S NAME=""
35 F S NAME=$O(TMP($J,NAME)) Q:NAME="" D
36 .S IEN=$P(TMP($J,NAME),U)
37 .S HSNAME=$P(TMP($J,NAME),U,2)
38 .S LINE=LINE+1
39 .S NUM=NUM+1
40 .;
41 .;set output display
42 .S DIS=$$SETSTR^VALM1(NUM,"",1,5)
43 .S DIS=$$SETSTR^VALM1(NAME,DIS,6,37)
44 .S DIS=$$SETSTR^VALM1(HSNAME,DIS,40,40)
45 .D SET^VALM10(LINE,DIS,IEN)
46 S VALMCNT=LINE
47 K TMP($J)
48 Q
49 ;
50CREATE ;
51 ;call to tiuhsobj
52 D CLEAN^VALM10
53 D FULL^VALM1
54 D CREATE^TIUHSOBJ
55 D INIT
56 S VALMBCK="R"
57 Q
58EDIT ;
59 ;lst man function to allow user to select protocal and line item in one command i.e. det=3
60 ;
61 N HSOBJ,SEL,TRUE,Y
62 S TRUE=0
63 S SEL=$P(XQORNOD(0),"=",2)
64 I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
65 I SEL["," D Q
66 .W $C(7),!,"Only one item number allowed." H 2
67 .S VALMBCK="R"
68 I SEL="" D
69 .W !,"Select Entry: (1-"_VALMLST_") " R SEL:DTIME
70 .I '$T!(SEL=U)!(SEL="") S TRUE=1
71 I TRUE=1 Q
72 I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
73 .W $C(7),!,SEL_" is not a valid item number." H 2
74 .S VALMBCK="R"
75 S Y=$O(@VALMAR@("IDX",SEL,""))
76 D CLEAN^VALM10
77 D EN^TIUHSV(+Y)
78 D CLEAN^VALM10
79 D INIT
80 Q
81 ;
82EDITHSO ;
83 ;lst man function to allow user to select protocal and line item in one command i.e. det=3
84 ;
85 N HSOBJ,IEN,OBJMETD,SEL,TRUE,Y,YESNO
86 S TRUE=0
87 S SEL=$P(XQORNOD(0),"=",2)
88 I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
89 I SEL["," D Q
90 .W $C(7),!,"Only one item number allowed." H 2
91 .S VALMBCK="R"
92 I SEL="" D
93 .W !,"Select Entry: (1-"_VALMLST_") " R SEL:DTIME
94 .I '$T!(SEL=U)!(SEL="") S TRUE=1
95 I TRUE=1 Q
96 I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
97 .W $C(7),!,SEL_" is not a valid item number." H 2
98 .S VALMBCK="R"
99 S Y=$O(@VALMAR@("IDX",SEL,""))
100 S IEN=+Y
101 S OBJMETD=^TIU(8925.1,IEN,9)
102 S HSOBJ=$P($P($G(OBJMETD),",",2),")")
103 S YESNO="Y"
104 I $D(^GMT(142.5,HSOBJ,0))=0 D
105 . W !,"No HS Object found. Create new HS Object now?"
106 . S DIR(0)="YA0"
107 . S DIR("B")="NO"
108 . S DIR("?")="Enter Y or N. For detailed help type ??"
109 . D ^DIR
110 . I $D(DIROUT) S DTOUT=1
111 . I $D(DTOUT)!($D(DUOUT)) S YESNO="N" Q
112 . S YESNO=$E(Y(0))
113 . I YESNO="Y" S HSOBJ=$$CRE^GMTSOBJ()
114 I $G(YESNO)="Y"&(HSOBJ>0) D
115 . S ^TIU(8925.1,IEN,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJ_")"
116 . D EN^TIUHSOLM(HSOBJ,IEN)
117 D CLEAN^VALM10
118 D INIT
119 Q
120FIND ;
121 S DIC=8925.1,DIC("A")="Enter OBJECT NAME: "
122 ;
123 ; DIC(0)="ABEOQ" a=ask user for input, b=use b xref only
124 ; e=echo o=only find 1 if exact match
125 ; q=question erroneous input
126 ;
127 ; DIC("S") ensures IEN is greater or equal to 1 and will only
128 ; lookup objects that contain the health summary object routine
129 ;
130 S DIC(0)="ABEOQ",DIC("S")="I Y'<1,$G(^TIU(8925.1,+Y,9))[""GMTSOBJ"""
131 W ! D ^DIC I Y=-1 K DIC Q
132 D EN^TIUHSV(+Y)
133 K DIC
134 Q
135 ;
136LSEXIT ;
137 ;display help option
138 N VALMSG
139 S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
140 D XQORM
141 Q
142 ;
143XQORM ;
144 S XQORM("#")=$O(^ORD(101,"B","TIUHS EDIT",0))_U_"1:"_VALMCNT
145 S XQORM("A")="Select Action: "
146 Q
147 ;
148HELP ; -- help code
149 N X
150 S X="?" D DISP^XQORM1 W !!
151 Q
152 ;
153EXIT ; -- exit code
154 Q
155 ;
156EXPND ; -- expand code
157 Q
158 ;
Note: See TracBrowser for help on using the repository browser.