source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR302PO.m@ 1535

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1LR302PO ;DALOI/FHS/RSH - LR*5.2*302 PATCH POST INSTALL ROUTINE;31-AUG-2001
2 ;;5.2;LAB SERVICE;**302**;Sep 27,1994
3PRE ;
4 ;$$HTE^XLFDT supported by DBIA #10103
5 ;$$HTFE^XLFDT supported by DBIA #10103
6 ;$$NOW^XLFDT supported by DBIA #10103
7 ;$$CJ^XLFSTR supported by DBIA #10104
8 ;^XMD supported by DBIA #10070
9 ;$$PATCH^XPDUTL supported by DBIA #10141
10 ;BMES^XPDUTL supported by DBIA #10141
11 ;SETUP^XQALERT supported by DBIA $10081
12 ;FILE^DIE supported by DBIA #10018
13 ;GETS^DIQ supported by DBIA #2056
14 ;EN^DIU2 supported by DBIA #10014
15 ;$$SITE^VASITE supported by DBIA #10112
16 ;$$FMTE^XLFDT supported by DBIA #10103
17 ;$$THE^XLFDT supported by DBIA #10103
18 ;$$HTFM^XLFDT supported by DBIA #10103
19 Q:'$D(XPDNM)
20VENDOR ;Save the vender pointer name into the VENDOR field.
21 N LRI,LRVEN
22 S LRI=0 F S LRI=$O(^LAB(64.2,LRI)) Q:LRI<1 S LRVEN=$P($G(^(LRI,0)),U,14) I LRVEN D
23 . S LRVEN=$P($G(^LAB(64.3,+LRVEN,0)),U)
24 . I $L(LRVEN) S $P(^LAB(64.2,LRI,2),U,2)=LRVEN
25 I '$D(^XTMP("LRNLT642")) D
26 . N LRLAST
27 . S LRLAST=$O(^LAB(64.2,99999),-1)
28 . S ^XTMP("LRNLT642",.01)=LRLAST
29 . S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^ LAB(64.2 Save"
30 . M ^XTMP("LRNLT642",1)=^LAB(64.2)
31 Q
32EN1 ;Find and correct existing spelling or duplicate numbers errors.
33 N DA,DIC,DIK,DIU,X,Y,DIRUT,DTOUT,DUOUT
34REINDEX ;Reindex LAM to fire new x-refs
35 L +^LAM:999 I '$T G EN1
36 D
37 . N DIK
38 . S DIK="^LAM(" D IXALL^DIK
39 . S $P(^LAM(0),U,3)=99999
40 K ^XTMP("LRNLTERR","LR302") S ^XTMP("LRNLTERR","LR302",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 302 Error Messages"
41 K ^XTMP("LRNLT","LR302")
42 S ^XTMP("LRNLT","LR302",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 302 Messages"
43 N DA,DIK,LRIEN,LRN0,LRN1,LRFILE
44 D POST,ALERT^LR302POA
45 Q
46 ;
47CHK N DIC,X,Y
48 K LRFDA,LRANS,LRNAMX,LRNUMX,LRNAMY,LRNUMY
49 S DIC(0)="ZNMO",(LRNAMX,LRNAMY,X)=$P(LRN0,U)
50 I $G(LRFILE)=64 D
51 . S DIC=64,(LRNUMY,LRNUMX)=$P(LRN0,U,2)
52 . S DIC("S")="I $P(^(0),U,2)=LRNUMX"
53 . D ^DIC I Y<1 D DEL Q
54 . W:$G(LRDBUG) !,Y_" ( "_LRFILE
55 . S LRIENS=+Y_","
56 . I $L($P(LRN0,U,8)) D
57 . . S LRNAMY=$P(LRN0,U,8)
58 . . S LRFDA(LRFILE,LRIENS,.01)=LRNAMY
59 . I $P(LRN0,U,3) D
60 . . S LRNUMY=$P(LRN0,U,3)
61 . . Q:$O(^LAM("C",LRNUMY_" ",0))
62 . . S LRFDA(LRFILE,LRIENS,1)=LRNUMY
63 I $G(LRFILE)=64.2 D
64 . N DIC
65 . S (LRNAMX,LRNAMY,X)=$P(LRN0,U)
66 . S DIC=64.2,LRNUMX=$P(LRN1,U,2)
67 . S DIC("S")="I $P(^(0),U,2)=LRNUMX"
68 . D ^DIC I Y<1 D DEL Q
69 . S LRIENS=+Y_","
70 . I $L($P(LRN0,U,8)) D
71 . . S LRNAMY=$P(LRN0,U,8)
72 . . S LRFDA(LRFILE,LRIENS,.01)=LRNAMY
73 . I $P(LRN1,U,3) D
74 . . S LRNUMY=$P(LRN1,U,3)
75 . . S LRFDA(LRFILE,LRIENS,1)=LRNUMY
76 . I $L($P(LRN1,U,7)) D
77 . . S LRSYN=$P(LRN1,U,7),LRSYNIEN=$O(^LAB(64.2,+LRIENS,1,"B",LRSYN,0))
78 . . Q:'LRSYNIEN
79 . . S LRFDA(64.23,LRSYNIEN_","_LRIENS,.01)="@"
80 . W:$G(LRDBUG) !,Y_" ( "_LRFILE
81 I $D(LRFDA) D SET
82 Q
83SET ;
84 D FILE^DIE("KS","LRFDA","LRANS")
85 I '$D(LRANS) W:$G(LRDBUG) !,"Okay" D Q
86 . D WRT,DEL
87 Q ; EDIT ERRORS are left in ^LAB(64.81)
88 ;
89DEL ;
90 N DA,DIK
91 S DA=LRIEN,DIK="^LAB(64.81," D ^DIK
92 Q
93ERR ;
94 W !,LRIEN_" ( "_LRFILE_" ERROR"
95 Q
96WRT ;
97 D SCR(LRNUMX_" "_LRNAMX)
98 D SCR("Was changed to: "_LRNUMY_" "_LRNAMY)
99 Q
100POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
101 K ^XTMP("LRNLT","LR302") D
102 . S ^XTMP("LRNLT","LR302",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_"LR302 Added NLT Codes List"
103 D DSS W !
104P1 F L +^LAM:10 Q:$T D BMES^LR302("Attempting to Lock ^LAM Global.")
105 S (LRLAST64,LRNEXT)=$O(^LAM(99999),-1)
106 S:LRNEXT<1 (LRLAST64,LRNEXT)=0
107 S $P(^LAM(0),U,3)=LRNEXT
108 S LRN=$O(^XTMP("LRNLT642",1,99999),-1)
109 S (LRADD,LRCHG,LRDOT)=0
110 D SCR("==========================")
111 D SCR("List of WKLD CODES added to ^LAM (#64)")
112 D SCR(" ")
113 S LRNEXT=0,LRIEN=50
114 F S LRNEXT=$O(^LAB(64.81,LRIEN,2,LRNEXT)) Q:LRNEXT<1 D
115 . K LRFDA,LROUT,LRAR1,LRSIXT4
116 . S LRDOT=$G(LRDOT)+1 I LRDOT#50=0 W ". "
117 . S LRREC=^LAB(64.81,LRIEN,2,LRNEXT,0),LRERR=0
118 . I $G(LRDBUG) W !,LRREC_" "
119 . S LRTRIEN=$P(LRREC,U)
120 . I $S($P(LRREC,U,2)["~":1,$P($P(LRREC,U,3),".",2):1,1:0) D KREC Q
121 . D CMP
122 . Q:LRERR
123 . I LRCHG D CHGNM
124 . I LRADD D GNDE
125 . I $S($G(LROUT(42,"DIERR")):0,$G(LROUT(45,"DIERR")):0,1:1) D KREC
126 . K LROUT
127 S $P(^LAM(0),U,3)=99999,LRVR=$T(+2)
128 S ^LAM("VR")=LRVR
129 N LRI
130 F LRI=64.061,64.2,64.21,64.22,64.3,95.3,95.31 I $D(^LAB(LRI,0))#2 S ^LAB(LRI,"VR")=LRVR
131 D:'$G(LRDBUG) MAIL^LR302POA
132KIL K LRADD,LRANS,LRAR1,LRBEG,LRCHG,LRCNT,LRCODE,LRCTR,LRDOT,LREND
133 K LRENODE,LRERR,LRFDA,LRFILE,LRFLD,LRFLE,LRFNAM,LRI,LRIEN,LRIENS
134 K LRMLT,LRN,LRN0,LRN1,LRNAMX,LRNAMY,LRNEXT,LRNIEN,LRNODE,LRNUM
135 K LRNUMX,LRNUMY,LRNX,LROUT,LRPROCNM,LRREC,LRSC,LRSCR,LRSEQ,LRSIXT4
136 K LRSUBFLE,LRSYN,LRSYNIEN,LRTRIEN,LRVAL,LRVR,X,Y
137 Q
138CHGNM ; CHANGE THE PROCEDURE NAME IN THE RECORD
139 K LRFDA
140 S LRFDA(42,64,LRCHG_",",.01)=LRPROCNM
141 D FILE^DIE("K","LRFDA(42)","LROUT(42)")
142 I $G(LROUT(42,"DIERR")) D
143 . S LRERR=1
144 . S LRENODE="LROUT(42,""DIERR"")"
145 . D ERMSG
146 I '$G(LROUT(42,"DIERR")) D SCR(LRCODE_"|"_LRPROCNM_"|"_"**Procedure Name Changed**")
147 K LRFDA(42),LRPROCNM
148 Q
149CMP ; COMPARE FOUND CODES AND PROCEDURE NAMES
150 N DIC,X,Y,ANS
151 S (LRADD,LRCHG,LRERR)=0
152 S LRCODE=$P(LRREC,U,3),LRPROCNM=$P(LRREC,U,2)
153 S Y=+$$FIND1^DIC(64,"","XO",LRCODE_" ","C","","ANS")
154 I Y<1 D
155 . S LRADD=1,LRN=$G(LRN)+1
156 . D SCR(LRCODE_"|"_LRPROCNM_"|")
157 Q
158SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
159 S LRSCR=$G(^XTMP("LRNLT","LR302",1,0))+1,^(0)=LRSCR
160 S ^XTMP("LRNLT","LR302",1,LRSCR)=LRSCR_"|"_LRMSG
161 Q
162SETUP ; SETS UP THE FDA ARRAY TO ADD A NODE
163 F S LRNODE=$Q(@LRNODE) Q:LRNODE="" D
164 . S LRFLE=$QS(LRNODE,1)
165 . S LRFLD=$QS(LRNODE,3)
166 . I LRFLE=64.8117 D
167 . . S LRSUBFLE=64
168 . . I LRFLD=1 S LRFLD=.01
169 . . I LRFLD>1 S LRFLD=LRFLD-1
170 . . S LRIENS="+"_LRTRIEN_","
171 . I LRFLE'=64.8117 D
172 . .; CONSTRUCT THE SUBFILE NUMBER FOR FILE 64 FROM 64.81
173 . . S LRBEG=$P(LRFLE,"8117")
174 . . S LREND=$P(LRFLE,"8117",2)
175 . . S LRSUBFLE=LRBEG_"0"_LREND
176 . . I LRFLD=.01 S LRSEQ=LRSEQ+1
177 . . S LRIENS="+"_LRSEQ_","_"+"_LRTRIEN_","
178 . S LRVAL=@LRNODE
179 . S LRFDA(45,LRSUBFLE,LRIENS,LRFLD)=LRVAL
180 . ;W !,"LRFDA(45,"_LRSUBFLE_","_LRIENS_LRFLD_")="_LRVAL
181 K LRAR1
182 Q
183GNDE ; RETRIEVES NODES FROM THE TRANSPORT MULTIPLE
184 S LRMLT="",LRCTR=1
185 D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
186 S LRNODE="LRAR1(64.8117_LRMLT)"
187 D SETUP
188 I $D(^LAB(64.81,50,2,LRTRIEN,1,0)) S LRNUM=$P(^LAB(64.81,50,2,LRTRIEN,1,0),U,4),LRSEQ=LRNUM+1
189 E I '$D(^LAB(64.81,50,2,LRTRIEN,1,0)) S LRSEQ=2
190 S LRMLT=18
191 D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
192 S LRNODE="LRAR1(64.8117_LRMLT)"
193 D SETUP
194 S LRMLT=19,LRSEQ=1
195 D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
196 S LRNODE="LRAR1(64.8117_LRMLT)"
197 D SETUP
198 D AREC I $G(LRDBUG) W !,"NEW IEN=",$G(LRSIXT4(LRTRIEN))
199 K LRSIXT4,LRFDA(45)
200 Q
201AREC ; ADDS ENTRIES FROM THE TRANSPORT MULTIPLE TO FILE 64
202 D UPDATE^DIE("","LRFDA(45)","LRSIXT4","LROUT(45)")
203 I $G(LROUT(45,"DIERR")) D
204 . S LRENODE="LROUT(45,""DIERR"")"
205 . D ERMSG
206 K LRFDA(45)
207 Q
208ERMSG ;STUFF THE TEMP GLOBAL WITH ANY ERROR MESSAGES
209 S LRN=$G(^XTMP("LRNLT642",1,0))+1
210 S ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|ERR"
211 F S LRENODE=$Q(@LRENODE) Q:LRENODE="" D
212 . S LRN=LRN+1
213 . S ^XTMP("LRNLT642",1,LRN,0)="|"_LRENODE_"|="_@LRENODE
214 S ^XTMP("LRNLT642",1,0)=LRN
215 S LRERR=1
216 K LRENODE
217 Q
218KREC ; DELETES THE RECORD FROM THE FILE
219 Q:$G(LRDBUG)
220 N DA,DIK
221 S DA(1)=LRIEN,DA=LRTRIEN
222 S DIK="^LAB(64.81,"_DA(1)_",2," D ^DIK
223 Q
224DSS ;Update WKLD CODE file , DSS Feeder Key (#14) field to 'Yes"
225 ;for those NLT codes used for AP professional services
226 D BMES^LR302("Updating DSS Feeder Key for AP NLT Codes")
227 N ERR,FDA,IEN,LST,OUT,NODE,X
228 S NODE="^LAB(64.81,""AC"")"
229 F S NODE=$Q(@NODE) Q:$QS(NODE,2)'="AC" D
230 . S X=$P($$GET1^DIQ(64.8117,$QS(NODE,5)_","_$QS(NODE,4)_",",2,"I","ERR"),".")
231 . Q:'X
232 . K OUT,ERR
233 . D FIND^DIC(64,"","@;1","M",X,"","C","","","OUT","ERR")
234 . Q:$D(ERR)
235 . S LST=0 F S LST=$O(OUT("DILIST",2,LST)) Q:'LST D
236 . . S IEN=$G(OUT("DILIST",2,LST))
237 . . Q:'($D(^LAM(IEN,0))#2)
238 . . K FDA,ERR S FDA(1,64,IEN_",",14)=1
239 . . D FILE^DIE("","FDA(1)","ERR")
240 . . I $D(ERR) W !,$C(7),ERR
241 . . W "*"
242 D BMES^LR302("Update DSS AP Feeder Key Complete")
243 Q
Note: See TracBrowser for help on using the repository browser.