source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m@ 619

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

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1PRCVRC2 ;WOIFO/BMM/VAC - silently build RIL for DynaMed ; 12/3/07 10:32am
2V ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;12/07 Code modified to fix error in GETTXN due to logic error.
6 ; Added KILL statements to eliminate finding random ^TMP global data
7 ; from other routines and to clean up ^DIC calls.
8 ;
9 ;validation, error code for PRCVRC1
10 ;
11 Q
12 ;
13GETFY(PRCVDT) ;return the fiscal year, PRCVDT is date/time the DM
14 ;message was created (thus the date/time for RIL)
15 ;
16 Q $E(100+$E(PRCVDT,2,3)+$E(PRCVDT,4),2,3)
17 ;
18GETQTR(PRCVDT) ;return the fiscal quarter, PRCVDT is date/time the DM
19 ;message was created (thus the date/time for RIL)
20 ;
21 N QTR S QTR=+$E(PRCVDT,4,5)
22 Q $P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR)
23 ;
24GETTXN(PRCVSTR) ;obtain current transaction number (if exists) from
25 ;Transaction Number file (#410.1)
26 ;increment transaction for current use, update 410.1 entry
27 ;return new transaction number for this RIL
28 ;PRCVSTR is Entry Number, comes in as "station-fy-qtr-fcp-cc"
29 ;TXN is transaction #, PRCVRN is IEN for 410.1 entry
30 ;NOTE: CHECK 410 too, look in EN1^PRCSUT3, lines 8-10 etc.
31 ;
32 Q:$G(PRCVSTR)="" 0
33 N TXN,PRCVE,PRCVRN S TXN="",(PRCVRN,PRCVE)=0
34 ;check if Entry Number def in 410.1
35 K ATXN,^TMP("DIERR",$J),^TMP("DILIST",$J)
36 D FIND^DIC(410.1,,"1","BX",PRCVSTR,,,,,"ATXN")
37 ;
38 S TXN=+$G(ATXN("DILIST","ID",1,1))
39 S PRCVRN=$G(ATXN("DILIST",2,1))
40 I TXN<1 D Q:PRCVE=1 0
41 . ;TXN=0 so Entry Number not def, create new
42 . K PRCVAT S PRCVAT(410.1,"+1,",.01)=PRCVSTR
43 . S PRCVAT(410.1,"+1,",2)=DT
44 . S PRCVAT(410.1,"+1,",1)=1
45 . K ^TMP("DIERR",$J),^TMP("DILIST",$J)
46 . D UPDATE^DIE("","PRCVAT","PRCVRN")
47 . ;don't send msg here
48 . ;I $D(^TMP("DIERR",$J)) D SENDMSG(7,PRCVGL,0,1) S PRCVE=1 Q
49 . I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) S PRCVE=1 Q
50 . S PRCVRN=PRCVRN(1)
51 S TXN=TXN+1
52 K PRCVSA S PRCVSA(410.1,PRCVRN_",",1)=TXN
53 K ^TMP("DIERR",$J),^TMP("DILIST",$J)
54 D FILE^DIE("","PRCVSA")
55 ;don't send msg here
56 ;I $D(^TMP("DILIST",$J)) D SENDMSG(7,PRCVGL,0,1) Q 0
57 I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) Q 0
58 K ^TMP("DIERR",$J),^TMP("DILIST",$J)
59 S TXN="000"_TXN,TXN=$E(TXN,$L(TXN)-3,$L(TXN))
60 Q TXN
61 ;
62CHKDT(INDT) ;check the incoming date (date/time message created) against
63 ;the present date. date/time message created must be today or in
64 ;the past. if INDT is today or before today then return 1, else
65 ;return 0
66 ;both dates are in Fileman format ex. 3050503.12446
67 ;
68 Q:$G(INDT)="" 0
69 N %,PRESENT,PRCVDIFF
70 D NOW^%DTC S PRESENT=%
71 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1)
72 I PRCVDIFF'<0 Q 1
73 Q 0
74 ;
75CHKDTN(INDT) ;check the incoming date (Date Needed By from DynaMed)
76 ;against the present date. Date Needed By must be today or in the
77 ;future. if INDT is today or after today then return 1, else return 0
78 ;both dates are in FileMan format ex. 3050503.12446
79 ;
80 Q:$G(INDT)="" 0
81 N %,PRESENT,PRCVDIFF
82 D NOW^%DTC S PRESENT=%
83 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1)
84 I PRCVDIFF'>0 Q 1
85 Q 0
86 ;
87CHKBOC(ITEM,BOC) ;test BOC from passed-in detail record
88 ;
89 Q:$G(ITEM)="" 0
90 N PRCVIBOC
91 S PRCVIBOC=$$GET1^DIQ(441,ITEM_",",12,"I")
92 I PRCVIBOC'=BOC Q 0
93 Q 1
94 ;
95CHKFCP(PRCVFCP,PRCVST) ;validate that FCP is in 420
96 ;
97 Q:$G(PRCVFCP)=""!($G(PRCVST)="") 0
98 N PRCVE,PRCVN,PRCVVAL
99 S PRCVVAL=1,PRCVN=0
100 S PRCVN=$$FIND1^DIC(420.01,","_PRCVST_",","",PRCVFCP_" ","B","","PRCVE")
101 I +PRCVN'>0 S PRCVVAL=0
102 Q PRCVVAL
103 ;
104CHKITM(PRCVITM) ;check extracted item number:
105 ;1. must be greater than 100000
106 ;2. must be defined in Item Master (#441) file
107 ;3. must not be inactive (441 field 16 '=1)
108 ;
109 Q:$G(PRCVITM)="" 0
110 N CITM S CITM=0
111 ;N NITM
112 ;S NITM=$$FIND1^DIC(441,"","X",PRCVITM,"","","ATXN")
113 ;I '$D(ATXN) Q 1
114 I PRCVITM'<100000,$D(^PRC(441,"B",PRCVITM)) D
115 . I +$$GET1^DIQ(441,PRCVITM_",",16,"I")=0 S CITM=1
116 Q CITM
117 ;
118CHKVEND(VENDN) ;check that vendor in Vendor file is active.
119 ;VENDN is Vendor number
120 ;
121 Q:+VENDN=0 0
122 N NVNDP,CHKFLG
123 S CHKFLG=0
124 I $D(^PRC(440,VENDN,0)),$$GET1^DIQ(440,VENDN_",",32,"I")="" S CHKFLG=1
125 Q CHKFLG
126 ;
127CHKVI(VENDN,ITMN) ;check that vendor VENDN sells item ITMN
128 ;can't use $$FIND1^DIC since could be >1 cross-ref and >1 node
129 ;
130 N ITMNN,VENDP,CHKFLG
131 S (VENDP,ITMNN,CHKFLG)=0
132 Q:+VENDN=0!(+ITMN=0) CHKFLG
133 ;get item ien, quit if undef
134 S ITMNN=$O(^PRC(441,"B",ITMN,0))
135 Q:ITMNN="" CHKFLG
136 ;get pointer to vendor ien
137 S VENDP=$O(^PRC(441,ITMNN,2,"B",VENDN,0))
138 ;check that vendor is defined
139 I VENDP>0,$D(^PRC(440,VENDP,0)) S CHKFLG=1
140 ;if item file defined and vendor for item defined, good
141 Q CHKFLG
142 ;
143CHKDUZ(INDUZ) ;validate that DUZ against New Person (#200)
144 ;
145 N DUZFLG S DUZFLG=0
146 Q:$G(INDUZ)="" DUZFLG
147 I $D(^VA(200,INDUZ,0)) S DUZFLG=1
148 Q DUZFLG
149 ;
150CHKNIF(ITEM,NIF) ;use the passed-in item to check that the passed-in
151 ;NIF# is correct. return 1 if valid, 0 if not valid
152 ;
153 N PRCVINIF
154 S PRCVINIF=$$GET1^DIQ(441,ITEM_",",51)
155 I PRCVINIF=NIF Q 1
156 Q 0
157 ;
158MAKECAP(INSTR) ;take INSTR and return an all-caps version of it
159 ;
160 Q:$G(INSTR)="" ""
161 N X,Y
162 S X=INSTR X ^%ZOSF("UPPERCASE")
163 Q Y
164 ;
165SENDMSG(EC,PRCVGL,CTR,ERPC) ;send an alert or error message back to
166 ;DynaMed via VIE by posting "ERR" node to appropriate ^XTMP node
167 ;
168 ;the error text is currently stored in the routine PRCVRC3
169 ;
170 ;EC is the error code
171 ;use EC to get the description and severity
172 ;the message is built in ECSTR and the "ERR" node in ^XTMP is
173 ; created using passed-in message id in MID. the error message
174 ; is appended to "ERR" and is separated by other error messages
175 ; already there with a carat ("^")
176 ;PRCVGL is the ^XTMP subscript and CTR is the detail counter #
177 ;ERPC is the data piece in the line item node or header node to
178 ; which the error pertains
179 ;
180 N X S X="PRCVRC3"
181 X ^%ZOSF("TEST") I '$T Q
182 N ECSTR,OVERSTR,ERRCTR
183 S ERPC=$G(ERPC)
184 S ECSTR=ERPC_"^"_$P($T(ET+EC^PRCVRC3),";;",2),CTR=+CTR
185 I CTR'=0 D
186 . S ERRCTR=+$O(^XTMP(PRCVGL,2,CTR,"ERR",""),-1)
187 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,2,CTR,"ERR",ERRCTR)=ECSTR
188 I CTR=0 D
189 . S ERRCTR=+$O(^XTMP(PRCVGL,1,"ERR",""),-1)
190 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,1,"ERR",ERRCTR)=ECSTR
191 Q
192 ;
193ADDAUD(ADDSTR) ;add "^"-pieces from ADDSTR as fields to a new record in
194 ;the Audit file #410.02
195 ;
196 ;ADDSTR pieces: DynaMed Doc ID ^ Item # ^ Vendor ^ User DUZ ^
197 ; Last name,First name ^ RIL# ^ date/time RIL created ^
198 ; date/time message created (DynaMed requisition) ^ date needed
199 ;
200 Q:$G(ADDSTR)=""
201 ;
202 ;set up entry
203 N PRCVA,PRCVI,PRCVP,PRCVRIL,PRCVTMP S PRCVA="",PRCVP=0
204 F PRCVI=.01,1,2,3,13,4,5,6,12 S PRCVP=PRCVP+1 D
205 . S PRCVA(414.02,"+1,",PRCVI)=$P(ADDSTR,U,PRCVP)
206 ;add record to Audit File
207 D UPDATE^DIE("","PRCVA")
208 ;if error, send bulletin
209 I $D(^TMP("DIERR",$J)) D Q
210 . S PRCVTMP="PRCVRC2",PRCVRIL=$P(ADDSTR,U,5)
211 . S XMB(1)="creating an entry in the DynaMed Audit File (#414.02)"
212 . S XMB(2)=$P(ADDSTR,U)
213 . S XMB(3)="unable to create Audit File entry"
214 . S ^TMP($J,"PRCVRC2",1,0)="",PRCVP=1
215 . S ^TMP($J,"PRCVRC2",2,0)="DynaMed Doc ID: "_$P(ADDSTR,U)
216 . S ^TMP($J,"PRCVRC2",3,0)="Item #: "_$P(ADDSTR,U,2)
217 . S ^TMP($J,"PRCVRC2",4,0)="Vendor #: "_$P(ADDSTR,U,3)
218 . S ^TMP($J,"PRCVRC2",5,0)="User DUZ: "_$P(ADDSTR,U,4)
219 . S ^TMP($J,"PRCVRC2",6,0)="RIL #: "_$P(ADDSTR,U,5)
220 . S ^TMP($J,"PRCVRC2",7,0)="Message date/time: "_$P(ADDSTR,U,6)
221 . S ^TMP($J,"PRCVRC2",8,0)="RIL create date: "_PRCVRIL
222 . S ^TMP($J,"PRCVRC2",9,0)="Date Needed: "_$P(ADDSTR,U,8)
223 . S ^TMP($J,"PRCVRC2",10,0)="Error: "_$G(^TMP("DIERR",$J,1,"TEXT",1))
224 . S PRCVST=$P(PRCVRIL,"-"),PRCVFCP=$P(PRCVRIL,"-",4)
225 . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
226 Q
227 ;
Note: See TracBrowser for help on using the repository browser.