source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPEVNT.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1TIUPEVNT ; SLC/JER - Event logger for upload/filer ;3/30/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**3,21,81,131,113,184**;Jun 20, 1997
3MAIN(BUFDA,ETYPE,ECODE,TIUTYPE,FDA,MSG) ; ---- Controls branching
4 N EVNTDA
5 ; ---- ETYPE = 1: Filing error event
6 ; ---- ETYPE = 2: Missing/incorrect field error event
7 ; ---- ETYPE = 0: Other event (no errors)
8 D LOG(BUFDA,ETYPE,$G(ECODE),$G(TIUTYPE),.EVNTDA,.FDA,.MSG)
9 I ETYPE=2 D FIELDS^TIUPEVN1(EVNTDA,.MSG)
10 Q
11LOG(BUFDA,ETYPE,ECODE,TIUTYPE,EVNTDA,FDA,MSG) ; ---- Register event in
12 ; TIU UPLOAD LOG file
13 ; (#8925.4)
14 N BUFREC,ERRMSG,NEWBUF,DIC,DLAYGO,DIE,DA,DR,TIUK,TIUL,X,Y
15 S BUFREC=$G(^TIU(8925.2,+BUFDA,0))
16 S (DIC,DLAYGO)=8925.4,DIC(0)="MLX",X=""""_$$NOW^TIULC_"""" D ^DIC
17 Q:+Y'>0
18 ; ---- File upload log record
19 S DIE=DIC,(EVNTDA,DA)=+Y,ERRMSG=$$ERRMSG(ETYPE,ECODE,TIUTYPE,.FDA,.MSG)
20 S DR=".02////"_$P(BUFREC,U,2)_";.03////"_TIUTYPE_";.04////"_ERRMSG_";.06////"_$S(+ETYPE:0,1:"")_";.08////"_ETYPE_";.09////"_$S($G(TIUINST):TIUINST,1:DUZ(2))
21 D ^DIE K DA
22 I ETYPE'=1 Q
23 ; ---- Store Header of failed record in log
24 S ^TIU(8925.4,+EVNTDA,"HEAD",0)="^^^^"_DT_"^"
25 S TIUL=0 F TIUK=TIUFRST:1:$S($P(TIUPRM0,U,16)="C":TIUI,1:TIUFRST+1) D
26 . S TIUL=TIUL+1,^TIU(8925.4,+EVNTDA,"HEAD",TIUL,0)=$G(^TIU(8925.2,+BUFDA,"TEXT",TIUK,0))
27 S $P(^TIU(8925.4,+EVNTDA,"HEAD",0),U,3,4)=TIUL_U_TIUL
28 ; ---- Create a new buffer entry w/ uploaded data
29 S NEWBUF=$$MAKEBUF^TIUUPLD
30 I +NEWBUF>0 D
31 . N TIUJ,TIUL,TIUBLIN
32 . S ^TIU(8925.2,+NEWBUF,"TEXT",0)="^^^^"_DT_"^"
33 . S TIUJ=TIUFRST,TIUL=1
34 . S ^TIU(8925.2,+NEWBUF,"TEXT",TIUL,0)=$G(^TIU(8925.2,+BUFDA,"TEXT",TIUJ,0)) K ^TIU(8925.2,+BUFDA,"TEXT",TIUJ,0)
35 . F S TIUJ=$O(^TIU(8925.2,+BUFDA,"TEXT",TIUJ)) Q:$S(+TIUJ'>0:1,($G(^TIU(8925.2,+BUFDA,"TEXT",TIUJ,0))[TIUHSIG):1,1:0) D
36 . . S TIUL=TIUL+1
37 . . S ^TIU(8925.2,+NEWBUF,"TEXT",TIUL,0)=$G(^TIU(8925.2,+BUFDA,"TEXT",TIUJ,0)),TIUI=TIUJ
38 . . K ^TIU(8925.2,+BUFDA,"TEXT",TIUJ,0)
39 . S $P(^TIU(8925.2,+NEWBUF,"TEXT",0),U,3,4)=TIUL_U_TIUL
40 . ; ---- Stuff new buffer entry pointer into event log file
41 . S DIE=8925.4,DA=+EVNTDA,DR=".05////"_+NEWBUF D ^DIE
42 . ; ---- File the error log pointer in buffer file
43 . S ^TIU(8925.2,+NEWBUF,"ERR",0)="^8925.22PA^^",DLAYGO=8925.22
44 . S DA(1)=+NEWBUF,DIC="^TIU(8925.2,"_+DA(1)_",""ERR"",",DIC(0)="L"
45 . S X="`"_EVNTDA
46 . D ^DIC
47 . K DIC,DLAYGO
48 . ; ---- Send filing error alerts
49 . D ALERT(+NEWBUF,.ERRMSG,.EVNTDA)
50 Q
51ERRMSG(ETYPE,ECODE,TIUTYPE,FDA,MSG) ; ---- Set error messages
52 N DIC,DIE,DA,X,Y
53 I +ETYPE'>0 S Y="" G ERRMSX
54 S TIUTYPE=$S($G(TIUTITLE)]"":$G(TIUTITLE),1:$G(TIUTYPE))
55 I +$G(TIUREC("FILE"))=8925,($G(TIUHDR(.09))="PRIORITY"),($G(TIUTYPE)]"") S TIUTYPE="STAT "_$G(TIUTYPE)
56 ; ---- Set filing error message
57 I +ETYPE=1,+ECODE D G ERRMSX
58 . S DIC=8925.3,DIC(0)="MXZ",X="`"_ECODE D ^DIC
59 . S Y="FILING ERROR: "_$G(TIUTYPE)_" "_$P(Y(0),U,2)
60 ; ---- If target file is 8925, get info on entry & set missing fld msg
61 I $G(MSG("DIERR",1,"PARAM","FILE"))=8925 D G ERRMSX
62 . N TIU,DA S DA=+$O(FDA(8925,"")) D GETTIU^TIULD(.TIU,DA)
63 . S Y=$$NAME^TIULS(TIU("PNM"),"LAST,FI MI ")
64 . S:$G(TIUHDR("TIUTITLE"))]"" TIUTYPE=TIUHDR("TIUTITLE")
65 . S Y=Y_TIU("PID")_": "_$$DATE^TIULS(+TIU("EDT"),"MM/DD/YY ")_$G(TIUTYPE)_" is missing fields."
66 ; ---- Otherwise get message from FM Filer error msg array
67 S Y=$G(MSG("DIERR",1,"TEXT",1))
68ERRMSX Q Y
69ALERT(BUFDA,ERRMSG,EVNTDA) ; ---- Send alerts for filing errors
70 N BUFREC,XQA,XQAID,XQADATA,XQAMSG,XQAKILL,XQAROU,TIUI,TIUSUB,TYPE
71 S BUFREC=$G(^TIU(8925.2,+BUFDA,0))
72 ; ---- TIU*1*81 TIUHDR is newed in MAIN+11^TIUPUTC, set in
73 ; GETREC^TIUPUTC1, so it exists for file errs.
74 S TYPE=+$$WHATITLE^TIUPUTU($G(TIUHDR("TIUTITLE")))
75 I TYPE'>0 S TYPE=+$G(TIUREC("TYPE"))
76 I TYPE N TIUDAD D WHOGETS^TIUPEVN1(.XQA,TYPE) ;TIU*1*81 New TIUDAD here, not in WHOGETS
77 ; ---- If no 8925.95 (Document Parameter) recipients, get 8925.99
78 ; (Site Parameter) recipients
79 I $D(XQA)'>9 D
80 . S TIUI=$O(^TIU(8925.99,"B",+$G(DUZ(2)),0)) S:+TIUI'>0 TIUI=+$O(^TIU(8925.99,0))
81 . S TIUSUB=0 F S TIUSUB=$O(^TIU(8925.99,+TIUI,2,TIUSUB)) Q:TIUSUB'>0 D
82 . . S XQA($G(^TIU(8925.99,+TIUI,2,TIUSUB,0)))=""
83 Q:$D(XQA)'>9
84 S XQAID="TIUERR"_+BUFDA
85 S XQAMSG=ERRMSG
86 W:'$D(ZTQUEUED) !!,XQAMSG,!
87 S XQADATA=BUFDA_";"_ERRMSG_";"_EVNTDA_";"_$G(TIUREC("TYPE"))
88 S XQAROU="DISPLAY^TIUPEVNT"
89 D SETUP^XQALERT
90 Q
91DISPLAY ; ---- Alert followup action for filing errors
92 N DIC,INQUIRE,RETRY,DWPK,EVNTDA,TIU K XQAKILL,RESCODE,TIUTYPE,TIUDONE
93 N TIUEVNT,TIUSKIP,TIUBUF,PRFILERR
94 I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
95 ; Set EVNTDA for backward compatibility, TIUEVNT for PN resolve code
96 S (EVNTDA,TIUEVNT)=+$P(XQADATA,";",3)
97 ; Set TIUBUF for similarity w TIURE. DON'T set BUFDA since
98 ; old code interprets that as set by TIURE only:
99 S TIUBUF=+XQADATA
100 I TIUEVNT D I +$G(TIUDONE)!$G(TIUSKIP) G DISPX
101 . D WRITEHDR(TIUEVNT)
102 . S TIUTYPE=+$P(XQADATA,";",4)
103 . I TIUTYPE>0 S RESCODE=$$FIXCODE^TIULC1(TIUTYPE)
104 . ;E S RESCODE="D GETPAT^TIUCHLP"
105 . I $G(RESCODE)]"" D Q
106 . . W ! S INQUIRE=$$READ^TIUU("YO","Inquire to patient record","YES","^D INQRHELP^TIUPEVNT")
107 . . I $D(DIRUT) S TIUSKIP=1 Q
108 . . I +INQUIRE X RESCODE
109 . . ; Redundant if all RESCODEs do RESOLVE:
110 . . I +$G(TIUDONE),+$G(TIUEVNT) D RESOLVE(+$G(TIUEVNT))
111 . W !!,"Filing error resolution code could not be found for this document type.",!,"Please edit the buffered data directly and refile."
112 W !!,"You may now edit the buffered upload data in an attempt to resolve error:",!,$P(XQADATA,";",2),!
113 I '$$READ^TIUU("EA","Press RETURN to continue and edit the buffer or '^' to exit: ") G DISPX
114 S DIC="^TIU(8925.2,"_TIUBUF_",""TEXT"",",DWPK=1 D EN^DIWE
115 S RETRY=$$READ^TIUU("YO","Now would you like to retry the filer","YES","^D FIL^TIUDIRH")
116 ; -- If refiling, tell Patient Record Flag LOOKUP to ask for flag link:
117 I +RETRY S PRFILERR=1
118 ; -- Refile
119 I +RETRY D ALERTDEL(TIUBUF)
120 I +RETRY D RESOLVE(TIUEVNT,1)
121 I +RETRY D FILE^TIUUPLD(TIUBUF)
122DISPX K XQX1
123 Q
124WRITEHDR(EVNTDA) ; ---- Write header to screen
125 ;Write header, as stored in Upload Log event (NOT buffer record,
126 ;which can be edited w/o refiling)
127 N TIUI
128 S TIUI=0
129 W !!,"The header of the original, failed record looks like this:",!
130 F S TIUI=$O(^TIU(8925.4,+EVNTDA,"HEAD",TIUI)) Q:+TIUI'>0 D
131 . W !,$G(^TIU(8925.4,+EVNTDA,"HEAD",TIUI,0))
132 Q
133ALERTDEL(DA) ; ---- Delete alerts associated with a given record
134 N XQA,XQAID,XQAKILL S XQAID="TIUERR"_+DA
135 F D DELETEA^XQALERT S XQAID="TIUERR"_+DA Q:'$D(^VA(200,"AXQAN",XQAID))
136 Q
137RESOLVE(EVNTDA,ECHO) ; ---- Indicate resolution of error
138 N DA,DIE,DR,TIUI,RESTIME,X,Y
139 W:+$G(ECHO) !,"Filing Record/Resolving Error..."
140 S RESTIME=$$NOW^TIULC
141 S DIE="^TIU(8925.4,"
142 S DA=+$G(EVNTDA) Q:+DA'>0
143 ; ---- If already resolved, Quit. (Go on to next record)
144 I +$P(^TIU(8925.4,DA,0),U,6)>0 Q
145 ; ---- Mark error log record as resolved
146 S DR=".05///@;.06////1;.07////"_RESTIME_";1///@"
147 D ^DIE
148 Q
149INQRHELP ; Help for Upload Error Inquire to Patient Record prompt
150 W !,"Do you wish to be prompted for the data necessary to resolve the filing error?"
151 W !,"If not, answer NO to proceed and edit the buffered data directly without"
152 W !,"prompts, or enter '^' to come back and resolve the error later."
153 Q
Note: See TracBrowser for help on using the repository browser.