source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUCPFIX.m@ 1354

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1TIUCPFIX ; SLC/JER,RMO - Resolve Filing errors for CP Documents ;4/18/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**109,167,113**;Jun 20, 1997
3 ; This routine is a modified version of TIUPEFIX
4MAKE(SUCCESS,DFN,TITLE,TIU,TIUBUF,TIUPLDA) ; File new TIU Document
5 ; SUCCESS = (by ref) SUCCESS Returns TIU DOCUMENT # (PTR to 8925)
6 ; = 0^Explanatory message if no SUCCESS
7 ; DFN = Patient (#2)
8 ; TITLE = Pointer to TIU Document Definition (#8925.1)
9 ; TIU = Array of demographic and visit attributes
10 ; TIUBUF = Record number (ien) of entry in TIU Buffer file (#8925.2)
11 ; TIUPLDA = Record number (ien) of entry in TIU Document file (#8925) (Optional)
12 ;
13 ; -- first, get TIU Document record --
14 ;
15 N TIUDA,LDT,NEWREC,TIUX,TIUTYP,TIUDPRM,HAPPY,TIUCLASS,TIUDTYP,TIUPOST
16 N TIUDFLT,TIUREC,TIUCNNBR,TIUDNB,TIUDTP,TIUPSC,TIUQUIT
17 S SUCCESS=0 ; Initialize SUCCESS to false
18 I '$G(TIUPLDA) D G MAKEQ:$G(TIUQUIT)
19 . I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,+$G(TIUTYPE)'>0:1,1:0) S SUCCESS="0^"_$$EZBLD^DIALOG(89250001) S TIUQUIT=1 Q
20 . ; If target file is not 8925 QUIT
21 . I +$G(^TIU(8925.1,+TIUTYPE,1))'=8925 S TIUQUIT=1 Q
22 . S TIUDTYP=$P($G(^TIU(8925.1,+TIUTYPE,0)),U,4)
23 . S TIUCLASS=$S(TIUDTYP="CL":+TIUTYPE,1:38)
24 . S TIUDFLT=$S(TIUCLASS'=TIUTYPE:TIUTYPE,1:"")
25 . I +$G(TITLE)'>0 S TITLE=$$ASKTITLE^TIULA3(TIUCLASS,TIUDFLT)
26 . I +TITLE'>0 S TIUQUIT=1 Q
27 ELSE D
28 . S TITLE=+$G(^TIU(8925,+TIUPLDA,0))
29 S TIUTYP=TITLE,TIUTYP(1)=1_U_TITLE
30 D DOCPRM^TIULC1(TITLE,.TIUDPRM)
31 ;
32 ; -- second, load the header elements & text into TIUX array
33 ;
34 D LOADTIUX(.TIUX,TIUBUF)
35 ;
36 ;Set variables
37 I $G(TIUPLDA) D
38 . S TIUCNNBR=+$P($G(^TIU(8925,+TIUPLDA,14)),U,5)
39 ELSE D
40 . S TIUCNNBR=$S(+$P($G(TIUX(1405)),"C.",2):+$P($G(TIUX(1405)),"C.",2),1:"")
41 . S:$G(TIUX(.001)) TIUPLDA=$G(TIUX(.001))
42 S TIUPSC=$G(TIUX(70201))
43 S TIUDTP=$G(TIUX(70202))
44 ;
45 ;Check consult associated with document
46 I '$$CHKCN^TIUPUTCP(TIUCNNBR,DFN,$G(TIUPLDA),.TIUDNB) S SUCCESS="0^"_$$EZBLD^DIALOG($G(TIUDNB)) G MAKEQ
47 ;
48 ;Check consult as it related to CP
49 I '$$CHKCP^TIUPUTCP(TIUCNNBR,$G(TIUPLDA),.TIUDNB) S SUCCESS="0^"_$$EZBLD^DIALOG($G(TIUDNB)) G MAKEQ
50 ;
51 ;If TIU document IEN is defined use it, otherwise call TIUEDI3
52 I $G(TIUPLDA) D
53 . S TIUDA=TIUPLDA
54 ELSE D
55 . S TIUDA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.NEWREC,.TIUDPRM)
56 I +TIUDA'>0 S SUCCESS="0^"_$$EZBLD^DIALOG(89250002) G MAKEQ
57 I +$$CANEDIT^TIUPUTU(TIUDA)'>0 D G MAKEX
58 . D MAKEADD(.TIUADD,+TIUDA,TIUBUF) S SUCCESS=TIUADD
59 S SUCCESS=1
60 ;
61 D STUFREC(TIUDA,$G(DFN),,.TIU,$G(TIUPSC),$G(TIUDTP),$G(TIUPLDA))
62 ;
63 ; -- third, file the data in TIU Document record --
64 ;
65 K ^TIU(8925,+TIUDA,"TEMP"),TIUX(.01),TIUX(.02),TIUX(.03),TIUX(.05)
66 K TIUX(.13),TIUX(1205),TIUX(1211),TIUX(.001),TIUX(70201),TIUX(70202)
67 M ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
68 D FILE(.HAPPY,+TIUDA,.TIUX,TIUTYP)
69 D MERGTEXT^TIUEDI1(+TIUDA,.TIU)
70 S TIUPOST=$$POSTFILE^TIULC1(TITLE)
71 S TIUREC("#")=TIUDA
72 I TIUPOST]"" X TIUPOST
73MAKEX D ALERTDEL^TIUPEVNT(+TIUBUF)
74 D RESOLVE^TIUPEVNT($S($D(XQADATA):+$P(XQADATA,";",3),1:$G(ERRDA)),1)
75 D BUFPURGE^TIUPUTC(+TIUBUF)
76 K ^TIU(8925,+TIUDA,"TEMP") W "Done."
77 I +$G(TIUDA),+$D(^TIU(8925,+$G(TIUDA),0)) D
78 . N TIU D GETTIU^TIULD(.TIU,+TIUDA)
79 . D EN^VALM("TIU BROWSE FOR MRT")
80MAKEQ Q
81LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
82 N TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE I '$D(TIUPRM0) D SETPARM^TIULE
83 S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
84 S TIUI=0 F S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0 D
85 . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
86 . I TIULINE[TIUHSIG D
87 . . N TIUD1,TIUD4
88 . . S X=$$STRIP^TIULS($P(TIULINE,":",2)),Y=$$WHATYPE^TIUPUTU(X)
89 . . I +Y'>0 D MAIN^TIUPEVNT(TIUBUF,1,3,X) Q
90 . . S TIUD1=$G(^TIU(8925.1,+Y,1)),TIUD4=$G(^TIU(8925.1,+Y,4))
91 . . S TYPE=+Y
92 . . F D Q:TIULINE[TIUBGN!(+TIUI'>0)
93 . . . N TIUN,TIUCAP,TIUFLD,TIUREQ S TIUREQ=0
94 . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
95 . . . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0)) Q:TIULINE[TIUBGN
96 . . . S TIUCAP=$P(TIULINE,":") Q:TIUCAP']""
97 . . . S TIUN=$O(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
98 . . . Q:+TIUN'>0
99 . . . S TIUFLD=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
100 . . . Q:TIUFLD']""
101 . . . S TIUREQ=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
102 . . . S TIUARR(TIUFLD)=$$STRIP^TIULS($P(TIULINE,":",2,99))
103 . . . S:TIUFLD'=.001 TIUARR(TIUFLD)=$$TRNSFRM(+TYPE,TIUFLD,TIUARR(TIUFLD))
104 . . . I +TIUREQ,TIUARR(TIUFLD)="" S TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
105 . . . I $S(TIUFLD=.01:1,TIUFLD=.02:1,TIUFLD=.07:1,TIUFLD=1301:1,1:0) K TIUARR(TIUFLD)
106 . . I TIULINE[TIUBGN D
107 . . . N TIUJ S TIUJ=0
108 . . . F D Q:+TIUI'>0
109 . . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
110 . . . . S TIUJ=TIUJ+1
111 . . . . S TIUARR("TEXT",TIUJ,0)=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
112 Q
113STUFREC(DA,DFN,PARENT,TIU,TIUPSC,TIUDTP,TIUPLDA) ; Stuff fixed field data
114 N FDA,FDARR,IENS,FLAGS,TIUMSG,TIURDT,TIUPSCI,TIUDTPI
115 S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
116 I +$G(PARENT)'>0 D
117 . I '$G(TIUPLDA) D
118 . . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
119 . . S @FDARR@(.07)=$P(TIU("EDT"),U)
120 . . S @FDARR@(1401)=$P($G(TIU("AD#")),U),@FDARR@(1402)=$P($G(TIU("TS")),U)
121 . . S @FDARR@(1201)=$$NOW^TIULC
122 . . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
123 . . S @FDARR@(1212)=$S(+$P($G(TIU("INST")),U):$P($G(TIU("INST")),U),1:DUZ(2))
124 . . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
125 . S @FDARR@(.05)=$S(+$$REQVER(+$P($G(TIUDPRM(0)),U,3)):4,1:5)
126 . S @FDARR@(.08)=$P(TIU("LDT"),U)
127 I +$G(PARENT)>0 D
128 . S @FDARR@(.02)=+$P(^TIU(8925,+PARENT,0),U,2)
129 . S @FDARR@(.03)=$P(^TIU(8925,+PARENT,0),U,3)
130 . S @FDARR@(.05)=$S(+$$REQVER(+$P($G(TIUDPRM(0)),U,3)):4,1:5)
131 . S @FDARR@(.06)=PARENT
132 . S @FDARR@(.07)=$P($G(TIU("EDT")),U),@FDARR@(.08)=$P($G(TIU("LDT")),U)
133 . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
134 . S @FDARR@(1212)=$P($G(^TIU(8925,+PARENT,12)),U,12)
135 . S @FDARR@(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
136 . S @FDARR@(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
137 . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
138 . S @FDARR@(1201)=$$NOW^XLFDT
139 I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))
140 I +$G(TIU("LDT"))'>0 D
141 . S TIUDICDT=+$$IDATE^TIULC($G(TIUDICDT))
142 . I +TIUDICDT,($P(TIUDICDT,".",2)'>0) D
143 . . S TIUDICDT=$S($P(TIU("VSTR"),";",3)'="H":$P($G(TIU("EDT")),U),1:"")
144 . S TIURDT=$S(+$G(TIUDICDT)>0:+$G(TIUDICDT),1:+$$NOW^TIULC)
145 . S:+$G(TIUTYPE)=1 @FDARR@(.12)=1
146 . K TIUDICDT
147 I '$G(TIUPLDA) S @FDARR@(1301)=TIURDT
148 S @FDARR@(1303)="U"
149 I $G(TIUPSC)]"" D VAL^DIE(8925,DA,70201,,TIUPSC,.TIUPSCI)
150 S @FDARR@(70201)=$S($G(TIUPSCI):TIUPSCI,1:"")
151 I '$G(TIUPLDA)!($P($G(^TIU(8925,+$G(TIUPLDA),702)),U,2))="" D
152 . I $G(TIUDTP)]"" D VAL^DIE(8925,DA,70202,,TIUDTP,.TIUDTPI)
153 . S @FDARR@(70202)=$S($G(TIUDTPI):TIUDTPI,1:"")
154 D FILE^DIE(FLAGS,"FDA","TIUMSG")
155 Q
156REQVER(VPARM) ; Evaluate whether verification is required
157 Q $S(VPARM=1:1,VPARM=2:1,1:0)
158MAKEADD(TIUDADD,TIUDA,TIUBUF) ; Create an addendum record
159 N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUCAN,TIUFPRIV,TIU,TIUX S TIUFPRIV=1
160 N TIUDTTL,TIUPOST,TIUREC
161 S TIUDTTL=+$G(^TIU(8925,+TIUDA,0))
162 S TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
163 S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
164 D ^DIC
165 S TIUDADD=+Y
166 I +Y'>0 S TIUDADD=TIUDADD_"^Could not create addendum." Q
167 D GETTIU^TIULD(.TIU,TIUDA)
168 S TIU("DOCTYP")=TIUATYP_U_$$PNAME^TIULC1(TIUATYP)
169 D STUFREC(TIUDADD,DFN,+TIUDA,.TIU)
170 D LOADTIUX(.TIUX,TIUBUF)
171 K ^TIU(8925,+TIUDADD,"TEMP")
172 M ^TIU(8925,+TIUDADD,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
173 D FILE(.SUCCESS,+TIUDADD,.TIUX,TIUATYP)
174 D MERGTEXT^TIUEDI1(+TIUDADD,.TIU)
175 S TIUPOST=$$POSTFILE^TIULC1(TIUDTTL)
176 S TIUREC("#")=TIUDADD
177 I TIUPOST]"" X TIUPOST
178 K ^TIU(8925,+TIUDADD,"TEMP")
179 Q
180FILE(SUCCESS,TIUDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
181 N FDA,FDARR,IENS,FLAGS,TIUMSG
182 S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="KE"
183 M @FDARR=TIUX
184 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
185 I $D(TIUMSG)>9 D
186 . S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1))
187 . D MAIN^TIUPEVNT(TIUBUF,2,"",$P($G(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
188 E S SUCCESS=TIUDA
189 Q
190TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
191 N XFORM
192 S FLD=$O(^TIU(8925.1,+RTYPE,"HEAD","D",+FLD,0))
193 I +FLD'>0 G TRNSFRMX
194 S XFORM=$G(^TIU(8925.1,+RTYPE,"HEAD",+FLD,1))
195 I XFORM']"" G TRNSFRMX
196 X XFORM
197TRNSFRMX Q X
Note: See TracBrowser for help on using the repository browser.