source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULC1.m@ 1736

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

initial load of WorldVistAEHR

File size: 8.1 KB
Line 
1TIULC1 ; SLC/JER - More computational functions ;11/01/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**3,4,40,49,100,131,113,112**;Jun 20, 1997
3 ; External References
4 ; DBIA 2324 $$ISA^USRLM
5 ; Any patch which makes ANY changes to this rtn must include a
6 ;note in the patch desc reminding sites to update the Imaging
7 ;Gateway. See IA # 3622.
8 ; IN ADDITION, if changes are made to components used by Imaging,
9 ;namely PNAME, backward compatibility may not be enough. If
10 ;changes call additional rtns, TIU should consult with Imaging
11 ;on need to add additional rtns to list of TIU rtns copied for
12 ;Imaging Gateway.
13 ; ****
14 ;
15ENCRYPT(X,X1,X2) ; Encrypt Text Strings
16 D EN^XUSHSHP
17 Q X
18DECRYPT(X,X1,X2) ; Decrypt Text Strings
19 D DE^XUSHSHP
20 Q X
21WHOSIGNS(DA) ; Evaluate who should be the expected signer
22 N Y,TIU12
23 S TIU12=$G(^TIU(8925,+DA,12))
24 I $P(TIU12,U,2)'=$P(TIU12,U,9) S Y=$P(TIU12,U,2)
25 E S Y=$P(TIU12,U,9)
26 Q Y
27WHOCOSIG(DA) ; Evaluate who should be the expected cosigner
28 N Y,TIU12
29 S TIU12=$G(^TIU(8925,+DA,12))
30 I $P(TIU12,U,2)=$P(TIU12,U,9) D
31 . I $P(TIU12,U,8)]"" S Y="@"
32 . E S Y=""
33 E S Y=$P(TIU12,U,9)
34 Q Y
35 ;
36HASADDEN(DA,IDKIDFLG) ; Evaluate whether a given record has addenda
37 ; **100**:
38 ; If +IDKIDFLG, check interdisciplinary kids of DA, as well as DA.
39 N TIUI,TIUY,TIUJ,TIUK
40 S (TIUI,TIUJ,TIUY)=0
41 F S TIUI=$O(^TIU(8925,"DAD",+DA,TIUI)) Q:+TIUI'>0 D Q:TIUY
42 . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUI,0)),0)),U)["ADDENDUM" S TIUY=1
43 I TIUY!'$G(IDKIDFLG) G HASX
44 ;**100** Check ID kids for addenda:
45 F S TIUJ=$O(^TIU(8925,"GDAD",+DA,TIUJ)) Q:+TIUJ'>0 D Q:TIUY
46 . S TIUK=0
47 . F S TIUK=$O(^TIU(8925,"DAD",TIUJ,TIUK)) Q:+TIUK'>0 D Q:TIUY
48 . . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUK,0)),0)),U)["ADDENDUM" S TIUY=1
49HASX Q TIUY
50 ;
51ISADDNDM(DA) ; Evaluate whether a given record IS an addendum
52 N TIUY S TIUY=0
53 I $P($G(^TIU(8925.1,+$G(^TIU(8925,+DA,0)),0)),U)["ADDENDUM",+$P($G(^TIU(8925,+DA,0)),U,6)>0 S TIUY=1
54 Q TIUY
55PNAME(DA) ; Receives pointer to 8925.1, returns display name of
56 ; document class
57 N TIUY,TIUMOM S TIUMOM=0
58 I +$G(DA)'>0 Q "UNKNOWN"
59 S TIUMOM=$O(^TIU(8925.1,"AD",DA,TIUMOM))
60 I $P($G(^TIU(8925.1,+DA,0)),U,4)="CO" S TIUMOM=0
61 I +$P($G(^TIU(8925.1,+DA,0)),U,9)=0 S TIUMOM=0
62 I +TIUMOM>0 D
63 . S TIUY=$P($G(^TIU(8925.1,+TIUMOM,0)),U,3)
64 . I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+TIUMOM,0)),U))
65 I +TIUMOM'>0 D
66 . S TIUY=$P($G(^TIU(8925.1,+DA,0)),U,3)
67 . I TIUY']"" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+DA,0)),U))
68 Q TIUY
69ABBREV(DA) ; Get abbreviaton for a document type or class
70 Q $P($G(^TIU(8925.1,+DA,0)),U,2)
71PERSNAME(USER) ; Receives pointer to 200, returns name field
72 N X S X=$$GET1^DIQ(200,USER,.01)
73 Q $S($L(X):X,1:"UNKNOWN")
74BEEP(USER) ; Get beeper #'s
75 Q $P($G(^VA(200,+USER,.13)),U,7,8)
76DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance
77 N TIUI,TIUDAD
78 S (TIUDPRM(0),TIUDPRM(5))=""
79 I $P($G(^TIU(8925.1,+TIUTYP,0)),U)["ADDENDUM",+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
80 S TIUI=+$O(^TIU(8925.95,"B",+TIUTYP,0))
81 I +TIUI D Q
82 . S TIUDPRM(0)=$G(^TIU(8925.95,+TIUI,0))
83 . I +$O(^TIU(8925.95,+TIUI,5,0)) D
84 . . N TIUJ S TIUJ=0
85 . . F S TIUJ=$O(^TIU(8925.95,+TIUI,5,TIUJ)) Q:+TIUJ'>0 D
86 . . . S $P(TIUDPRM(5),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,5,+TIUJ,0))
87 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
88 I +TIUDAD D DOCPRM(TIUDAD,.TIUDPRM)
89 Q
90POSTFILE(TIUTYP) ; Get Post-filing Code, support inheritance
91 N TIUPOST,TIUDAD
92 S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.5))
93 I TIUPOST]"" G POSTFILX
94 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
95 I +TIUDAD S TIUPOST=$$POSTFILE(TIUDAD)
96POSTFILX Q TIUPOST
97FIXCODE(TIUTYP) ; Get Error Resolution Code, support inheritance
98 N TIUFIX,TIUDAD
99 S TIUFIX=$G(^TIU(8925.1,+TIUTYP,4.8))
100 I TIUFIX]"" G FIXCODX
101 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
102 ; Don't inherit PN code for consults: TIU*1*131
103 I +TIUTYP=$$CLASS^TIUCNSLT,TIUDAD=3 G FIXCODX
104 I +TIUDAD S TIUFIX=$$FIXCODE(TIUDAD)
105FIXCODX Q TIUFIX
106DOCCLASS(TIUTYP) ; Given a document type, find its parent document class
107 Q +$O(^TIU(8925.1,"AD",+TIUTYP,0))
108CLINDOC(TIUTYP,TIUDA) ; Given a document type, find the Clinical Document
109 ; subclass to which it belongs
110 N TIUI,TIUY S (TIUI,TIUY)=0
111 I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
112 S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI))
113 I +TIUI'>0 G CLINDOX
114 I TIUI=38 S TIUY=TIUTYP
115 I TIUI'=38 S TIUY=$$CLINDOC(TIUI)
116CLINDOX Q TIUY
117REQVER(TIUTYP,TIUDA) ; Does a given document type require verification
118 N TIUDPRM,TIUY
119 I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
120 D DOCPRM(TIUTYP,.TIUDPRM)
121 I +$P($G(TIUDPRM(0)),U,3) S TIUY=1
122 Q +$G(TIUY)
123REFDATE(TIU,TIUDICDT) ; Identify Reference date
124 N TIURDT
125 I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))_"^0"
126 I +$G(TIU("LDT"))'>0 D
127 . S TIURDT=$S(+$G(TIUDICDT):+$G(TIUDICDT),1:+$$NOW^TIULC)_"^1"
128 . S TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
129 Q TIURDT
130WHATMPL(USER) ; What List Template should a given user get?
131 N TIUY
132 I +$$ISA^USRLM(USER,"PROVIDER") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
133 I +$$ISA^USRLM(USER,"MEDICAL RECORDS TECHNICIAN") S TIUY="TIU BROWSE FOR MRT" G WHAX
134 I +$$ISA^USRLM(USER,"CHIEF, MIS") S TIUY="TIU BROWSE FOR MGR" G WHAX
135 I +$$ISA^USRLM(USER,"MEDICAL STUDENT") S TIUY="TIU BROWSE FOR CLINICIAN" G WHAX
136 S TIUY="TIU BROWSE FOR READ ONLY"
137WHAX Q TIUY
138SUPPVSIT(TIUTYP) ; Evaluate whether to suppress visit matching
139 N TIUI,TIUY S TIUY=0
140 I +$P($G(^TIU(8925.1,+TIUTYP,3)),U,3) S TIUY=1 G SUPPVSIX
141 I $L($P($G(^TIU(8925.1,+TIUTYP,3)),U,3)),($P($G(^(3)),U,3)=0) S TIUY=0 G SUPPVSIX ; ** SLC/JER - NOIS NYC-1298-11472
142 S TIUI=0 F S TIUI=$O(^TIU(8925.1,"AD",+TIUTYP,TIUI)) Q:+TIUI'>0!(+TIUY>0) D
143 . S TIUY=+$$SUPPVSIT(+TIUI)
144SUPPVSIX Q TIUY
145PTNAME(DFN) ; Resolve Patient Name
146 N TIUY S TIUY=$P($G(^DPT(DFN,0)),U)
147 S:TIUY']"" TIUY="NAME UNKNOWN"
148 Q TIUY
149POSTSIGN(TIUTYP) ; Get Post-Signature Code, support inheritance
150 N TIUPOST,TIUDAD
151 S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.9))
152 I TIUPOST]"" G POSTSIGX
153 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
154 I +TIUDAD S TIUPOST=$$POSTSIGN(TIUDAD)
155POSTSIGX Q TIUPOST
156COMMIT(TIUTYP) ; Get Commitment action, support inheritance
157 N TIUCOMM,TIUDAD
158 S TIUCOMM=$G(^TIU(8925.1,+TIUTYP,4.1))
159 I TIUCOMM]"" G COMMITX
160 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
161 I +TIUDAD S TIUCOMM=$$COMMIT(TIUDAD)
162COMMITX Q TIUCOMM
163RELEASE(TIUTYP) ; Get Release Action, support inheritance
164 N TIUREL,TIUDAD
165 S TIUREL=$G(^TIU(8925.1,+TIUTYP,4.2))
166 I TIUREL]"" G RELEASX
167 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
168 I +TIUDAD S TIUREL=$$RELEASE(TIUDAD)
169RELEASX Q TIUREL
170VERIFY(TIUTYP) ; Get Verification action, support inheritance
171 N TIUVER,TIUDAD
172 S TIUVER=$G(^TIU(8925.1,+TIUTYP,4.3))
173 I TIUVER]"" G VERIFYX
174 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
175 I +TIUDAD S TIUVER=$$VERIFY(TIUDAD)
176VERIFYX Q TIUVER
177DELETE(TIUTYP) ; Get Delete Action, support inheritance
178 N TIUDEL,TIUDAD
179 S TIUDEL=$G(^TIU(8925.1,+TIUTYP,4.4))
180 I TIUDEL]"" G DELETEX
181 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
182 I +TIUDAD S TIUDEL=$$DELETE(TIUDAD)
183DELETEX Q TIUDEL
184REASSIGN(TIUTYP) ; Get Package Reassign Action, support inheritance
185 N TIUREASS,TIUDAD
186 S TIUREASS=$G(^TIU(8925.1,+TIUTYP,4.45))
187 I TIUREASS]"" G REASSIX
188 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
189 I +TIUDAD S TIUREASS=$$REASSIGN(TIUDAD)
190REASSIX Q TIUREASS
191ONBROWSE(TIUTYP) ; Get OnBrowse Event, support inheritance
192 N TIUBRWS,TIUDAD
193 S TIUBRWS=$G(^TIU(8925.1,+TIUTYP,6.5))
194 I TIUBRWS]"" G ONBRWSX
195 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
196 I +TIUDAD S TIUBRWS=$$ONBROWSE(TIUDAD)
197ONBRWSX Q TIUBRWS
198ONRTRCT(TIUTYP) ; Get OnRetract Event, support inheritance
199 N TIURTRCT,TIUDAD
200 S TIURTRCT=$G(^TIU(8925.1,+TIUTYP,6.51))
201 I TIURTRCT]"" G ONRTRX
202 S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
203 I +TIUDAD S TIURTRCT=$$ONRTRCT(TIUDAD)
204ONRTRX Q TIURTRCT
205DIVISION(TIULOC) ; Get Division
206 ; Input -- TIULOC HOSPITAL LOCATION file (#44) IEN
207 ; Output -- TIUIN INSTITUTION file (#4) IEN^
208 ; INSTITUTION file (#4) NAME
209 N TIUDVHL,TIUSTN,TIUIN
210 S TIUDVHL=$P($G(^SC(+TIULOC,0)),U,15)
211 I +TIUDVHL D
212 . S TIUSTN=$$SITE^VASITE(,TIUDVHL)
213 . I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"") D
214 . . S TIUIN=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)
215 I '$G(TIUIN) D
216 . S TIUIN=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
217 Q TIUIN
Note: See TracBrowser for help on using the repository browser.