source: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUCNSLT.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1TIUCNSLT ; SLC/JER - Patient movement look-up ;1/7/03 [6/11/04 8:34am]
2 ;;1.0;TEXT INTEGRATION UTILITIES;**4,31,109,131,142,144,184**;Jun 20, 1997
3 ; External References
4 ; DBIA 2324 $$ISA^USRLM
5 ; DBIA 3473 SEND^GMRCTIU
6 ; DBIA 3473 GET^GMRCTIU
7 ; DBIA 3575 ROLLBACK^GMRCTIU1
8GETCNSLT(DFN,TIUCPF,TIUDA,TIUOVR) ; Match consult result
9 ;to an active request
10 ; Call with:
11 ; [DFN] - patient file entry number
12 ; [TIUCPF] - flag to indicate clinical procedure (Optional)
13 ; [TIUDA] - TIU document IEN of consult result (Optional).
14 ; If TIUDA has a request, return it w/o asking user.
15 ; [TIUOVR] - flag to override restrictions on selectable requests
16 ; (Optional). If not received or received as null, reset
17 ; according to whether user is in MIS.
18 ; Note - If DA is defined and TIU document DA has a request,
19 ; code returns its request instead of asking user.
20 ; Returns: TIUY - Variable pointer to consult request
21 ; = -1 if pat has no requests
22 ; = 0 if no request is selected
23AGN ; Loop for handling repeated attempts
24 N TIUI,TIUII,TIUER,TIUOK,TIUOUT,TIUX,TIUY,TIUCNT,X
25 I +DFN'>0 S TIUOUT=1 Q 0
26 I +$G(GMRCO) S TIUX=+$G(GMRCO) G GETX
27 ; -- If TIUDA is not defined, try DA for backward
28 ; compatibility:
29 S TIUDA=$S('$D(TIUDA):+$G(DA),1:+TIUDA)
30 ; -- Ignore TIUDA if it doesn't match pt DFN:
31 I $P($G(^TIU(8925,TIUDA,0)),U,2)'=+DFN S TIUDA=0
32 ; -- If TIUDA or its parent already has a request,
33 ; return it & don't ask user:
34 I +$P($G(^TIU(8925,TIUDA,14)),U,5) S TIUX=+$P($G(^(14)),U,5) G GETX
35 I +$$ISADDNDM^TIULC1(TIUDA) S TIUX=+$$DADCR(TIUDA) G:+TIUX>0 GETX
36 ; -- If override flag is null or is not defined, set it according to
37 ; user's membership in MIS:
38 S TIUOVR=$S($G(TIUOVR)="":+$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION"),1:+TIUOVR)
39 D SEND^GMRCTIU(DFN,$G(TIUOVR),$G(TIUCPF))
40 ; If no consult requests for patient, then quit with -1
41 I $S($G(^TMP("GMRCR",$J,"TIU",1,0))["No Consults":1,'$D(^TMP("GMRCR",$J,"TIU")):1,1:0) D Q -1
42 . W !!,$C(7),"No CONSULT REQUESTS to Result for ",$P($G(^DPT(DFN,0)),U),".",!
43 S (TIUCNT,TIUI)=0 F S TIUI=+$O(^TMP("GMRCR",$J,"TIU",TIUI)) Q:+TIUI'>0 D
44 . S TIUCNT=+$G(TIUCNT)+1
45 W !,"You must link this Result to a Consult Request...",!
46 D I +TIUER Q:+$G(TIUOUT) 0 G AGN
47 . W !,"The following CONSULT REQUEST"
48 . W $S(+TIUCNT>1:"(S) are",1:" is")," available:"
49 . S (TIUER,TIUOK,TIUI)=0
50 . F S TIUI=$O(^TMP("GMRCR",$J,"TIU",TIUI)) Q:+TIUI'>0!+TIUER!+TIUOK D
51 . . S TIUII=TIUI,TIUX=$G(^TMP("GMRCR",$J,"TIU",TIUI,0))
52 . . D WRITE I '(TIUI#5) D BREAK
53 . Q:$D(TIUOUT)
54 . I +TIUER S TIUOUT=1 Q
55 . I TIUII#5 D BREAK Q:$D(TIUOUT)
56 . I +TIUER S TIUOUT=1 Q
57 . S TIUX=$O(^TMP("GMRCR",$J,"TIU","B",+TIUOK,0))
58 . ;,^DISV(DUZ,"^GMR(123,",DFN)=+TIUX
59 . W " ",+TIUX
60GETX S TIUY=+TIUX_";GMR(123,"
61 Q $G(TIUY)
62BREAK ; Handle prompting
63 W !,"CHOOSE 1-",TIUII W:$D(^TMP("GMRCR",$J,"TIU",TIUII+1,0)) !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT" W ": " R X:DTIME
64 I $S('$T!(X["^"):1,X=""&'$D(^TMP("GMRCR",$J,"TIU",TIUII+1)):1,1:0) S TIUER=1 Q
65 I X="" Q
66 I X'=+X!'$D(^TMP("GMRCR",$J,"TIU",+X)) W !!,$C(7),"INVALID RESPONSE",! G BREAK
67 S TIUOK=X
68 Q
69DADCR(DA) ; Get the Consult request associated with the parent record
70 N TIUDADA,TIUY S TIUDADA=$P($G(^TIU(8925,+DA,0)),U,6)
71 S TIUY=$P($G(^TIU(8925,TIUDADA,14)),U,5)
72 Q TIUY
73WRITE W !,TIUX
74 Q
75POST(TIUDA,STATUS) ; Post status updates to Consult Tracking
76 N GMRCDA,DA,TIUAUTH S GMRCDA=+$P($G(^TIU(8925,+TIUDA,14)),U,5)
77 I +GMRCDA'>0 Q
78 S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2)
79 D GET^GMRCTIU(GMRCDA,TIUDA,STATUS,TIUAUTH)
80 Q
81ISCNSLT(TIUY,TITLE) ; Boolean RPC to evaluate whether TITLE is a CONSULT
82 N TIUCLASS
83 S TIUCLASS=+$$CLASS
84 I +TIUCLASS'>0 S TIUY=0 Q
85 S TIUY=+$$ISA^TIULX(TITLE,TIUCLASS)
86 Q
87CHANGE(TIUDA,TIUCPF,TIUNOCS) ; Re-direct the TIU Document to a different CT Record
88 ; Passes back TIUNOCS=-1 if pt has no requests or none is selected
89 N DA,DFN,DIE,DR,GMRCO,GMRCSTAT,GMRCVP,TIUD0,TIUD14
90 S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD14=$G(^(14))
91 S DFN=$P(TIUD0,U,2),GMRCO=$P(TIUD14,U,5)
92 Q:+DFN'>0
93 I GMRCO'="" D ROLLBACK(TIUDA) K GMRCO ;P144
94CHAGN S DA=TIUDA,TIUNOCS=0
95 W ! S GMRCVP=+$$GETCNSLT(DFN,$G(TIUCPF))_";GMR(123,"
96 I +GMRCVP=0 W !!,$C(7),"You must select a Consult Request...Restoring record."
97 I +GMRCVP'>0 D RETREAT(TIUDA,TIUD14) S TIUPOP=1,TIUNOCS=-1 Q ;P144
98 S DIE=8925,DA=TIUDA,DR="1405////^S X=GMRCVP" D ^DIE
99 D UPDTADD(TIUDA,GMRCVP)
100 S GMRCO=+GMRCVP,GMRCSTAT=$S($P(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
101 D POST(TIUDA,GMRCSTAT)
102 Q
103RETREAT(DA,TIUD14) ; If Pt has no requests, retreat gracefully
104 N DIE,DR,GMRCO,GMRCSTAT
105 S DIE=8925,DR="1405////^S X=$P(TIUD14,U,5)" D ^DIE
106 S GMRCO=+$P(TIUD14,U,5)
107 S GMRCSTAT=$S($P(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
108 D POST(TIUDA,GMRCSTAT)
109 Q
110UPDTADD(TIUDA,TIUCVP) ; Addenda for re-linked original are updated
111 ;Update TIU(8925 ONLY. GMR(123 doesn't track individual adda
112 I $$HASADDEN^TIULC1(+TIUDA) D
113 . N DA
114 . S DA=0 F S DA=$O(^TIU(8925,"DAD",+TIUDA,DA)) Q:+DA'>0 D
115 . . N DR,DIE
116 . . I '+$$ISADDNDM^TIULC1(+DA) Q
117 . . S DR="1405////^S X=TIUCVP"
118 . . S DIE=8925 D ^DIE
119 . . D ^DIE
120 Q
121ROLLBACK(TIUDA) ; Roll back CT Record when TIU changes require it
122 N GMRCDA,DIE,DR,DA S GMRCDA=+$P($G(^TIU(8925,TIUDA,14)),U,5)
123 I +GMRCDA>0 D ROLLBACK^GMRCTIU1(GMRCDA,TIUDA) ;P144
124 S DIE="^TIU(8925,",DA=TIUDA,DR="1405///@" D ^DIE
125 Q
126CLASS() ; What is the TIU Class (or Document Class) for CONSULTS
127 N GMRCY
128 S GMRCY=+$O(^TIU(8925.1,"B","CONSULTS",0))
129 I +GMRCY>0,$S($P($G(^TIU(8925.1,+GMRCY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S GMRCY=0
130 Q GMRCY
131REMCNSLT(TIUDA) ;Remove link to consult if there is one ;*171
132 ;TIUDA is a TIU record number
133 N TIUTYPE,TIUDELX
134 S TIUTYPE=+$G(^TIU(8925,+TIUDA,0))
135 S TIUDELX=$$DELETE^TIULC1(TIUTYPE)
136 I TIUDELX]"" X TIUDELX
137 Q
138CONSCT(TIUDA,TIUOTTL,TIUNTTL) ;
139 ;non cons title to cons title - already handled
140 ;cons title to cons title - already handled
141 ;cons title to non cons title
142 N TIUCLASS
143 S TIUCLASS=$$CLASS^TIUCNSLT()
144 I +$$ISA^TIULX(TIUOTTL,TIUCLASS),'+$$ISA^TIULX(TIUNTTL,TIUCLASS) D
145 . W !,"The Title you selected is not a Consults Title."
146 . W !," The note is currently linked to a Consults Request,"
147 . W !," but will be disassociated when the title is changed"
148 . W !," to a non Consults Title.",!
149 . W !,"Do you want to continue with this Change Title Action?"
150 . I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1
151 . I $G(TIUQUIT)=1 W !,"Title not changed." Q
152 . D REMCNSLT(+TIUDA)
153 Q
154CNSCTGUI(TIUDA,TIUOTTL,TIUNTTL) ;
155 ;non cons title to cons title - already handled
156 ;cons title to cons title - already handled
157 ;cons title to non cons title
158 N TIUCLASS
159 S TIUCLASS=$$CLASS^TIUCNSLT()
160 I +$$ISA^TIULX(TIUOTTL,TIUCLASS),'+$$ISA^TIULX(TIUNTTL,TIUCLASS) D
161 . ;Assume the confirmation has been taken care of already
162 . D REMCNSLT(+TIUDA)
163 Q
Note: See TracBrowser for help on using the repository browser.