source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m@ 636

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

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