source: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVLO.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1TIUSRVLO ; SLC/JER - Server fns - lists for CPRS ;9/12/06 14:17
2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,15,19,63,108,122,181,194,211**;Jun 20, 1997;Build 26
3NOTES(TIUY,DFN,EARLY,LATE,PERSON,SEQUENCE) ; Get notes
4 N TIUPREF,TIUOCC S TIUPREF=$$PERSPRF^TIULE(DUZ)
5 S TIUOCC=$P(TIUPREF,U,10),PERSON=$S(+$G(PERSON):+$G(PERSON),1:+$G(DUZ))
6 S SEQUENCE=$S($G(SEQUENCE)]"":$G(SEQUENCE),1:"D")
7 D CONTEXT(.TIUY,3,1,DFN,$G(EARLY),$G(LATE),PERSON,TIUOCC,SEQUENCE)
8 Q
9SUMMARY(TIUY,DFN,EARLY,LATE) ; Get Summaries
10 N TIUPREF,TIUOCC S TIUPREF=$$PERSPRF^TIULE(DUZ)
11 S TIUOCC=$P(TIUPREF,U,10),PERSON=$S(+$G(PERSON):+$G(PERSON),1:+$G(DUZ))
12 S SEQUENCE=$S($G(SEQUENCE)]"":$G(SEQUENCE),1:"D")
13 D CONTEXT(.TIUY,244,1,DFN,$G(EARLY),$G(LATE),PERSON,TIUOCC,SEQUENCE)
14 Q
15CONTEXT(TIUY,CLASS,CONTEXT,DFN,EARLY,LATE,PERSON,OCCLIM,SEQUENCE,SHOWADD,INCUND) ; main
16 ; --- Call with: TIUY - RETURN ARRAY pass by reference
17 ; CLASS - Pointer to TIU DOCUMENT DEFINITION #8925.1
18 ; CONTEXT - 1=All Signed (by PT),
19 ; - 2="Unsigned (by PT&(AUTHOR!TANSCRIBER))
20 ; - 3="Uncosigned (by PT&EXPECTED COSIGNER
21 ; - 4="Signed notes (by PT&selected author)
22 ; - 5="Signed notes (by PT&date range)
23 ; DFN - Pointer to Patient (#2)
24 ; [EARLY] - FM date/time to begin search
25 ; [LATE] - FM date/time to end search
26 ; [PERSON] - Pointer to file 200 (DUZ if not passed)
27 ; [OCCLIM] - Occurrence Limit (optional)
28 ; [SEQUENCE]- "A"=ascending (Regular date/time)
29 ; - "D"=descending (Reverse date/time) (dflt)
30 ; [INCUND] - Boolean: include undictated & untranscribed
31 S TIUY=$NA(^TMP("TIUR",$J))
32 K @TIUY
33 I $G(CONTEXT)'>0 Q
34 I $G(CLASS)'>0 Q
35 I $G(CONTEXT)=1 D STRT1^AWCMCPR1 ; TIU*1.0*181
36 S:+$G(EARLY)'>0!(+$G(CONTEXT)=1) EARLY=0
37 S:+$G(LATE)'>0!(+$G(CONTEXT)=1) LATE=5000000
38 I EARLY>LATE D SWAP(.EARLY,.LATE)
39 I $L(LATE,".")=1 D EXPRANGE(.EARLY,.LATE)
40 S:+$G(PERSON)'>0 PERSON=DUZ
41 S:$G(SEQUENCE)']"" SEQUENCE="D"
42 S:+$G(OCCLIM)'>0 OCCLIM=9999999
43 S DFN=+$G(DFN)
44 S EARLY=9999999-EARLY,LATE=9999999-LATE ; CHANGE TO REVERSE DATES
45 ;
46 I CONTEXT=1!(CONTEXT=5) D G CTXQ
47 . D ACLPT(.TIUY,CLASS,DFN,LATE,EARLY,OCCLIM,SEQUENCE)
48 ;
49 I CONTEXT=2 D G CTXQ
50 . I DFN>0 D Q
51 . . D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,$G(INCUND))
52 . F S DFN=$O(^TIU(8925,"ACLAU",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,$G(INCUND))
53 ;
54 I CONTEXT=3 D G CTXQ
55 . I DFN>0 D Q
56 . . D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
57 . F S DFN=$O(^TIU(8925,"ACLEC",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
58 ;
59 I CONTEXT=4 D G CTXQ
60 . I DFN>0 D Q
61 . . ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 REMOVED EXECUTION OF ACLSB & ADDED APTCL
62 . . ;D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
63 . . D APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
64 . F S DFN=$O(^TIU(8925,"APTCL",DFN)) Q:DFN'>0 D APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
65 ;
66CTXQ K @TIUY@("INDX")
67 I $D(AWCSTRT) D END^AWCMCPR1 ; TIU*1.0*181
68 Q
69 ;
70SWAP(TIUX,TIUY) ; Swap variables
71 N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP
72 Q
73 ;
74EXPRANGE(TIUX,TIUY) ; Expand range when same for early & late
75 I TIUX=DT S TIUY=$$NOW^XLFDT I 1
76 E S TIUY=TIUY_"."_2359
77 Q
78 ;
79ACLPT(TIUY,CLASS,DFN,TIME1,TIME2,OCCLIM,SEQUENCE) ; Signed, by patient
80 N DATTIM,DA,ROOT,TIUI,TIUJ
81 S ROOT=$NA(^TIU(8925,"ACLPT",CLASS,DFN)),TIUJ=0
82 S DATTIM=TIME1-.0000001
83 F S DATTIM=$O(@ROOT@(DATTIM)) Q:$S(+DATTIM'>0:1,+DATTIM>TIME2:1,+$G(TIUJ)'<OCCLIM:1,1:0) D
84 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
85 . . ;Added first condition to following line for interdisciplinary notes - need addenda
86 . . I +$G(SHOWADD)=0,(+$G(^TIU(8925,+DA,0))=81) Q
87 . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
88 . . Q:+$D(@TIUY@("INDX",DA))
89 . . ; Selectively filter DELETED or RETRACTED records
90 . . I +$P($G(^TIU(8925,DA,0)),U,5)>13,'+$$CANDO^TIULP(DA,"VIEW",DUZ) Q
91 . . S TIUI=$S(SEQUENCE="D":+$G(TIUI)+1,1:+$G(TIUI)-1)
92 . . S @TIUY@(TIUI)=DA_U_$$RESOLVE(DA)
93 . . S TIUJ=+$G(TIUJ)+1
94 . . S @TIUY@("INDX",DA,TIUI)=""
95 . . Q:+$G(SHOWADD)=0
96 . . I +$$HASDAD^TIUSRVLI(DA) D SETDAD^TIUSRVLI(.TIUY,DA,.TIUI)
97 . . I +$$HASKIDS^TIUSRVLI(DA) D SETKIDS^TIUSRVLI(.TIUY,DA,.TIUI)
98 Q
99 ;
100ACLAU(TIUY,CLASS,AUTHOR,DFN,TIME1,TIME2,SEQUENCE,INCUND) ; Unsigned
101 N DATTIM,DA,ROOT,TIUI
102 S ROOT=$NA(^TIU(8925,"ACLAU",CLASS,AUTHOR,DFN))
103 S DATTIM=TIME1-.0000001
104 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
105 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
106 . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
107 . . I +$P($G(^TIU(8925,DA,0)),U,5)>6 K @ROOT@(DATTIM,DA) Q
108 . . S TIUI=$S(SEQUENCE="D":+$G(TIUI)+1,1:+$G(TIUI)-1)
109 . . Q:+$D(@TIUY@("INDX",DA))
110 . . ; Selectively filter DELETED or RETRACTED records
111 . . I +$P($G(^TIU(8925,DA,0)),U,5)>13,'+$$CANDO^TIULP(DA,"VIEW",DUZ) Q
112 . . S @TIUY@(TIUI)=DA_U_$$RESOLVE(DA)
113 . . S @TIUY@("INDX",DA,TIUI)=""
114 . . Q:+$G(SHOWADD)=0
115 . . I +$$HASDAD^TIUSRVLI(DA) D SETDAD^TIUSRVLI(.TIUY,DA,.TIUI)
116 . . I +$$HASKIDS^TIUSRVLI(DA) D SETKIDS^TIUSRVLI(.TIUY,DA,.TIUI)
117 I +$G(INCUND) D GETUND^TIUSRVLI(.TIUY,CLASS,DFN,TIME1,TIME2,.TIUI,SEQUENCE)
118 Q
119 ;
120ACLEC(TIUY,CLASS,EXCOSIGN,DFN,TIME1,TIME2,SEQUENCE) ; Uncosigned
121 N DATTIM,DA,ROOT,TIUI
122 S ROOT=$NA(^TIU(8925,"ACLEC",CLASS,EXCOSIGN,DFN))
123 S DATTIM=TIME1-.0000001
124 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
125 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
126 . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
127 . . S TIUI=$S(SEQUENCE="D":+$G(TIUI)+1,1:+$G(TIUI)-1)
128 . . Q:+$D(@TIUY@("INDX",DA))
129 . . ; Selectively filter DELETED or RETRACTED records
130 . . I +$P($G(^TIU(8925,DA,0)),U,5)>13,'+$$CANDO^TIULP(DA,"VIEW",DUZ) Q
131 . . S @TIUY@(TIUI)=DA_U_$$RESOLVE(DA)
132 . . S @TIUY@("INDX",DA,TIUI)=""
133 . . Q:+$G(SHOWADD)=0
134 . . I +$$HASDAD^TIUSRVLI(DA) D SETDAD^TIUSRVLI(.TIUY,DA,.TIUI)
135 . . I +$$HASKIDS^TIUSRVLI(DA) D SETKIDS^TIUSRVLI(.TIUY,DA,.TIUI)
136 Q
137 ;
138ACLSB(TIUY,CLASS,SIGNEDBY,DFN,TIME1,TIME2,SEQUENCE) ; Signed, by author
139 N DATTIM,DA,ROOT,TIUI
140 S ROOT=$NA(^TIU(8925,"ACLSB",CLASS,SIGNEDBY,DFN))
141 S DATTIM=TIME1-.0000001
142 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
143 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
144 . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
145 . . S TIUI=$S(SEQUENCE="D":+$G(TIUI)+1,1:+$G(TIUI)-1)
146 . . Q:+$D(@TIUY@("INDX",DA))
147 . . ; Selectively filter DELETED or RETRACTED records
148 . . I +$P($G(^TIU(8925,DA,0)),U,5)>13,'+$$CANDO^TIULP(DA,"VIEW",DUZ) Q
149 . . S @TIUY@(TIUI)=DA_U_$$RESOLVE(DA)
150 . . S @TIUY@("INDX",DA,TIUI)=""
151 . . Q:+$G(SHOWADD)=0
152 . . I +$$HASDAD^TIUSRVLI(DA) D SETDAD^TIUSRVLI(.TIUY,DA,.TIUI)
153 . . I +$$HASKIDS^TIUSRVLI(DA) D SETKIDS^TIUSRVLI(.TIUY,DA,.TIUI)
154 Q
155 ;
156RESOLVE(DA) ; Resolve to external data
157 N DOC,LOC,PT,AUT,EDT,TIUPT,TIULST4,TIUREC,TIUR0,TIUR12,TIUR13,TIUR14
158 N TIUR17,STATUS,EDTCNT,LOCTYP,TIUADT,TIUDDT,PREFIX,IDPARENT,IDSORT
159 S PREFIX=""
160 S TIUR0=$G(^TIU(8925,+DA,0)),TIUR12=$G(^TIU(8925,+DA,12))
161 S TIUR13=$G(^TIU(8925,+DA,13)),TIUR14=$G(^(14)),TIUR17=$G(^(17))
162 S IDPARENT=+$G(^TIU(8925,+DA,21))
163 S TIUPT=$G(^DPT(+$P(TIUR0,U,2),0))
164 S DOC=$$PNAME^TIULC1(+TIUR0)
165 I +$G(^TIU(8925.1,+DA,15)) D
166 . N TIUD15 S TIUD15=$G(^TIU(8925.1,+DA,15))
167 . S DOC=DOC_";"_$P($G(^TIU(8926.1,+TIUD15,0)),U)
168 I DOC="Addendum" S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(TIUR0,U,6),0)))
169 ; If IDNotes (TIU*1.0*100) installed, use $$PREFIX^TIULA2 to evaluate
170 ; which prefix to use:
171 ; - keep prefix display in earlier CPRS versions and LM
172 ; - omit in newer TreeView versions
173 I $L($T(PREFIX^TIULA2)) D I 1
174 . S PREFIX=$$PREFIX^TIULA2(DA,1) ; 1=include ID Child indicator
175 . I PREFIX["<" S IDSORT=$$IDSORT(DA)
176 . I +$G(SHOWADD)=0 S DOC=PREFIX_DOC
177 ; otherwise, only show addendum indicator (+)
178 ; - keep prefix display in earlier CPRS versions and LM
179 ; - omit in newer TreeView versions
180 E D
181 . I +$$HASADDEN^TIULC1(DA) S PREFIX="+ "
182 . I +$G(SHOWADD)=0,(+$$HASADDEN^TIULC1(DA)) S DOC=PREFIX_DOC
183 I +$$URGENCY^TIURM(+DA)=1 S DOC=$S(DOC["+":"*",1:"* ")_DOC
184 S STATUS=$$LOWER^TIULS($P($G(^TIU(8925.6,+$P(TIUR0,U,5),0)),U))
185 S LOC=$G(^SC(+$P(TIUR12,U,5),0)),LOCTYP=$P(LOC,U,3),LOC=$P(LOC,U)
186 S TIUADT=$S(LOCTYP="W":"Adm: ",1:"Visit: ")_$$DATE^TIULS($P(TIUR0,U,7),"MM/DD/YY")
187 S TIUDDT=$S(+$P(TIUR0,U,8):"Dis: ",1:"")_$$DATE^TIULS($P(TIUR0,U,8),"MM/DD/YY")
188 I +$G(SHOWADD)>0 S TIUADT=TIUADT_";"_$P(TIUR0,U,7),TIUDDT=TIUDDT_";"_$P(TIUR0,U,8)
189 S PT=$$NAME^TIULS($P(TIUPT,U),"LAST, FIRST MI")
190 S TIULST4=$E($P(TIUPT,U,9),6,9)
191 S TIULST4="("_$E(PT)_TIULST4_")"
192 S AUT=+$P(TIUR12,U,2)
193 S AUT=AUT_";"_$$SIGNAME^TIULS(+$P(TIUR12,U,2))_";"_$$GET1^DIQ(200,AUT,.01)
194 S EDT=+TIUR13,EDTCNT=+$G(EDTCNT)+1
195 S TIUREC=DOC_U_EDT_U_PT_" "_TIULST4_U_AUT_U_LOC_U_STATUS_U_TIUADT_U_TIUDDT_U_$P(TIUR14,U,5)_U_$$IMGCNT(DA)_U
196 S TIUREC=TIUREC_$S($L(TIUR17):$E(TIUR17,1,(255-$L(TIUREC)))_U,1:U)
197 S TIUREC=TIUREC_$P(PREFIX," ")_U
198 S TIUREC=TIUREC_$S(+TIUR0=81:+$P(TIUR0,U,6),+IDPARENT:IDPARENT,+$G(CONTEXT):CONTEXT,1:1)_U_$G(IDSORT)
199 Q $G(TIUREC)
200IMGCNT(TIUDA) ; Get the number of images associated with a document
201 N IMGDA,TIUI S (IMGDA,TIUI)=0
202 F S IMGDA=$O(^TIU(8925.91,"ADI",TIUDA,IMGDA)) Q:+IMGDA'>0 D
203 . S TIUI=TIUI+1
204 Q TIUI
205IDSORT(TIUDA) ; Get ID Sort indicator when appropriate
206 N TIUDPRM
207 D DOCPRM^TIULC1(+$G(^TIU(8925,+TIUDA,0)),.TIUDPRM)
208 Q +$P(TIUDPRM(0),U,18)
Note: See TracBrowser for help on using the repository browser.