source: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVLL.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 
1TIUSRVLL ; SLC/JER - Server functions for LOCAL lists ;7/16/01
2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,100,121,143,194**;Jun 20, 1997
3LIST(TIUY,CLASS,DFN,EARLY,LATE) ; Build List user can select from to browse
4 N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUREC,TIUPRM0,TIUPRM1
5 N TIUPRM3,TIUT,TIUTP,XREF,TIUS,TIUCONT,TIUSTAT,TIUTYPE
6 I '$D(TIUPRM0) D SETPARM^TIULE
7 S EARLY=9999999-+$G(EARLY),TIUCNT=0
8 S (TIUI,LATE)=9999999-$S(+$G(LATE):+$G(LATE),1:3333333)
9 F S TIUI=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI)) Q:+TIUI'>0!(+TIUI>EARLY) D GATHER(.TIUY,DFN,CLASS,TIUI)
10 Q
11GATHER(TIUY,DFN,CLASS,TIUI) ; Find/sort records for the list to browse
12 N TIUDA
13 S TIUDA=0
14 F S TIUDA=$O(^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA)) Q:+TIUDA'>0 D
15 . I ($P(TIUPRM0,U,6)="S"),(+$$CANDO^TIULP(TIUDA,"VIEW")'>0) Q
16 . I +$G(^TIU(8925,+TIUDA,0))'>0 K ^TIU(8925,"APTCL",DFN,CLASS,TIUI,TIUDA) Q
17 . I +$G(^TIU(8925,+TIUDA,0))=81,(+$P($G(^(0)),U,5)>5) Q
18 . S TIUCNT=+$G(TIUCNT)+1
19 . S ^TMP("TIUYLIST",$J,TIUCNT)=TIUDA,TIUY=TIUCNT ; TIU*1.0*143
20 . ; S TIUY(TIUCNT)=TIUDA,TIUY=TIUCNT ; pre-143 code
21 Q
22 ;
23CONTEXT(TIUY,CLASS,CONTEXT,DFN,EARLY,LATE,PERSON,OCCLIM,SEQUENCE,TIUEXPKD) ; main
24 ; --- Call with: TIUY - Return array, pass by reference
25 ; CLASS - Pointer to TIU DOCUMENT DEFINITION #8925.1
26 ; CONTEXT - 1=All Signed (by PT),
27 ; - 2="Unsigned (by PT&(AUTHOR!TANSCRIBER))
28 ; - 3="Uncosigned (by PT&EXPECTED COSIGNER
29 ; - 4="Signed notes (by PT&selected author)
30 ; - 5="Signed notes (by PT&date range)
31 ; DFN - Pointer to Patient (#2)
32 ; [EARLY] - FM date/time to begin search
33 ; [LATE] - FM date/time to end search
34 ; [PERSON] - Pointer to file 200 (DUZ if not passed)
35 ; [OCCLIM] - Occurrence Limit (optional)
36 ; [SEQUENCE] - "A"=ascending (Regular date/time) (dflt)
37 ; - "D"=descending (Reverse date/time)
38 ; [TIUEXPKD] - Return array, pass by ref.
39 ; TIUEXPKD(IFN)="", where we will expand IFN
40 ; so ID kids/adda that meet criteria are
41 ; displayed under it.
42 K TIUY S TIUY=0
43 I $G(CONTEXT)'>0 Q
44 I $G(CLASS)'>0 Q
45 S:+$G(EARLY)'>0 EARLY=0
46 S:+$G(LATE)'>0 LATE=5000000
47 S:+$G(PERSON)'>0 PERSON=DUZ
48 S:$G(SEQUENCE)']"" SEQUENCE="D"
49 S:+$G(OCCLIM)'>0 OCCLIM=9999999
50 S DFN=+$G(DFN)
51 S EARLY=9999999-EARLY,LATE=9999999-LATE ; CHANGE TO REVERSE DATES
52 ; --------------------
53 I CONTEXT=1!(CONTEXT=5) D Q
54 . D ACLPT(.TIUY,CLASS,DFN,LATE,EARLY,OCCLIM,SEQUENCE)
55 ; --------------------
56 I CONTEXT=2 D Q
57 . I DFN>0 D Q
58 . . D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
59 . F DFN=0:0 S DFN=$O(^TIU(8925,"ACLAU",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLAU(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
60 ; --------------------
61 I CONTEXT=3 D Q
62 . I DFN>0 D Q
63 . . D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
64 . F DFN=0:0 S DFN=$O(^TIU(8925,"ACLEC",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLEC(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
65 ; --------------------
66 I CONTEXT=4 D Q
67 . I DFN>0 D Q
68 . . ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 REMOVED EXECUTION OF ACLSB & ADDED APTCL
69 . . ;D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
70 . . D APTCL^TIUSRVLL(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
71 . F S DFN=$O(^TIU(8925,"APTCL",DFN)) Q:DFN'>0 D APTCL^TIUSRVLP(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE)
72 . ;F DFN=0:0 S DFN=$O(^TIU(8925,"ACLSB",CLASS,PERSON,DFN)) Q:DFN'>0 D ACLSB(.TIUY,CLASS,PERSON,DFN,LATE,EARLY,SEQUENCE,.TIUEXPKD)
73 Q
74 ;
75ACLPT(ARRAY,CLASS,DFN,TIME1,TIME2,OCCLIM,SEQUENCE) ; Signed,
76 ;by patient, [& date].
77 N DATTIM,DA,ROOT,TIUORDER
78 K ^TMP("TIUREPLACE",$J)
79 S ROOT=$NA(^TIU(8925,"ACLPT",CLASS,DFN))
80 S DATTIM=TIME1-.0000001
81 ; Since date/time is inverted, set subscripts forward for descending:
82 S TIUORDER=$S(SEQUENCE="D":1,1:-1)
83 F S DATTIM=$O(@ROOT@(DATTIM)) Q:$S(+DATTIM'>0:1,+DATTIM>TIME2:1,+$G(^TMP("TIUREPLACE",$J))'<OCCLIM:1,1:0) D
84 . F DA=0:0 S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
85 . . I +$G(^TIU(8925,+DA,0))'>0 K @ROOT@(DATTIM,DA) Q
86 . . I +^TIU(8925,+DA,0)=81 Q
87 . . ; -- Set records into ^TMP("TIUREPLACE",$J),
88 . . ; replacing kids w parents:
89 . . D REPLACE(DA,DATTIM)
90 ; B 1
91 D SETARRY(.ARRAY,TIUORDER)
92 K ^TMP("TIUREPLACE",$J)
93 Q
94 ;
95SETARRY(ARRAY,TIUORDER) ; Set ARRAY(SUB)=DA, which is passed
96 ;back to CONTEXT. ARRAY holds the right records, in the right order
97 ;for the List Template list.
98 ; TIUORDER=1 or -1: Set ARRAY subscripts forward 1,2 etc., or
99 ;backward -1,-2, etc.
100 ; Requires ^TMP("TIUREPLACE",$J),
101 ;with ID kids or adda replaced by parents.
102 ; B 1
103 N DATTIM,TIUDA,SUB
104 S DATTIM=0
105 S SUB=0
106 F S DATTIM=$O(^TMP("TIUREPLACE",$J,DATTIM)) Q:'DATTIM D
107 . S TIUDA=0
108 . F S TIUDA=$O(^TMP("TIUREPLACE",$J,DATTIM,TIUDA)) Q:'TIUDA D
109 . . S SUB=SUB+TIUORDER
110 . . S ^TMP("TIUYARRAY",$J,SUB)=TIUDA ; TIU*1.0*143
111 . . ; S ARRAY(SUB)=TIUDA ; original code
112 Q
113 ;
114REPLACE(TIUDA,DATTIM,EXPAND,FORGETAD) ; Populate ^TMP("TIUREPLACE",$J) with
115 ;records that meet criteria, replacing ID kids or addenda with
116 ;their parents.
117 ; Requires TIUDA, DATTIM;
118 ; opt flag FORGETAD - if 1, don't add note to the expand list
119 ;merely because of an addendum. Used in search by title.
120 ; Passes back array EXPAND.
121 ; Sort by ref date/time
122 N IDPRNT,ADDMPRNT,ADDMGPNT,PDATTIM,GPDATTIM
123 S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
124 I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
125 I IDPRNT S PDATTIM=+^TIU(8925,IDPRNT,13),PDATTIM=9999999-PDATTIM
126 S ADDMPRNT=+$P(^TIU(8925,TIUDA,0),U,6) ; assume TIUDA is not component
127 I '$D(^TIU(8925,ADDMPRNT,0)) S ADDMPRNT=0
128 I ADDMPRNT S PDATTIM=+^TIU(8925,ADDMPRNT,13),PDATTIM=9999999-PDATTIM
129 ; -- If TIUDA is not an ID kid, not addm, just put it
130 ; in array and quit: --
131 S EXPAND=+$G(EXPAND)
132 I 'IDPRNT,'ADDMPRNT D Q
133 . Q:$D(^TMP("TIUREPLACE",$J,DATTIM,TIUDA))
134 . S ^TMP("TIUREPLACE",$J,DATTIM,TIUDA)=""
135 . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
136 ; -- If TIUDA is an ID kid, put its parent in array:
137 I IDPRNT D Q
138 . I '$D(EXPAND(IDPRNT)) S EXPAND(IDPRNT)="",EXPAND=EXPAND+1
139 . Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT))
140 . S ^TMP("TIUREPLACE",$J,PDATTIM,IDPRNT)=""
141 . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
142 ; -- If TIUDA is an addendum, put its parent/gprnt in array:
143 I ADDMPRNT D Q
144 . I '$G(FORGETAD),'$D(EXPAND(ADDMPRNT)) S EXPAND(ADDMPRNT)="",EXPAND=EXPAND+1
145 . S ADDMGPNT=+$G(^TIU(8925,ADDMPRNT,21))
146 . I '$D(^TIU(8925,ADDMGPNT,0)) S ADDMGPNT=0
147 . I ADDMGPNT D I 1
148 . . S GPDATTIM=+^TIU(8925,ADDMGPNT,13),GPDATTIM=9999999-GPDATTIM
149 . . I '$D(EXPAND(ADDMGPNT)) S EXPAND(ADDMGPNT)="",EXPAND=EXPAND+1
150 . . Q:$D(^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT))
151 . . S ^TMP("TIUREPLACE",$J,GPDATTIM,ADDMGPNT)=""
152 . . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
153 . E D
154 . . Q:$D(^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT))
155 . . S ^TMP("TIUREPLACE",$J,PDATTIM,ADDMPRNT)=""
156 . . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
157 Q
158ACLAU(ARRAY,CLASS,AUTHOR,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Unsigned
159 N DATTIM,DA,ROOT,TIUORDER
160 K ^TMP("TIUREPLACE",$J)
161 S ROOT=$NA(^TIU(8925,"ACLAU",CLASS,AUTHOR,DFN))
162 S DATTIM=TIME1-.0000001
163 S TIUORDER=$S(SEQUENCE="D":1,1:-1)
164 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
165 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
166 . . I +$P($G(^TIU(8925,DA,0)),U,5)>6 K @ROOT@(DATTIM,DA) Q
167 . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA) Q
168 . . ; Don't include ID kids or parents in top level of list;
169 . . ; Do expand kids
170 . . D REPLACE(DA,DATTIM,.TIUEXPKD)
171 D SETARRY(.ARRAY,TIUORDER)
172 K ^TMP("TIUREPLACE",$J)
173 Q
174ACLEC(ARRAY,CLASS,EXCOSIGN,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Uncosigned
175 N DATTIM,DA,ROOT,TIUORDER
176 K ^TMP("TIUREPLACE",$J)
177 S ROOT=$NA(^TIU(8925,"ACLEC",CLASS,EXCOSIGN,DFN))
178 S DATTIM=TIME1-.0000001
179 S TIUORDER=$S(SEQUENCE="D":1,1:-1)
180 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
181 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
182 . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
183 . . D REPLACE(DA,DATTIM,.TIUEXPKD)
184 D SETARRY(.ARRAY,TIUORDER)
185 K ^TMP("TIUREPLACE",$J)
186 Q
187ACLSB(ARRAY,CLASS,SIGNEDBY,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
188 N DATTIM,DA,ROOT,TIUORDER
189 K ^TMP("TIUREPLACE",$J)
190 S ROOT=$NA(^TIU(8925,"ACLSB",CLASS,SIGNEDBY,DFN))
191 S DATTIM=TIME1-.0000001
192 S TIUORDER=$S(SEQUENCE="D":1,1:-1)
193 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
194 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
195 . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
196 . . D REPLACE(DA,DATTIM,.TIUEXPKD)
197 D SETARRY(.ARRAY,TIUORDER)
198 K ^TMP("TIUREPLACE",$J)
199 Q
200 ;VMP OIFO BAY PINES;ELR;TIU*1.0*194 ADDED NEXT TAG
201APTCL(ARRAY,CLASS,TIUAUTH,DFN,TIME1,TIME2,SEQUENCE,TIUEXPKD) ; Signed, by author
202 N DATTIM,DA,ROOT,TIUORDER,TIUS12,TIUS15
203 K ^TMP("TIUREPLACE",$J)
204 S ROOT=$NA(^TIU(8925,"APTCL",DFN,CLASS))
205 S DATTIM=TIME1-.0000001
206 S TIUORDER=$S(SEQUENCE="D":1,1:-1)
207 F S DATTIM=$O(@ROOT@(DATTIM)) Q:DATTIM'>0!(DATTIM>TIME2) D
208 . S DA=0 F S DA=$O(@ROOT@(DATTIM,DA)) Q:DA'>0 D
209 . . I +$G(^TIU(8925,DA,0))'>0 K @ROOT@(DATTIM,DA)
210 . . S TIUS12=$G(^TIU(8925,DA,12))
211 . . Q:+$P(TIUS12,U,2)'=TIUAUTH ;See if this is the authors note
212 . . S TIUS15=$G(^TIU(8925,DA,15))
213 . . Q:+$P(TIUS15,U,2)'>0 ;See if signed
214 . . D REPLACE(DA,DATTIM,.TIUEXPKD)
215 D SETARRY(.ARRAY,TIUORDER)
216 K ^TMP("TIUREPLACE",$J)
217 Q
Note: See TracBrowser for help on using the repository browser.