source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRF1.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.0 KB
Line 
1TIUPRF1 ; SLC/JMH - Modules for Patient Record Flags ; 1/9/06
2 ;;1.0;TEXT INTEGRATION UTILITIES;**184**;Jun 20, 1997
3 ;
4SELECT(TIUTTL,DFN,TIUDA) ; Select flag action for VISTA
5 ;Requires:
6 ; TIUTTL - 8925.1 IEN
7 ; DFN - Patient IEN
8 ;Optional:
9 ; TIUDA - Note IEN: If user picks the link that TIUDA is already
10 ; linked to, question the pick
11 ;Returns:
12 ; PRFAssignmentIEN^PRFAssignmentHistoryIEN or
13 ; 0^msg ;
14 ; LINEOK = Line of action selected by user
15 ; TIUAGN = 2 if note TIUDA is already linked to selected action
16 ; TIUAGN = 1 if Assignment History IEN selected by user already has
17 ; another note linked to it
18 N TIUDG,TIUER,TIURET,TIUAGN,LKBLARR
19 N FLAGNM,HASFLAG,AVAIL,LINKBL,UNLINKBL,TIUJ
20 S TIUAGN=0,HASFLAG=1
21 S FLAGNM=$$FNDFLAG^TIUPRFL(TIUTTL)
22 I 'FLAGNM S HASFLAG=0
23 S FLAGNM=$S(HASFLAG:$P(FLAGNM,U,2),1:"UNKNOWN")
24 S TIUDG=$$GETHTIU^DGPFAPI1(DFN,+$G(TIUTTL),"^TMP(""TIUPRFH"",$J)")
25 F D Q:'TIUAGN
26 . I 'TIUAGN W !!,"This Note must be linked to Patient Record Flag:",!," ",FLAGNM,!," Checking for available Flag Actions...",!
27 . I 'TIUDG S TIURET="0^"_$P(TIUDG,U,2) D Q
28 . . W !,$P(TIUDG,U,2),"!",!
29 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
30 . S AVAIL=$$AVAILACT^TIUPRFL("^TMP(""TIUPRFH"",$J)",.LINKBL,.UNLINKBL)
31 . I 'AVAIL D Q
32 . . S TIURET="0^All linked"
33 . . W !,"All linkable Flag actions for this Patient and Title are already linked!",!
34 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
35 . I TIUAGN=1 W " ?? This action already has a note linked to it.",! S TIUAGN=0
36 . I TIUAGN=2 W " ?? The note is already linked to this action.",! S TIUAGN=0
37 . ; -- If flag assgnmt array has unlinkable actions, omit them and set
38 . ; a new arr starting subscript at 1:
39 . I UNLINKBL D S LKBLARR="^TMP(""TIUPRFLKBL"",$J)"
40 . . F TIUJ=1:1:LINKBL M ^TMP("TIUPRFLKBL",$J,"HISTORY",TIUJ)=^TMP("TIUPRFH",$J,"HISTORY",TIUJ+UNLINKBL)
41 . I 'UNLINKBL S LKBLARR="^TMP(""TIUPRFH"",$J)"
42 . ; Display all linkable actions and prompt user to select one:
43 . W !,"Please select a Patient Record Flag Assignment Action: "
44 . W !,?7,"Date",?27,"Action",?52,"Note"
45 . S (TIUER,LINEOK)=0
46 . ; -- Display the flag actions and ask for choice in BREAK
47 . F LINENO=1:1:LINKBL D Q:+TIUER!+LINEOK
48 . . D WRITE(LINENO) I '(LINENO#5) D BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
49 . I LINENO#5 D BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
50 . ; -- Check if user ^ out
51 . I TIUER S TIURET="0^USER EXITED" Q
52 . S TIURET=+^TMP("TIUPRFH",$J,"ASSIGNIEN")_U_+@LKBLARR@("HISTORY",LINEOK,"HISTIEN")
53 . ; -- If action already has a note linked to it, try again:
54 . I +$G(TIUDA),+@LKBLARR@("HISTORY",LINEOK,"TIUIEN")=$G(TIUDA) S TIUAGN=2 Q
55 . I @LKBLARR@("HISTORY",LINEOK,"TIUIEN") S TIUAGN=1 Q
56SELECTQ K ^TMP("TIUPRFH",$J),^TMP("TIUPRFLKBL",$J)
57 Q TIURET
58 ;
59BREAK(LINENO,LINKBL,TIUER,LINEOK) ; Handle prompting
60 N TIUX,MORE
61 S MORE=$S(LINKBL>LINENO:1,1:0)
62BREAK1 ;
63 W !,"CHOOSE 1-",LINENO
64 I MORE W !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
65 W ": " R TIUX:DTIME
66 I $S('$T!(TIUX["^"):1,TIUX=""&'MORE:1,1:0) S TIUER=1 Q
67 I TIUX="" Q
68 I TIUX'=+TIUX!'$D(@LKBLARR@("HISTORY",+TIUX)) W !!,$C(7),"INVALID RESPONSE",! G BREAK1
69 S LINEOK=TIUX
70 Q
71 ;
72WRITE(LINENO) ; write the selectable item
73 ; Uses LKBLARR
74 N TIUX,TIUIEN,TIUAHIST,REFDT
75 S TIUX=$P($G(@LKBLARR@("HISTORY",LINENO,"DATETIME")),U)
76 W !,?2,LINENO,">",?7,$$FMTE^XLFDT(TIUX,"2D")
77 W ?27,$P(@LKBLARR@("HISTORY",LINENO,"ACTION"),U,2),?52
78 S TIUIEN=+@LKBLARR@("HISTORY",LINENO,"TIUIEN")
79 S TIUAHIST=+@LKBLARR@("HISTORY",LINENO,"HISTIEN")
80 I TIUIEN S REFDT=+$G(^TIU(8925,TIUIEN,13)),REFDT=$$DATE^TIULS(REFDT,"MM/DD/YY HR:MIN") W REFDT
81 Q
82 ;
83LINK(TIUDA,ASSGNDA,ACTDA,DFN) ;links a note to a flag assignment action
84 ;for patient DFN.
85 ; Returns 1 if successful otherwise 0^"error message"
86 N TIUTTL
87 S TIUTTL=+$G(^TIU(8925,TIUDA,0))
88 I 'TIUTTL Q "0^Document does not exist"
89 ; -- GUI doesn't link if we check if TIUDA is PRF note, so don't
90 ;I '$$ISPFTTL^TIUPRFL(TIUTTL) Q "0^Can't link non-PRF notes"
91 S TIURES=$$STOTIU^DGPFAPI2(DFN,ASSGNDA,ACTDA,TIUDA)
92 I 'TIURES Q TIURES
93 Q 1
94UNLINK(TIUDA) ;removes any link the note TIUDA might have
95 N TIUTTL
96 S TIUTTL=+$G(^TIU(8925,TIUDA,0))
97 I 'TIUTTL Q
98 S TIURES=$$DELTIU^DGPFAPI2(TIUDA)
99 Q
100RELINK(TIUDA,DFN) ; removes old link for TIUDA and links to new PRF assignment for patient DFN
101 ; returns 1 if successful otherwise 0^"error message"
102 N TIUPRF,TIUTTL,TIUASS,TIUACT,TIURES
103 S TIUTTL=+$G(^TIU(8925,TIUDA,0))
104 S TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
105 I '+TIUPRF Q TIUPRF
106 S TIUASS=+TIUPRF,TIUACT=$P(TIUPRF,U,2)
107 D UNLINK(TIUDA)
108 S TIURES=$$LINK^TIUPRF1(TIUDA,TIUASS,TIUACT,DFN)
109 Q 1
110 ;
111CHANGE(TIUDA) ; removes old link for TIUDA and links to new PRF assignment for TIUDA's patient
112 N DFN,TIUTTL,TIUPRF
113 S DFN=$P($G(^TIU(8925,TIUDA,0)),U,2)
114 S TIUTTL=+$G(^TIU(8925,TIUDA,0))
115 S TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
116 I '+TIUPRF W !,"You must select an action ... Nothing (re)-linked." S TIUPOP=1 Q
117 S TIUASS=+TIUPRF,TIUACT=$P(TIUPRF,U,2)
118 D UNLINK(TIUDA)
119 S TIUPRF=$$LINK(TIUDA,TIUASS,TIUACT,DFN)
120 I '+TIUPRF S TIUPOP=1 Q
121 Q
122 ;
123PRFCT(TIUOTTL,TIUNTTL,TIUDA) ; handles changing title situations for PRF notes in LM
124 N NEWISPRF,DFN,TIULINK,TIULINKC,OLDISPRF
125 S DFN=$P($G(^TIU(8925,TIUDA,0)),U,2)
126 S NEWISPRF=$$ISPFTTL^TIUPRFL(TIUNTTL)
127 S OLDISPRF=$$ISPFTTL^TIUPRFL(TIUOTTL)
128 ;-- non PRF title to PRF title
129 I NEWISPRF,'OLDISPRF D Q
130 . W !,"The Title you selected is a PRF Title."
131 . W !," PRF Notes must be linked to Patient Record Flags.",!
132 . W !,"Do you want to continue with this Change Title Action?"
133 . I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
134 . S TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
135 . I 'TIULINK S TIUQUIT=1 W !,"Title not changed." Q
136 . ; -- get new link
137 . S TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$P(TIULINK,U,2),DFN)
138 ;-- PRF title to PRF title
139 I NEWISPRF,OLDISPRF D Q
140 . W !,"This document is already attached to a Patient Record"
141 . W !," Flag. It will be unlinked from the current flag"
142 . W !," and linked to a new flag.",!
143 . W !,"Do you want to continue with this Change Title Action?"
144 . I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
145 . ; -- get new PRF Assignment to link to
146 . S TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
147 . I 'TIULINK S TIUQUIT=1 W !,"Title not changed." Q
148 . D UNLINK^TIUPRF1(+TIUDA)
149 . S TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$P(TIULINK,U,2),DFN)
150 ; -- PRF title to non PRF title
151 I 'NEWISPRF,OLDISPRF D Q
152 . W !,"The Title you selected is not a PRF Title."
153 . W !," The note is currently linked to a Patient Record Flag,"
154 . W !," but will be unlinked when the title is changed"
155 . W !," to a non-PRF Title.",!
156 . W !,"Do you want to continue with this Change Title Action?"
157 . I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
158 . D UNLINK^TIUPRF1(+TIUDA)
159 Q
160 ;
161GETLINK(TIUTYP,DFN,TIUDA) ; Ask user for link for NEW note and link it. Return success or failure
162 N TIUPRF,TIUPRFL
163 S TIUPRF=$$SELECT^TIUPRF1(TIUTYP,DFN)
164 I 'TIUPRF W !,"Patient Record Flag Notes must be linked to Flag Actions.",! Q 0
165 S TIUPRFL=$$LINK^TIUPRF1(TIUDA,$P(TIUPRF,U,1),$P(TIUPRF,U,2),DFN)
166 I 'TIUPRFL W !,$P(TIUPRFL,U,2),! Q 0
167 Q 1
Note: See TracBrowser for help on using the repository browser.