source: cprs/branches/tmg-cprs/m_files/TMGHUI1.m@ 1729

Last change on this file since 1729 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 5.6 KB
Line 
1TMGHUI1 ;TMG/kst/Custom version of HUI code ;03/25/06
2 ;;1.0;TMG-LIB;**1**;01/12/05
3
4
5HUIPSUPD ;DLD/Pacific HUI/Updates orderable item file with PS Orderable Items ; 1/25/05 7:55am
6 ;;This routine populates the drug orderable items
7
8 ;"HUI MISCELLANEOUS FUNCTIONS (used/customized in TMG library)
9
10 ;"=======================================================================
11 ;" API -- Public Functions.
12 ;"=======================================================================
13 ;"myGO ;" - global list- (global lister)
14
15 ;"=======================================================================
16 ;"PRIVATE API FUNCTIONS
17 ;"=======================================================================
18
19 ;"=======================================================================
20 ;"=======================================================================
21
22EN
23 ;" loop through PS(50.7 and add to OE Ordeable item
24 new PSOIEN
25 do DT^DICRW
26 set PSOIEN=$order(^PS(50.7,0))
27 if +PSOIEN>0 for do quit:'PSOIEN
28 . do ADD(PSOIEN)
29 . set PSOIEN=$order(^PS(50.7,PSOIEN))
30 quit
31
32
33ADD(PSOIEN)
34 ;" Calls PS Orderable Item update routines
35 do EN^PSSPOIDT(PSOIEN)
36 do EN2^PSSHL1(PSOIEN,"MUP")
37 quit
38
39SET
40 ;" - updates view set
41 new DIC,X,Y,IEN,D,TYPE,NM,DGNM,UPDTIME,ATTEMPT
42 do DT^DICRW
43 set DIC="^ORD(101.44,"
44 set DIC(0)="AQ"
45 for D ^DIC quit:+Y quit:X="^"
46 quit:X="^"
47 set IEN=+Y
48 set NM=$P(Y,U,2)
49 set DGNM=$P(NM,"ORWDSET ",2)
50 set UPDTIME=$H
51 set ATTEMPT=""
52 do FVBLD^ORWUL
53 quit
54
55
56myGO;" - global list- (global lister)
57 ;- Jan 2005 - DLD - PACIFIC HUI
58 ; - THis routine allows global out of a partial global
59 ;" //kt note: Obtained from N. Anthracite 11/4/05. She got
60 ;" it from Norman Dodd <norman.dodd@bluecliffinc.com>
61 ;" Reformatted for full commands
62 ;" User interface changes made also.
63 ;" This function dumps one or more globals to selected output device
64
65 write !,"Global Output Utility",!
66 if '$data(%zdebug) new $et do
67 . set $et="zg "_$zl_":ERR^%GO"
68 . use $p:(ctrap=$c(3):exc="zg "_$zl_":EXIT^%GO")
69 new g,gn,m,n,c,gl,in,%ZD,%ZG,%ZH,fmt
70 set c=0
71 for read !,"Enter Global ([enter] if done): ",in,! do quit:in=""
72 . quit:in=""
73 . if $extract(in)="?",$length(in)=1 do help quit
74 . if $extract(in)="^",$length(in)=1 set in="" quit
75 . if $extract(in)'="^" do help quit
76 . if in["(",in'[")" do help quit
77 . set c=c+1,gl(c)=in
78 if '$data(gl) write !,"No globals selected" quit
79 read !,"Header Label: ",%ZH,!
80 read !,"Output Format: GO or ZWR: ",fmt,!
81 if (fmt="")!($extract("ZWR",1,$length(fmt))=$translate(fmt,"zwr","ZWR")) set fmt=1
82 else set fmt=0
83 for do quit:$length(%ZD)
84 . read !,"Output device: <terminal>: ",%ZD,!
85 . if '$length(%ZD) set %ZD=$p quit
86 . if %ZD="^" quit
87 . if %ZD="?" do quit
88 . . write !!,"Select the device you want for output"
89 . . write !,"If you wish to exit enter a carat (^)",!
90 . . set %ZD=""
91 . if $zparse(%ZD)="" write " no such device" set %ZD="" quit
92 . open %ZD:(newversion:block=2048:record=2044:exception="g noopen"):0
93 . if '$t write !,%ZD," is not available" set %ZD="" quit
94 . quit
95noopen . write !,$p($ZS,",",2,999),! close %ZD set %ZD=""
96 quit:%ZD="^"
97 write !!
98 if '$length(%ZH) set %ZH="%GO Global Output Utility"
99 use %ZD
100 write %ZH,!,"GT.M ",$zd($h,"DD-MON-YEAR 24:60:SS")
101 write:fmt " ZWR"
102 write !
103 set c=0,(m,n)=0
104 for set c=$order(gl(c)) quit:'+c set gn=gl(c),g=gn do
105 . use $p
106 . write:$x>70 !
107 . write gn,?$x\10+1*10
108 . use %ZD
109 . if $p=%ZD write !
110 . quit:g=""
111 . set m=m+1
112 . if $data(@g)'[0 write g do set n=n+1
113 . . if fmt write "=" do fw(@g)
114 . . else write !,@g,!
115 . for set g=$q(@g) quit:g="" do
116 . . if fmt zwr @g
117 . . else write g,!,@g,!
118 . . set n=n+1
119 use %ZD write !!
120 use $p
121 write !!,"Total of ",n," node",$s(n=1:"",1:"s")
122 write " in ",m," global",$s(m=1:".",1:"s."),!!
123 close:%ZD'=$p %ZD
124 use $p:(ctrap="":exc="")
125 quit
126
127fw(s)
128 ;" variables used in this function are: fwlen, s, cc, fastate, isctl, i, thistime
129 ;" initialize this procedure
130 set fwlen=$length(s)
131 if fwlen=0 write ! quit
132 if s=+s write s,! quit
133 set cc=$extract(s)
134 if cc?1C write "$C(",$a(cc) set fastate=2
135 else write """",cc w:cc="""" cc set fastate=1
136 ;" start the loop to deal with the whole string.
137 for i=2:1:fwlen set cc=$extract(s,i,i),isctl=cc?1C d
138 . set thistime=1
139 . if fastate=1 do
140 . . if (isctl) write """_$C(",$a(cc) set fastate=2,thistime=0
141 . . else write cc w:cc="""" cc
142 . if (fastate=2)&thistime do
143 . . if (isctl)!(cc="""") write ",",$a(cc)
144 . . else write ")_""",cc set fastate=1
145 if fastate=1 write """",!
146 else write ")",!
147 quit
148
149ERR use $p write !,$p($zs,",",2,99),!
150 ; Warning - Fall-though
151 set $ec=""
152EXIT if $data(%ZD),%ZD'=$p close %ZD
153 use $p:(ctrap="":exc="")
154 quit
155
156help;
157 write !,"Enter a global reference to start at with ^"
158 write !,"i.e ^DPT or ^VA(200)"
159 quit
Note: See TracBrowser for help on using the repository browser.