source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFLF5.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1DGPFLF5 ;ALB/RBS - PRF FLAG MANAGEMENT LM PROTOCOL ACTIONS CONT. ; 3/23/05 1:01pm
2 ;;5.3;Registration;**425,554**;Aug 13, 1993
3 ;
4 ;no direct entry
5 QUIT
6 ;
7EFCONT(DGPFLF,DGPFLH,DGPFORIG,DGABORT,DGIDXIEN) ; EF Edit Flag action
8 ;-- Continue entry point for DGPF EDIT FLAG action protocol.
9 ;
10 ; Input:
11 ; DGPFLF - array of flag record fields (passed by reference)
12 ; DGPFLH - array for REASON field (passed by reference)
13 ; DGPFORIG - DGPFLF copy of original values (passed by reference)
14 ; DGABORT - abort flag - value passed in = 0
15 ; DGIDXIEN - ien of flag record from the "IDX"
16 ;
17 ; Output:
18 ; DGPFLF - Edited array of flag record fields
19 ; DGABORT - 1 if user wishes to abort, 0 otherwise
20 ;
21 N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call
22 N DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT ;input/output vars for ^DIR
23 N DGDA ;default answer
24 N DGCKWP ;check if word-processing is OK
25 N DGASK ;return value from $$ANSWER^DGPFUT call
26 N DGRDAY ;review frequency
27 N DGQ,DGSUB ;counters and quit flag
28 N DGACNT ;count of existing assignments assigned to flag
29 N DGDFNLST ;array of DFN's when existing assignments are found
30 N DGTITLE ;pointer of the progress note title
31 N DGARRAY ;array of assignment history data
32 ;
33 S (DGACNT,DGQ,DGSUB)=0
34 S DGARRAY=$NA(^TMP("DGPFLF5",$J)) K @DGARRAY
35 ;
36 ; check for assignments to the flag and load the array with the DFN's
37 S DGACNT=$$ASGNCNT^DGPFLF6(DGIDXIEN,.DGDFNLST)
38 I DGACNT M @DGARRAY=DGDFNLST K DGDFNLST
39 ;
40 ;-- user prompts
41 D
42 . ;-- prompt for flag name, quit if one not entered
43 . S DGDA=$P($G(DGPFLF("FLAG")),U,2)
44 . S DGASK=$$ANSWER^DGPFUT("Enter the Record Flag Name",DGDA,"26.11,.01^^I X'=DGDA,$D(^DGPF(26.11,""B"",X)) K X W "" *** Flag name already on file""")
45 . I DGASK=-1!(DGASK=0) S DGABORT=1 Q
46 . I DGASK'=DGDA D
47 . . I DGACNT D Q
48 . . . W !," >>> Name change not allowed ... "_DGACNT_" patients are assigned to this flag."
49 . . . S DGABORT=1
50 . . ;
51 . . S DGPFLF("OLDFLAG")=DGDA ;save for name change lookup
52 . . S DGPFLF("FLAG")=DGASK_U_DGASK
53 . ;
54 . Q:DGABORT
55 . ;
56 . ;-- prompt for status of the flag, quit if one not entered
57 . S DGDA=$P($G(DGPFLF("STAT")),U,2)
58 . S DGASK=$$ANSWER^DGPFUT("Enter the Status of the Flag",DGDA,"26.11,.02")
59 . I DGASK<0 S DGABORT=1 Q
60 . S:DGASK'=$P($G(DGPFLF("STAT")),U) DGPFLF("STAT")=DGASK_U_$$EXTERNAL^DILFD(26.11,.02,"F",DGASK)
61 . ;
62 . ; check for any Active Patient Assignments and give warning
63 . ; that all patients will be inactivated when this edit is filed
64 . I DGASK=0,$D(^DGPF(26.13,"ASTAT",1,DGIDXIEN)) D
65 . . W *7,!," >>> WARNING - All Patient's assigned to this flag will be"
66 . . W !?17,"Inactivated automatically after filing this edit."
67 . . ;
68 . . I $$ANSWER^DGPFUT("Enter RETURN to continue or '^' to exit","","E")=-1 S DGABORT=1
69 . ;
70 . Q:DGABORT
71 . ;
72 . ;-- prompt for flag type, quit if one not entered
73 . S DGDA=$P($G(DGPFLF("TYPE")),U,2)
74 . S DGASK=$$ANSWER^DGPFUT("Enter the Type of the Flag",DGDA,"26.11,.03")
75 . I DGASK'>0 S DGABORT=1 Q
76 . I DGASK'=$P($G(DGPFLF("TYPE")),U) D
77 . . I DGACNT D Q
78 . . . W !," >>> Flag Type change not allowed ... "_DGACNT_" patients are assigned to this flag."
79 . . . S DGABORT=1
80 . . S DGPFLF("TYPE")=DGASK_U_$$EXTERNAL^DILFD(26.11,.03,"F",DGASK)
81 . Q:DGABORT
82 . ;
83 . ;-- delete all principal investigator(s) if flag type not RESEARCH
84 . I +DGPFLF("TYPE")'=2,$D(DGPFLF("PRININV")) D
85 . . S DGSUB=0
86 . . F S DGSUB=$O(DGPFLF("PRININV",DGSUB)) Q:DGSUB="" D
87 . . . S DGPFLF("PRININV",DGSUB,0)="@"
88 . ;
89 . ;-- prompt for principal investigator(s) name for RESEARCH type flag
90 . I +DGPFLF("TYPE")=2,'$$PRININV^DGPFLF6(+DGIDXIEN,.DGPFLF) D Q:DGABORT
91 . . I $$ANSWER^DGPFUT("Enter RETURN to continue or '^' to exit","","E")=-1 S DGABORT=1
92 . ;
93 . ;-- prompt for review frequency, quit if one not entered
94 . S DGDA=$P($G(DGPFLF("REVFREQ")),U,2)
95 . S DGASK=$$ANSWER^DGPFUT("Enter the Review Frequency Days",DGDA,"26.11,.04^^K:$L(X)>4!(X[""."") X")
96 . I DGASK<0 S DGABORT=1 Q
97 . S:DGASK'=$P($G(DGPFLF("REVFREQ")),U) DGPFLF("REVFREQ")=DGASK_U_DGASK
98 . S DGRDAY=DGASK
99 . I DGASK=0 D ;don't ask notification/review group when review freq = 0
100 . . S DGPFLF("NOTIDAYS")=0_U_0
101 . . S DGPFLF("REVGRP")=""_U_""
102 . . ;
103 . E D Q:DGABORT
104 . . ;
105 . . ;-- prompt for notification days
106 . . S DGDA=$P($G(DGPFLF("NOTIDAYS")),U,2)
107 . . S DGASK=$$ANSWER^DGPFUT("Enter the Notification Days",DGDA,"26.11,.05^^K:$L(X)>4!(X[""."")!(X>DGRDAY) X")
108 . . I DGASK<0 S DGABORT=1 Q
109 . . S DGPFLF("NOTIDAYS")=DGASK_U_DGASK
110 . . ;
111 . . S DGQ=0
112 . . F D Q:(DGQ!DGABORT)
113 . . . ;-- prompt for review mail group name, optional entry
114 . . . S DGDA=$P($G(DGPFLF("REVGRP")),U,2)
115 . . . S DGASK=$$ANSWER^DGPFUT("Enter the Review Mail Group",DGDA,"26.11,.06r")
116 . . . I DGASK<0 S DGABORT=1 Q
117 . . . I DGASK'>0 D Q
118 . . . . W !," >>> You've entered the Review Frequency and Notification Days,"
119 . . . . W !," now enter a Review Mail Group or abort this process.",*7
120 . . . . I '$$CONTINUE^DGPFUT() S DGABORT=1
121 . . . ;
122 . . . S DGPFLF("REVGRP")=DGASK_U_$$EXTERNAL^DILFD(26.11,.06,"F",DGASK)
123 . . . S DGQ=1 ;set entry, quit
124 . ;
125 . ;-- prompt for associated TIU PN Title
126 . S DGDA=$P($G(DGPFLF("TIUTITLE")),U,2),DGQ=0
127 . S DGTITLE=$P($G(DGPFLF("TIUTITLE")),U)
128 . S DGASK=$$ANSWER^DGPFUT("Enter the Progress Note Title",DGDA,"26.11,.07r")
129 . I DGASK<0 S DGABORT=1 Q
130 . ;
131 . ; Do not allow the title to change using the following logic:
132 . ; - if the existing progress note title changes,
133 . ; and there are patients assigned to the record flag name,
134 . ; and there are any linked TIU progress notes on any patients
135 . ; assignment history record
136 . ;
137 . I DGASK'=DGTITLE D
138 . . I $$FNDTITLE^DGPFAPI1(DGASK) S DGQ=1 ;should never happen...but
139 . . I 'DGQ,DGTITLE,DGACNT D
140 . . . ; check all DFN's assigned to the record flag
141 . . . I $$CKTIUPN^DGPFLF6(DGTITLE,DGARRAY) S DGQ=1
142 . . I DGQ D Q
143 . . . W !!," >>> Unable to edit, there are Progress Note(s) associated with a",!," patient's PRF Assignment action.",!,*7
144 . . ;
145 . . ; ok to add or change the TIU Progress Note Title
146 . . S DGPFLF("TIUTITLE")=DGASK_U_$$EXTERNAL^DILFD(26.11,.07,"F",DGASK)
147 . ;
148 . Q:DGABORT
149 . ;
150 . ;-- ask user if they want to edit the flag description text
151 . I $$ANSWER^DGPFUT("Would you like to edit the description of this record flag","NO","Y")>0 D Q:DGABORT
152 . . S DGCKWP=0 K DGERR
153 . . S DGWPROOT=$NA(^TMP($J,"DGPFDESC"))
154 . . K @DGWPROOT
155 . . S DGDA=$$GET1^DIQ(26.11,$P(DGIDXIEN,";"),"1","Z",DGWPROOT,"DGERR")
156 . . I $D(DGERR)!(DGDA="") S DGABORT=1 D Q
157 . . . W !,"An error has occurred while trying to retrieve the Flag Description Text.",*7
158 . . F D Q:(DGCKWP!DGABORT)
159 . . . S DIC=$$OREF^DILF(DGWPROOT)
160 . . . S DIWETXT="Patient Record Flag - Flag Description Text"
161 . . . S DIWESUB="Flag Description Text"
162 . . . S DWLW=75 ;max # chars allowed to be stored on WP global node
163 . . . S DWPK=1 ;if line editor, don't join line
164 . . . D EN^DIWE
165 . . . I $$CKWP^DGPFUT(DGWPROOT) S DGCKWP=1 Q
166 . . . W !,"Flag Description Text is required!",!,*7
167 . . . I '$$CONTINUE^DGPFUT() S DGABORT=1 K @DGWPROOT
168 . . ;
169 . . ;-- quit if required flag description not entered
170 . . Q:DGABORT
171 . . ;
172 . . ;-- place flag description text into assignment array
173 . . I DGCKWP D
174 . . . K DGPFLF("DESC")
175 . . . M DGPFLF("DESC")=@DGWPROOT
176 . . . K @DGWPROOT
177 . ;
178 . Q:DGABORT
179 . ;
180 . ;-- have user enter edit reason (required)
181 . S DGCKWP=0
182 . S DGWPROOT=$NA(^TMP($J,"DGPFREASON"))
183 . K @DGWPROOT
184 . F D Q:(DGCKWP!DGABORT)
185 . . W !!,"Enter the reason for editing this record flag:" ;needed for line editor
186 . . S DIC=$$OREF^DILF(DGWPROOT)
187 . . S DIWETXT="Patient Record Flag - Edit Reason Text"
188 . . S DIWESUB="Edit Reason Text"
189 . . S DWLW=75 ;max # chars allowed to be stored on WP global node
190 . . S DWPK=1 ;if line editor, don't join line
191 . . D EN^DIWE
192 . . I $$CKWP^DGPFUT(DGWPROOT) S DGCKWP=1 Q
193 . . W !,"Edit Reason Text is required!",!,*7
194 . . I '$$CONTINUE^DGPFUT() S DGABORT=1 K @DGWPROOT
195 . ;
196 . Q:DGABORT
197 . I DGCKWP M DGPFLH("REASON")=@DGWPROOT K @DGWPROOT
198 . ;
199 . S:'DGCKWP DGABORT=1
200 ;
201 I DGACNT K @DGARRAY
202 Q
Note: See TracBrowser for help on using the repository browser.