source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m@ 1681

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007
2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
3 ;==================================================
4BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
5 N FILENUM,IENS,IENT,IND,UP
6 S FILENUM=$O(DIQOUT(""))
7 I FILENUM="" Q
8 ;DBIA #2631
9 S UP=$G(^DD(FILENUM,0,"UP"))
10 ;Top level file in DIQOUT should not have an up node.
11 I UP="" D
12 . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS
13 . S TTABLE(FILENUM,IENS)="+"_IENS
14 E D Q
15 . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level"
16 ;
17 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
18 . S UP=$G(^DD(FILENUM,0,"UP"))
19 . S IENS=""
20 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D
21 .. S IND=IND+1
22 .. S IENT=$P(IENS,",",2,99)
23 .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT)
24 .. S IENROOT(IND)=$P(IENS,",",1)
25 Q
26 ;
27 ;==================================================
28CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's
29 ;to the resolved form.
30 N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE
31 N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST
32 S FILENUM=""
33 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
34 . K TYPE,VPTRLIST
35 . S IENS=""
36 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D
37 .. S FIELD=""
38 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D
39 ...;If there is no data then don't keep this entry.
40 ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q
41 ...;Get the field type, if it is a variable-pointer then set up
42 ...;the resolved form.
43 ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
44 ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
45 ... ;Remove pointers to file 200.
46 ... I PTRTO="VA(200," S DIQOUT(FILENUM,IENS,FIELD)="" Q
47 ...;If the field's type is COMPUTED then don't transport it.
48 ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
49 ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D
50 .... I '$D(VPTRLIST(FILENUM,FIELD)) D
51 ..... K VLIST
52 ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST)
53 ..... M VPTRLIST(FILENUM,FIELD)=VLIST
54 .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I")
55 .... S (PTRTO,ROOT)=$P(INTERNAL,";",2)
56 .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4)
57 .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD)
58 ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D
59 .... S (LINE,WPLCNT)=0
60 .... F S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE="" D
61 ..... S WPLCNT=WPLCNT+1
62 .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT
63 .... E K DIQOUT(FILENUM,IENS,FIELD)
64 ...;For fields that point to files 80 and 80.1 we have to append a space
65 ...;so FileMan can resolve the pointers when installing a component.
66 ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" "
67 Q
68 ;
69 ;==================================================
70CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form
71 ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE.
72 ;DIQOUT contains the GETS^DIQ output. If any of the fields are
73 ;variable pointers change them to the resolved form.
74 N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE
75 ;Clean up DIQOUT remove null entries and change .01's to the resolved
76 ;form.
77 D CLDIQOUT(.DIQOUT)
78 ;Convert the iens to the adding FDA form .
79 D BTTABLE(.DIQOUT,.IENROOT,.TTABLE)
80 S FILENUM=""
81 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
82 . S IENS=""
83 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D
84 .. S IENSA=TTABLE(FILENUM,IENS)
85 .. S FIELD=""
86 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D
87 ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD)
88 .. K DIQOUT(FILENUM,IENS)
89 Q
90 ;
91 ;==================================================
92GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J).
93 N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
94 S ^TMP(TMPIND,$J,"NUMF")=NUM
95 F IND=1:1:NUM D
96 . S TEMP=LIST(IND)
97 . S FILENAME=$P(TEMP,U,1)
98 . S FILENUM=$P(TEMP,U,2)
99 . S IEN=$P(TEMP,U,3)
100 . K DIQOUT,IENROOT
101 .;If the file entry is ok to install then get the entire entry,
102 .;otherwise just get the .01.
103 . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
104 . E S FIELD=.01
105 . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
106 . I $D(MSG) D Q
107 .. S SERROR=1,IND=NUM
108 .. N ETEXT
109 .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
110 .. W !,ETEXT
111 .. W !,"it returned the following error:"
112 .. D AWRITE^PXRMUTIL("MSG")
113 .. H 2
114 .. K MSG
115 .;Remove edit history from all reminder files.
116 . D RMEH(FILENUM,.DIQOUT)
117 .;Convert the iens to the FDA adding form.
118 . D CONTOFDA(.DIQOUT,.IENROOT)
119 . S CSUM=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
120 . S ^TMP("PXRMEXCS",$J,IND,FILENAME)=CSUM
121 .;Load the converted DIQOUT into TMP.
122 . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
123 . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT
124 Q
125 ;
126 ;==================================================
127GETREM(ACTION) ;Get the reminder to save.
128 N DIC,DUOUT,X,Y
129 S DIC="^PXD(811.9,"
130 S DIC(0)="AEMQ"
131 S DIC("A")="Select Reminder Definition to "_ACTION_": "
132 D ^DIC
133 Q Y
134 ;
135 ;==================================================
136GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
137 N DIF,IEN,IND,RA,TEMP,X,XCNP
138 S ^TMP(TMPIND,$J,"NUMR")=NUM
139 S X=""
140 F IND=1:1:NUM D
141 .;Make sure the routine exists.
142 . S X=LIST(IND)
143 . X ^%ZOSF("TEST")
144 . I $T D
145 .. K RA
146 .. S DIF="RA("
147 .. S XCNP=0
148 .. X ^%ZOSF("LOAD")
149 .. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
150 .. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA
151 . E D
152 .. S SERROR=1
153 .. W !,"Warning could not find routine ",X
154 .. H 2
155 Q
156 ;
157 ;==================================================
158RMEH(FILENUM,DIQOUT,NOSTUB) ;Clear the edit history from all reminder files.
159 ;Leave a stub so it can be filled in when the file is installed.
160 I (FILENUM<800)!(FILENUM>811.9) Q
161 N IENS,SFN,TARGET
162 ;Edit History is stored in node 110 for all files, get the
163 ;subfile number.
164 D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET")
165 S SFN=+$G(TARGET("SPECIFIER"))
166 I SFN=0 Q
167 ;Clean out the history.
168 S IENS=""
169 F S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS="" K DIQOUT(SFN,IENS)
170 ;Create a stub for the install.
171 I $G(NOSTUB) Q
172 S IENS="1,"_$O(DIQOUT(FILENUM,""))
173 S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
174 S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
175 S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)"
176 S DIQOUT(SFN,IENS,2,1)="Exchange Stub"
177 Q
178 ;
179 ;==================================================
180UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository.
181 N MSG
182 ;Try to eliminate gaps in the repository.
183 S $P(^PXD(811.8,0),U,3)=0
184 D UPDATE^DIE("E","FDA","FDAIEN","MSG")
185 I $D(MSG) D
186 . N DATE,RNAME
187 . S SUCCESS=0
188 . W !,"The update failed, UPDATE^DIE returned the following error message:"
189 . D AWRITE^PXRMUTIL("MSG")
190 . S RNAME=FDA(811.8,"+1,",.01)
191 . S DATE=FDA(811.8,"+1,",.03)
192 . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!"
193 . W !,"Examine the above error message for the reason.",!
194 . H 2
195 E S SUCCESS=1
196 Q
197 ;
Note: See TracBrowser for help on using the repository browser.