source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURD.m@ 672

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1TIURD ; SLC/JER - Reassign actions ;4/25/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**4,58,61,100,109,173,184**;Jun 20, 1997
3 ;
4 ; Call to $$TIUREAS^MDAPI covered by IA# 3378
5 ; $$TIUREAS^MDAPI went out with MD 1.0, which was not mandated, so
6 ;checks are made for its existence before it is called.
7REASSIGN ; Reassign selected Documents
8 N TIUCHNG,TIULST,TIUI,RSTRCTD,TIUDAARY
9 I '$D(VALMY) D EN^VALM2(XQORNOD(0))
10 S TIUI=0
11 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
12 . N TIUDA,DFN,TIU,TIUDATA,TIUVIEW
13 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
14 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
15 . W !!,"Processing Item #",TIUI,"..."
16 . I $$CANTSURG(TIUDA) H 1 Q ;not permitted for surgery reports
17 . I RSTRCTD D Q
18 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message
19 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
20 . I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
21 . S TIUVIEW=$$CANDO^TIULP(TIUDA,"VIEW")
22 . I '+TIUVIEW D Q
23 . . W !!,$C(7),$C(7),$C(7),$P(TIUVIEW,U,2),!
24 . . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
25 . S TIUDAARY(TIUI)=TIUDA
26 . S TIUCHNG=0
27 . D EN^VALM("TIU REASSIGN")
28 . I +$G(TIUCHNG) D
29 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
30 ; -- Rebuild list: --
31 S TIUCHNG("RBLD")=1
32 D UPRBLD^TIURL(.TIUCHNG) K VALMY
33 S VALMBCK="R"
34 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"reassigned")
35 Q
36 ;
37REASSIG1 ; Single record reassign
38 N TIUAUTH,TIURSSG,TIUNAME,DA,DR,DIE,TIUTYPE,TIUEDIT,TIUADD,TIUPROMO,TIUY
39 N TIUD0,TIUD12,TIUD13,TIUD14,TIUODA,TIUOUT K ^TMP("TIURTRCT",$J)
40 D FULL^VALM1
41 I $$CANTSURG(TIUDA) H 3 Q ;not permitted for surgery reports
42 L +^TIU(8925,+TIUDA):1
43 E W !?5,$C(7),$C(7),$C(7),"Another user is editing this entry." S TIUY=$$READ^TIUU("EA","Press RETURN to continue...") Q
44 ; Authorized? NO: echo why not & quit
45 I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q
46 I +$$ISADDNDM^TIULC1(TIUDA) D I 1
47 . N TIUDAD
48 . S TIUDAD=+$P(^TIU(8925,TIUDA,0),U,6)
49 . I +$$DADORKID^TIUGBR(TIUDAD) D
50 . . S TIURSSG="0^You must first detach the ORIGINAL interdisciplinary entry."
51 E I $$DADORKID^TIUGBR(TIUDA) D I 1
52 . S TIURSSG="0^You must first detach interdisciplinary entries."
53 I '$D(TIURSSG) S TIURSSG=$$CANDO^TIULP(+TIUDA,"REASSIGN")
54 I +$G(TIURSSG)'>0 D G REASS1X
55 . W !!,$C(7),$C(7),$C(7),$P(TIURSSG,U,2),!
56 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
57 S TIUD0(0)=$G(^TIU(8925,+TIUDA,0)),TIUD12(0)=$G(^(12))
58 S TIUD13(0)=$G(^TIU(8925,+TIUDA,13)),TIUD14(0)=$G(^(14))
59 S TIUTYPE=$P(TIUD0(0),U)
60 S TIUNAME=$$PNAME^TIULC1(+TIUTYPE)
61 S TIUAUTH=$P(TIUD12(0),U,2)
62 W !,$C(7)
63 S TIUY=$$READ^TIUU("YO","Are you sure you want to REASSIGN this "_TIUNAME,"NO","^D REAS1^TIUDIRH")
64 I +TIUY'>0 S TIUOUT=1 G REASS1X
65 I +$P(TIUD0(0),U,5)>5 D G:+$G(TIUOUT) REASS1X
66 . W !!,$C(7),$C(7),"The status of this document is: ",$$UP^XLFSTR($$STATUS^TIULC(TIUDA))
67 . I +$$GETSIG^TIURD2'>0 S TIUOUT=1
68 . W !
69 ; Addendum? YES: Ask intended action is move, swap with original, or
70 ; replace original
71 S TIUADD=$$ISADDNDM^TIULC1(+TIUDA)
72 I +TIUADD D G REASS1X
73 . D REASSIGA
74 D REASSIGO^TIURD3
75REASS1X L -^TIU(8925,+TIUDA):1
76 I +$G(TIUOUT),+$G(TIUODA),+$G(TIUDA),$D(TIUD0(0)) D RECOVER^TIURD4(TIUODA,TIUDA,.TIUD0) S TIUDA=TIUODA
77 ; Remove additional signers who haven't signed from retracted original
78 I '+$G(TIUOUT),+$G(TIUODA) D
79 . I +$O(^TIU(8925.7,"B",+$G(TIUODA),0)) D DELSGNRS^TIURD4(TIUODA,1)
80 . D ALERTDEL^TIUALRT(TIUODA)
81 I '+$G(TIUOUT),+$G(TIUODA),+$$ISA^TIULX(+$G(TIUD0(0)),+$$CLASS^TIUCP) D
82 . N TIUCPY,TIUNVSTR
83 . Q:'$L($T(TIUREAS^MDAPI))
84 . S TIUNVSTR=$P(TIUD12(1),U,11)_";"_$P(TIUD0(1),U,7)
85 . S TIUNVSTR=TIUNVSTR_";"_$P(TIUD0(1),U,13)
86 . S TIUCPY=$$TIUREAS^MDAPI(+$P(TIUD0(0),U,2),+$P(TIUD14(0),U,5),+TIUODA,+$P(TIUD0(1),U,2),+$P($G(^TIU(8925,TIUDA,14)),U,5),TIUNVSTR,TIUDA)
87 D SEND^TIUALRT(TIUDA)
88 S VALMBCK=$S(+$G(TIUCHNG):"Q",1:"R") K ^TMP("TIURTRCT",$J)
89 Q
90 ;
91REASSIGO ; Reassign an original Document
92 G REASSIGO^TIURD3
93 ;
94REASSIGA ;Reassign an Addendum to an original DS
95 N TIUACT,TIUSET S TIUCHNG=0
96 W !,"Please choose the appropriate action for this Addendum:"
97 S TIUSET="M:move addendum to a different document"
98 S TIUSET=TIUSET_";P:promote addendum as document for another visit"
99 S TIUSET=TIUSET_";R:replace parent document with this addendum"
100 S TIUSET=TIUSET_";S:swap this addendum with its parent document"
101 S TIUACT=$$READ^TIUU("S^"_TIUSET,"Select Reassign Action","move")
102 I $P(TIUACT,U)="M" D MOVEADD^TIURD1(TIUDA) Q
103 I $P(TIUACT,U)="P" D PROMOTE^TIURD1(TIUDA) Q
104 I $P(TIUACT,U)="R" D REPLACE^TIURD1(TIUDA) Q
105 I $P(TIUACT,U)="S" D SWAPADD^TIURD1(TIUDA)
106 Q
107 ;
108CLAPPLNK ; Re-link selected Documents to different Client Records
109 N TIUCHNG,TIULST,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,Y,DIROUT,TIUPOP
110 N TIUDAARY
111 I '$D(VALMY) D EN^VALM2(XQORNOD(0))
112 S TIUI=0 D FULL^VALM1
113 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
114 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
115 . S TIUDA=+$P(TIUDATA,U,2),TIUDAARY(TIUI)=TIUDA
116 . S TIUCHNG=0
117 . W !!,"Processing Item #",TIUI,"..."
118 . D CLAPPLN1(TIUDA)
119 . I +$G(TIUCHNG)=1 D
120 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":", ",1:"")_TIUI
121 S TIUCHNG("REFRESH")=1
122 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
123 S VALMBCK="R"
124 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"re-linked")
125 Q
126 ;
127CLAPPLN1(TIUDA) ; Re-link a single record to the client application
128 N TIUREASX,CANLNK,ACTION,ISPRF,OLDLINK
129 I '$D(^TIU(8925,TIUDA,0)) D Q
130 . W !!,$C(7),"Document no longer exists.",!
131 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
132 I $$CANTSURG(TIUDA) H 3 Q ;not permitted for surgery reports
133 S ISPRF=$$ISPRFDOC^TIUPRF(TIUDA) ;Patient Record Flag
134 I ISPRF S ACTION="LINK TO FLAG",OLDLINK=$$GETLINK^DGPFAPI1(TIUDA)
135 I 'ISPRF S ACTION="LINK WITH REQUEST",OLDLINK=$P($G(^TIU(8925,TIUDA,14)),U,5)
136 I +$$ISADDNDM^TIULC1(TIUDA) D Q
137 . W !!,$C(7),"Links for ADDENDA can't be independently changed.",!
138 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
139 S TIUREASX=$$REASSIGN^TIULC1(+$G(^TIU(8925,TIUDA,0)))
140 I TIUREASX']"" D Q
141 . W !!,$C(7),"No PACKAGE REASSIGNMENT ACTION Defined.",!
142 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
143 I $$DADORKID^TIUGBR(TIUDA) D Q ;**100**
144 . S CANLNK="0^You must first detach interdisciplinary entries"
145 . W !!,$C(7),$C(7),"You must first detach interdisciplinary entries",!
146 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
147 S CANLNK=$$CANDO^TIULP(+TIUDA,ACTION)
148 I +CANLNK'>0 D Q
149 . W !!,$C(7),$C(7),$P(CANLNK,U,2),!
150 . I $$READ^TIUU("EA","Press RETURN to continue...") W ""
151 X TIUREASX
152 I ISPRF,OLDLINK'=$$GETLINK^DGPFAPI1(TIUDA) S TIUCHNG=1
153 I 'ISPRF,$P($G(^TIU(8925,TIUDA,14)),U,5)'=OLDLINK S TIUCHNG=1
154 Q
155 ;
156CANTSURG(TIUDA) ; If TIUDA is surg docmt, write can't do this action and
157 ;return 1 for can't do it P184
158 N TIUY,CANT S CANT=0
159 D ISSURG^TIUSROI(.TIUY,+$G(^TIU(8925,TIUDA,0)))
160 I '+TIUY Q CANT
161 S CANT=1 W !,"This action is no longer permitted for SURGICAL REPORTS"
162 Q CANT
Note: See TracBrowser for help on using the repository browser.