source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURD2.m@ 1150

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1TIURD2 ; SLC/JER - Reassignment following signature ;11/01/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**61,100,109,113,112**;Jun 20, 1997
3RETRACT(TIUDA,TIUDAD,COPYSTAT,NEWDAD,SKIPADD) ; Retract document
4 N TIUOD0,TIUOD12,TIUOD13,TIUOD14,TIUOD15,TIUOD16,TIUOD17,TIUI,TIUPAT
5 N TIUDPRM,TIUCOPY,TIUVSUPP,DUOUT,DIROUT,DTOUT,DA,DR,DFN,TIU,TIULMETH
6 N TIUTYP,TIUVMETH,TIUPATNM,TIUNREC,DFN,TIUNDAD,TIUTNM,ONRTRCT
7 S TIUOD0=$G(^TIU(8925,+TIUDA,0)),TIUOD12=$G(^(12)),TIUOD13=$G(^(13))
8 S TIUOD14=$G(^TIU(8925,+TIUDA,14)),TIUOD15=$G(^(15)),TIUOD16=$G(^(16))
9 S TIUOD17=$G(^TIU(8925,+TIUDA,17))
10 S TIUTYP=+TIUOD0,^TMP("TIURTRCT",$J,TIUDA,0)=TIUOD0,COPYSTAT=$G(COPYSTAT,5)
11 I $S(+COPYSTAT=14:1,+COPYSTAT=15:1,1:0) D STATUS(TIUDA) G RTADD
12 I +$P(TIUOD0,U,5)'>5 D:+$G(NEWDAD) LINKADD(TIUDA,NEWDAD) G RETRAX
13 I +COPYSTAT'<7,+$G(NEWDAD) D LINKADD(TIUDA,NEWDAD) G RETRAX
14 D FULL^VALM1
15 ; --- Initialize document parameters ---
16 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,TIUDA)
17 S TIUTNM=$$PNAME^TIULC1(+TIUTYP)
18 ; --- Identify the patient ---
19 S DFN=+$P(TIUOD0,U,2)
20 I +DFN'>0 D G RETRAX
21 . W !,$C(7),"No patient selected..."
22 . I $$READ^TIUU("EA","Press RETURN to continue...") W !
23 S TIUPATNM=$$PTNAME^TIULC1(DFN)
24 ; --- Get visit info ---
25 D GETTIU^TIULD(.TIU,TIUDA)
26 I '$D(TIU("VSTR")) W !,$C(7),"Patient & Visit required." H 2 G RETRAX
27 I $D(TIU) D
28 . N TIUNEW,TIUITEM,DA,DR,DIE
29 . S DA=$$GETREC^TIUSRVP(DFN,.TIU,TIUTYP,.TIUNEW) Q:+DA'>0
30 . I '+$G(TIUNEW) D Q
31 . . W !!,$C(7),"A ",TIUTNM," already exists for this visit."
32 . . W !,"You may not use the reassign function to overwrite an existing ",!,$$UPPER^TIULS($$STATUS^TIULC(DA))," ",TIUTNM,".",!
33 . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
34 . D REMVSIT(TIUDA,TIUOD0)
35 . D COPY0(DA,TIUOD0,.TIU,$G(TIUDAD),COPYSTAT),COPY12(DA,TIUOD12,.TIU)
36 . D COPY13(DA,TIUOD13,.TIU,COPYSTAT),COPY14(DA,TIUOD14,.TIU)
37 . D COPYSGNR(TIUDA,DA,COPYSTAT)
38 . I COPYSTAT>5 D COPY15(DA,TIUOD15)
39 . I COPYSTAT>6,$L(TIUOD16) S ^TIU(8925,+DA,16)=TIUOD16
40 . I +$$REQCOSIG^TIULP(+TIUTYP,TIUDA,+$P(TIUOD12,U,4)),(COPYSTAT<6) D
41 . . N DIE,DR S DIE=8925
42 . . S DR="1506////1" D ^DIE
43 . D COPY17^TIURC1(DA,TIUOD17),COPYTEXT^TIURC1(TIUDA,DA)
44 . I $D(^TIU(8925,DA,"TEMP")) D MERGTEXT^TIUEDI1(DA,.TIU) K ^TIU(8925,+DA,"TEMP")
45 . S DR=".05///"_$$UPPER^TIULS($$STATUS^TIULC(DA))_";.1////^S X=$$LINECNT^TIULC(DA);1406////"_TIUDA
46 . S DIE=8925 D ^DIE
47 . D AUDIT^TIUEDI1(DA,0,$$CHKSUM^TIULC("^TIU(8925,"_+DA_",""TEXT"")"))
48 . S ^TMP("TIURTRCT",$J,"NEW",DA)=""
49 . S:'+$G(TIUDAD) TIUNDAD=DA
50 . S TIUNREC=$G(TIUNREC)_$S(+$G(TIUNREC):",",1:"")_DA
51 . D STATUS(TIUDA)
52 S ONRTRCT=$$ONRTRCT^TIULC1(+$G(^TIU(8925,TIUDA,0)))
53 I ONRTRCT]"" X ONRTRCT
54 ; If SKIPADD is TRUE, bypass retraction of addenda...
55 I +$G(SKIPADD) G RETRAX
56RTADD ; Retract all addenda
57 N TIUDADD S TIUDADD=0
58 F S TIUDADD=$O(^TIU(8925,"DAD",TIUDA,TIUDADD)) Q:+TIUDADD'>0 D
59 . I '$$ISADDNDM^TIULC1(TIUDADD) Q
60 . D ADDENDEL^TIUALRT(TIUDADD)
61 . S TIUNREC=$G(TIUNREC)_$S(+$G(TIUNREC):",",1:"")_$$RETRACT(TIUDADD,TIUDA,$G(COPYSTAT),$G(TIUNDAD))
62RETRAX Q +$G(TIUNREC)
63REMVSIT(DA,TIUOD0) ; Remove VISIT from Retracted Doc
64 N DIE,DR,SVCAT,TIUPOP S TIUPOP=0
65 S SVCAT=$P(TIUOD0,U,13)
66 I +$$ISADDNDM^TIULC1(DA) D Q:+TIUPOP
67 . I +$P($G(^TIU(8925,+$P(TIUOD0,U,6),0)),U,3)>0 S TIUPOP=1 Q
68 . S:SVCAT="" SVCAT=$P($G(^TIU(8925,+$P(TIUOD0,U,6),0)),U,13)
69 I SVCAT="H" Q
70 W !,"Removing RETRACTED ",TIUTNM," from original Visit..."
71 S DIE=8925,DR=".03///@" D ^DIE
72 Q
73LINKADD(DA,TIUDAD) ; Link addendum (DA) to TIUDAD
74 N DR,DIE
75 S DIE=8925,DR=".06////^S X=TIUDAD" D ^DIE
76 Q
77COPY0(DA,TIUD0,TIU,TIUDAD,STATUS) ; Copy root node
78 N DR,DIE S DIE=8925,STATUS=$G(STATUS,5)
79 S DR=".02////"_DFN_";.03////"_$P(TIUD0,U,3)_";.04////"_$P(TIUD0,U,4)_";.05////"_STATUS_";.06////"_$P(TIUD0,U,6)_";.07////"_$P(TIUD0,U,7)_";.08////"_$P(TIUD0,U,8)_";.09////"_$P(TIUD0,U,9)_";.12////"_$P(TIUD0,U,12)_";.13////"_$P(TIUD0,U,13)
80 I $P($G(TIUDPRM(0)),U,16),'$P($G(^TIU(8925,+DA,0)),U,11),$$WORKOK^TIUPXAP1(+DA) S DR=DR_";.11////1" ;set flag to collect workload
81 D ^DIE
82 Q
83COPY12(DA,TIUD12,TIU) ; Copy 12-node
84 N DR,DIE S DIE=8925
85 S DR="1201////"_+$$NOW^XLFDT_";1202////"_+$P(TIUD12,U,2)_";1203////"_$P(TIUD12,U,3)_";1204////"_$P(TIUD12,U,4)_";1205////"_$P(TIUD12,U,5)
86 S DR=DR_";1206////"_$P(TIUD12,U,6)_";1207////"_$P(TIUD12,U,7)_";1208////"_$P(TIUD12,U,8)_";1209////"_$P(TIUD12,U,9)
87 S DR=DR_";1210////"_$P(TIUD12,U,10)_";1211////"_$P(TIUD12,U,11)_";1212////"_$P(TIUD12,U,12)
88 D ^DIE
89 Q
90COPY13(DA,TIUD13,TIU,STATUS) ; Copy 13-node
91 N DR,DIE,TIUDT,TIURDT S DIE=8925,TIUDT=$P(TIUD13,U)
92 S TIURDT=$S(+$$ISDS^TIULX(+$G(^TIU(8925,DA,0))):+$$REFDATE^TIULC1(.TIU,TIUDT),1:TIUDT)
93 S:'TIURDT TIURDT=TIUDT
94 S DR="1301////"_TIURDT_";1302////"_$P(TIUD13,U,2)_";1303////O"
95 S DR=DR_";1304////"_$S(STATUS<4:"@",1:TIUDT)
96 S DR=DR_";1305////"_$S(STATUS<5:"@",1:TIUDT)
97 S DR=DR_";1306////"_$S(STATUS<5:"@",+$P(TIUD13,U,6):$P(TIUD13,U,6),1:DUZ)
98 S DR=DR_";1307////"_$P(TIUD13,U,7)
99 D ^DIE
100 Q
101COPY14(DA,TIUD14,TIU) ; Copy 14-node
102 N DR,DIE S DIE=8925
103 S DR="1401////"_$P(TIUD14,U)_";1402////"_$P(TIUD14,U,2)
104 S DR=DR_";1403////"_$P(TIUD14,U,3)_";1404////"_$P(TIUD14,U,4)
105 S DR=DR_";1405////^S X=$P(TIUD14,U,5)"
106 D ^DIE
107 Q
108COPYSGNR(TIUDA,TIUCDA,COPYSTAT) ; Copy Add'nal Signers
109 N TIUSDA S TIUSDA=0
110 F S TIUSDA=$O(^TIU(8925.7,"B",TIUDA,TIUSDA)) Q:+TIUSDA'>0 D
111 . N TIUSD0,DA,DR,DIC,DIE,DLAYGO
112 . S TIUSD0=$G(^TIU(8925.7,TIUSDA,0))
113 . S (DIC,DLAYGO)=8925.7,DIC(0)="LX",X=""""_"`"_TIUCDA_"""" D ^DIC Q:+Y'>0
114 . S DA=+Y,DIE=DIC,DR=".02////^S X=0;.03////^S X=$P(TIUSD0,U,3)"
115 . I COPYSTAT>5 D
116 . . S DR=DR_";.04////^S X=$P(TIUSD0,U,4);.05////^S X=$P(TIUSD0,U,5)"
117 . . S DR=DR_";.06////^S X=$P(TIUSD0,U,6);.07////^S X=$P(TIUSD0,U,7)"
118 . . S DR=DR_";.08////^S X=$P(TIUSD0,U,8)"
119 . D ^DIE
120 Q
121COPY15(DA,TIUD15) ; Copy 15-node
122 N DR,DIE S DIE=8925
123 S DR="1501////"_$P(TIUD15,U)_";1502////"_$P(TIUD15,U,2)_";1503////^S X=$P(TIUD15,U,3);1504////^S X=$P(TIUD15,U,4)"
124 S DR=DR_";1505////"_$P(TIUD15,U,5)_";1506////"_$P(TIUD15,U,6)_";1507////"_$P(TIUD15,U,7)_";1508////"_$P(TIUD15,U,8)
125 S DR=DR_";1509////^S X=$P(TIUD15,U,9);1510////^S X=$P(TIUD15,U,10);1511////"_$P(TIUD15,U,11)_";1512////"_$P(TIUD15,U,12)
126 S DR=DR_";1513////"_$P(TIUD15,U,13)
127 D ^DIE
128 Q
129STATUS(DA) ; Set original's status to "RETRACTED"
130 N DIE,DR,DIC
131 S DIE=8925,DR=".05///RETRACTED" D ^DIE
132 D ALERTDEL^TIUALRT(DA),DELIRT^TIUDIRT(DA)
133 Q
134ATTACH(TIUDA,TIUDADD) ; Attach TIUDADD as addendum to TIUDA
135 N DR,DIE,DA,TIUD0,TIUD12,TIUD14,TIUDADA
136 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
137 S DIE="^TIU(8925,",DA=TIUDADD
138 S DR=".01////81;.02////^S X=$P(TIUD0,U,2);.03////^S X=$P(TIUD0,U,3);.04////^S X=$$DOCCLASS^TIULC1(81)"
139 S DR=DR_";.06////^S X=TIUDA;.07////^S X=$P(TIUD0,U,7);.08////^S X=$P(TIUD0,U,8)"
140 D ^DIE
141 S DR="1205////^S X=$P(TIUD12,U,5);1211////^S X=$P(TIUD12,U,11);1212////^S X=$P(TIUD12,U,12)"
142 D ^DIE
143 S DR="1301////^S X="_$$REFDTA(TIUDA,TIUDADD,TIUD0)
144 S DR=DR_";1401////^S X=$P(TIUD14,U);1402////^S X=$P(TIUD14,U,2)"
145 D ^DIE
146 ; If TIUDADD has addenda, re-attach them as addenda to TIUDA
147 S TIUDADA=0
148 F S TIUDADA=$O(^TIU(8925,"DAD",TIUDADD,TIUDADA)) Q:+TIUDADA'>0 D
149 . Q:'+$$ISADDNDM^TIULC1(TIUDADA)
150 . D ATTACH(TIUDA,TIUDADA),SEND^TIUALRT(TIUDADA) W "."
151 W !!,"Done." S TIUCHNG=1
152 Q
153REFDTO(TIUDA,TIU) ; Compute reference date
154 N TIUY,TIUD12,TIUD13
155 S TIUD12=$G(^TIU(8925,+TIUDA,12)),TIUD13=$G(^(13))
156 S TIUY=+TIU("LDT")
157 I TIUY>0 G REFDTOX
158 I +$P(TIUD13,U,7) S TIUY=+$P(TIUD13,U,7) G REFDTOX
159 S TIUY=+$P(TIUD12,U)
160REFDTOX Q TIUY
161REFDTA(TIUDA,TIUDADD,TIUD0) ; Compute reference date for addenda
162 N TIUY,TIUDAD12,TIUDAD13
163 S TIUDAD12=$G(^TIU(8925,+TIUDADD,12)),TIUDAD13=$G(^(13))
164 S TIUY=+TIUDAD13
165 I +$$ISDS^TIULX(+TIUD0)'>0 G REFDTAX
166 I +$P(TIUDAD13,U) S TIUY=+$P(TIUDAD13,U) G REFDTAX
167 I +$P(TIUDAD13,U,7) S TIUY=+$P(TIUDAD13,U,7) G REFDTAX
168 S TIUY=+$P(TIUDAD12,U)
169REFDTAX Q TIUY
170UPDTADD(TIUDA) ; Addenda for reassigned original are updated
171 I $$HASADDEN^TIULC1(+TIUDA) D
172 . N DA
173 . W !!,$C(7),"Addenda for this Document will now be updated..."
174 . S DA=0 F S DA=$O(^TIU(8925,"DAD",+TIUDA,DA)) Q:+DA'>0 D
175 . . N DR,DIE,TIUD0,TIUD12,TIUD14
176 . . I '+$$ISADDNDM^TIULC1(+DA) Q
177 . . S TIUD0(0)=$G(^TIU(8925,+DA,0)),TIUD12(0)=$G(^(12))
178 . . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
179 . . S DR=".02////"_$P(TIUD0,U,2)_";.03////"_$S($P(TIUD0,U,3)="":"@",1:$P(TIUD0,U,3))_";.04////"_$P(TIUD0,U,4)_";.07////"_$P(TIUD0,U,7)_";.08////"_$S(+$P(TIUD0,U,8):$P(TIUD0,U,8),1:"@")_";.13////"_$P(TIUD0,U,13)
180 . . S DR=DR_";1401////"_$P(TIUD14,U)_";1402////"_$P(TIUD14,U,2)
181 . . S DIE=8925 D ^DIE
182 . . S DR="1205////"_$P(TIUD12,U,5)_";1211////"_$P(TIUD12,U,11)_";1212////"_$P(TIUD12,U,12)
183 . . D ^DIE
184 . . S DR="1301////^S X="_$$REFDTA^TIURD2(TIUDA,DA,TIUD0)
185 . . D ^DIE W "."
186 . . ; Remove and resend alerts
187 . . D SEND^TIUALRT(DA)
188 . . S TIUD0(1)=$G(^TIU(8925,+DA,0)),TIUD12(1)=$G(^(12))
189 . . D AUDREASS^TIURB1(DA,.TIUD0,.TIUD12)
190 . . ; If the addendum was retracted, post its audit trail info as well
191 . . I +$P($G(^TIU(8925,DA,14)),U,6) D
192 . . . D AUDREASS^TIURB1(+$P(^TIU(8925,DA,14),U,6),.TIUD0,.TIUD12)
193 Q
194VLOC(LOCDA) ; Resolve location pointer
195 Q $P($G(^SC(LOCDA,0)),U)
196GETSIG() ; Challenge user for Electronic Signature, when appropriate
197 N X,X1,X2,TIUY S TIUY=0
198 D SIG^XUSESIG
199 I X1']"" D G GETSIGX
200 . W !!,$C(7),$C(7),"You MUST Enter your CORRECT Electronic Signature to Complete this Task...",!
201 . W:$$READ^TIUU("EA","Press RETURN to continue...") ""
202 S TIUY=1
203GETSIGX Q +$G(TIUY)
Note: See TracBrowser for help on using the repository browser.