source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU5.m

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1PXRMEXU5 ; SLC/PKR - Reminder exchange KIDS utilities, #5. ;03/31/2004
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;==================================================
4BMTABLE(MTABLE,IENROOT,DIQOUT,FDA) ;Build the table for merging
5 ;GETS^DIQOUT indexes into the FDA. The merge table has the form:
6 ;MTABLE(IENSD)=IENSF. IENSD is the DIQOUT iens and IENSF is the
7 ;FDA iens. MTABLE provides a direct replacement of IENSD to IENSF.
8 N FNUM,IEN,IENS,IENSD,IENRF,IENSF,IND,LAST,LEN,NULLF,TOPFN
9 S FILENUM=$O(FDA(""),-1),IENS=$O(FDA(FILENUM,""),-1)
10 S LAST=+$P(IENS,",",1)
11 ;Initialize the merge table by looking for identical entries in
12 ;DIQOUT and FDA. First create the top level entry.
13 S NULLF=0
14 S FILENUM=$O(DIQOUT(""))
15 S IENSD=$O(DIQOUT(FILENUM,""))
16 S LEN=$L(IENSD,",")-1
17 S IENS=$P(IENSD,",",LEN)_","
18 ;DBIA #2631
19 F IND=1:1:LEN-1 S FILENUM=$G(^DD(FILENUM,0,"UP"))
20 S TOPFN=FILENUM
21 S IENSF=$O(FDA(TOPFN,""))
22 S MTABLE(TOPFN,IENS)=IENSF
23 ;Build all the entries below the top level.
24 S FILENUM=TOPFN
25 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
26 . S IENSD=""
27 . F S IENSD=$O(DIQOUT(FILENUM,IENSD)) Q:IENSD="" D
28 .. S MTABLE(FILENUM,IENSD)=""
29 .. I '$D(FDA(FILENUM)) S NULLF=1 Q
30 ..;Look for matches based on identical .01s
31 .. S IENSF=""
32 .. F S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF="" D
33 ... I $G(DIQOUT(FILENUM,IENSD,.01))=$G(FDA(FILENUM,IENSF,.01)) S MTABLE(FILENUM,IENSD)=IENSF
34 ... E S NULLF=1
35 ;Entries that are equal to null at this point don't have a
36 ;corresponding FDA entry.
37 I 'NULLF Q
38 S FILENUM=""
39 F S FILENUM=$O(FDA(FILENUM)) Q:FILENUM="" D
40 . S IENSF=""
41 . F S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF="" D
42 .. S IND=+IENSF
43 .. I IENROOT(IND)'="" S IENRF(FILENUM,IENROOT(IND))=IND
44 ;IENRF keeps track of the IENROOT entries by file number.
45 S FILENUM=""
46 F S FILENUM=$O(MTABLE(FILENUM)) Q:FILENUM="" D
47 . S IENSD=""
48 . F S IENSD=$O(MTABLE(FILENUM,IENSD)) Q:IENSD="" D
49 .. I MTABLE(FILENUM,IENSD)'="" Q
50 .. D MMTAB(.MTABLE,.IENROOT,.LAST,FILENUM,IENSD,.IENRF)
51 Q
52 ;
53 ;==================================================
54LOIEN(FILENUM) ;Find the first open ien in a global.
55 N GBL,I1,I2,OIEN
56 S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_"I1)"
57 S OIEN=-1
58 S (I1,I2)=0
59 F S I1=+$O(@GBL) Q:(OIEN>0)!(I1=0) D
60 . I ((I1-I2)>1)!(I1="") S OIEN=I2+1 Q
61 . S I2=I1
62 I OIEN=-1 S OIEN=I2+1
63 Q OIEN
64 ;
65 ;==================================================
66MERGE(FILENUM,IEN,FIELD,FDA,IENROOT) ;Merge existing site entries into
67 ;the FDA that is loaded from Exchange.
68 ;FILENUM - the file number
69 ;IEN - internal entry number
70 ;FIELD - semicolon separated list of fields.
71 ;These the are arguments for GETS^DIQ, see that documentation for
72 ;more information.
73 ;FDA and IENROOT are the FDA and IENROOT for UPDATE^DIE. These
74 ;are already setup with the contents of the packed reminder before
75 ;this routine is called.
76 ;The default is to merge any nodes of the FDA with the nodes
77 ;already existing at the site. If MODE="R" then the existing nodes
78 ;will be replaced with the nodes already in the FDA.
79 N DIQOUT,IENSD,IENSF,IND,IND1,IND2,IND2S,IND3,LE,MSG,MTABLE
80 N SITE,TIENROOT
81 S IENS=IEN_","
82 D GETS^DIQ(FILENUM,IENS,FIELD,"","DIQOUT","MSG")
83 I $D(MSG) D Q
84 . N ETEXT,FILENAME
85 . S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
86 . S ETEXT="GETS^DIQ failed for "_FILENAME_" entry "_IEN_", it returned the following error message:"
87 . W !,ETEXT
88 . D AWRITE^PXRMUTIL("MSG")
89 . H 2
90 . K MSG
91 ;If there is nothing to merge quit.
92 I '$D(DIQOUT) Q
93 ;Clean up DIQOUT remove null entries and change pointers to the resolved
94 ;form.
95 D CLDIQOUT^PXRMEXPU(.DIQOUT)
96 ;If there is nothing left to merge quit.
97 I '$D(DIQOUT) Q
98 ;Build the merge table.
99 D BMTABLE(.MTABLE,.IENROOT,.DIQOUT,.FDA)
100 ;Do the merge
101 S FILENUM=""
102 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
103 . S IENSD=""
104 . F S IENSD=$O(DIQOUT(FILENUM,IENSD)) Q:IENSD="" D
105 .. S IENSF=MTABLE(FILENUM,IENSD)
106 .. S FIELD=""
107 .. F S FIELD=$O(DIQOUT(FILENUM,IENSD,FIELD)) Q:FIELD="" D
108 ... S FDA(FILENUM,IENSF,FIELD)=DIQOUT(FILENUM,IENSD,FIELD)
109 Q
110 ;
111 ;==================================================
112MMTAB(MTABLE,IENROOT,LAST,FILENUM,IENS,IENRF) ;Generate a merge table entry.
113 N IENRL,FNUP,UP,UPIENS
114 S UP=$P(IENS,",",2,99)
115 ;DBIA #2631
116 S FNUP=$G(^DD(FILENUM,0,"UP"))
117 S UPIENS=MTABLE(FNUP,UP)
118 S LAST=LAST+1
119 S MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
120 S IENRL=$O(IENRF(FILENUM,""),-1)+1
121 S IENROOT(LAST)=IENRL,IENRF(FILENUM,IENRL)=LAST
122 Q
123 ;
124 ;==================================================
125NONULL(PXRMRIEN) ;Set any lines with a length of 0 equal to a space
126 ;so KIDS will not delete them.
127 N IND
128 S IND=0
129 F S IND=+$O(^PXD(811.8,PXRMRIEN,100,IND)) Q:IND=0 D
130 . I $L(^PXD(811.8,PXRMRIEN,100,IND,0))=0 S ^PXD(811.8,PXRMRIEN,100,IND,0)=" "
131 Q
132 ;
133 ;==================================================
134POSTKIDS(PXRMRIEN) ;Change all ACK characters in node 100 of Exchange
135 ;File entry PXRMRIEN back to "^".
136 N ACK,UPA
137 S ACK=$C(6)
138 S UPA="^"
139 D REPCHAR(PXRMRIEN,ACK,UPA)
140 Q
141 ;
142 ;==================================================
143PREKIDS(PXRMRIEN) ;Change all "^" characters in node 100 of Exchange
144 ;File entry PXRMRIEN so that KIDS does not truncate lines when it
145 ;installs the file.
146 N ACK,UPA
147 S ACK=$C(6)
148 S UPA="^"
149 D REPCHAR(PXRMRIEN,UPA,ACK)
150 D NONULL(PXRMRIEN)
151 Q
152 ;
153 ;==================================================
154REPCHAR(PXRMRIEN,CHAR1,CHAR2) ;Replace CHAR1 with CHAR2 for all lines in node
155 ;100 of entry PXRMRIEN of the Exchange File.
156 N IND,LINE
157 S IND=0
158 F S IND=+$O(^PXD(811.8,PXRMRIEN,100,IND)) Q:IND=0 D
159 . S LINE=$TR(^PXD(811.8,PXRMRIEN,100,IND,0),CHAR1,CHAR2)
160 . S ^PXD(811.8,PXRMRIEN,100,IND,0)=LINE
161 Q
162 ;
163 ;==================================================
164SCLASS(FILENUM,CLASS,FDA) ;Set the class field in those files that use it.
165 I '$D(PXRMCLAS) Q
166 N ERRMSG,IND,FNAME
167 S FNAME=$$GET1^DID(FILENUM,100,"","LABEL","","ERRMSG")
168 I FNAME="CLASS" D
169 . S IND=$O(FDA(FILENUM,""))
170 . I $D(FDA(FILENUM,IND,100)) S FDA(FILENUM,IND,100)=PXRMCLAS
171 Q
172 ;
Note: See TracBrowser for help on using the repository browser.