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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1DGPFLF6 ;ALB/RPM - PRF FLAG MANAGEMENT LM SUB-ROUTINE ; 4/19/04 4:25pm
2 ;;5.3;Registration;**425,554**;Aug 23, 1993
3 ;
4 Q
5 ;
6PRININV(DGFIEN,DGPFLF) ;Prompt for principle investigators
7 ;
8 ; Input:
9 ; DGFIEN - (optional) Pointer to PRF LOCAL FLAG (#26.11) file.
10 ; [default=0]
11 ; DGPFLF - Flag data array
12 ;
13 ; Output:
14 ; Function Value - 1 on success, 0 when user enters "^"
15 ; DGPFLF("PRININV") - Array of principal investigators
16 ;
17 N DGASK ;answer from prompt as a pointer to NEW PERSON (#200) file
18 N DGCNT ;place holder for new entries
19 N DGDA ;default answer for prompt
20 N DGLAST ;last entry in field entry array
21 N DGLKUP ;principle investigator dynamic "B" index
22 N DGNEWPI ;principal investigator in FM external form
23 N DGORIG ;principle investigator unmodified "B" index
24 N DGPREV ;next to last entry in field entry array
25 N DGQUIT ;loop termination flag
26 N DGRSLT ;function value
27 ;
28 S DGFIEN=+$G(DGFIEN) ;will be zero for 'Add Flag'
29 ;
30 ;build lookup and "on-file" array
31 M DGORIG=^DGPF(26.11,DGFIEN,2,"B")
32 M DGLKUP=DGORIG
33 ;
34 S DGRSLT=1
35 S DGQUIT=0
36 S (DGLAST,DGCNT)=+$O(DGPFLF("PRININV",""),-1)
37 ;
38 ;set default answer
39 S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2)
40 ;
41 F D Q:DGQUIT
42 . S DGASK=$$ANSWER^DGPFUT("Enter the Principal Investigator(s)",DGDA,"26.112,.01")
43 . ;
44 . ;stop prompting if user enters "^" or times out
45 . I DGASK=-1 S DGQUIT=1,DGRSLT=0 Q
46 . ;
47 . ;stop prompting if user accepts default entry
48 . I DGASK=$P($G(DGPFLF("PRININV",DGLAST,0)),U,1)!(DGASK="") S DGQUIT=1 Q
49 . ;
50 . ;perform lookup - re-prompt with new selection when entry exists
51 . I $D(DGLKUP(DGASK)) D Q
52 . . S DGLAST=+$O(DGLKUP(DGASK,0))
53 . . S DGDA=$P(DGPFLF("PRININV",DGLAST,0),U,2)
54 . ;
55 . ;process delete - remove entry from lookup array and move last pointer
56 . ; to previous entry in list. Set the field entry
57 . ; array value to "@" when the entry is "on-file",
58 . ; otherwise, remove the field entry array node.
59 . I DGASK="@" D Q
60 . . Q:'$D(DGPFLF("PRININV",DGLAST,0))
61 . . Q:'$$ANSWER^DGPFUT("Sure you want to delete '"_$P(DGPFLF("PRININV",DGLAST,0),U,2)_"' as a PRINCIPAL INVESTIGATOR","Yes","Y")
62 . . K DGLKUP($P(DGPFLF("PRININV",DGLAST,0),U,1))
63 . . S DGPREV=+$O(DGPFLF("PRININV",DGLAST),-1)
64 . . I $D(DGORIG($P(DGPFLF("PRININV",DGLAST,0),U,1))) D
65 . . . S DGPFLF("PRININV",DGLAST,0)="@"
66 . . E D
67 . . . K DGPFLF("PRININV",DGLAST,0)
68 . . S DGLAST=DGPREV
69 . . S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2)
70 . ;
71 . ;process new entry - if we make it here, then the entry is not the
72 . ; default, does not already exist in the field
73 . ; entry array and is not a delete. Add entry
74 . ; to the lookup array and the field entry array.
75 . I DGDA=""!(DGASK'=$P($G(DGPFLF("PRININV",DGLAST,0)),U)) D
76 . . S DGNEWPI=$$EXTERNAL^DILFD(26.112,.01,"F",DGASK)
77 . . Q:'$$ANSWER^DGPFUT("Are you adding '"_DGNEWPI_"' as a new PRINCIPAL INVESTIGATOR","No","Y")
78 . . S DGCNT=DGCNT+1
79 . . S DGLKUP(DGASK,DGCNT)=""
80 . . S DGPFLF("PRININV",DGCNT,0)=DGASK_U_DGNEWPI
81 . . S DGDA=""
82 ;
83 Q DGRSLT
84 ;
85ASGNCNT(DGFIEN,DGDFNLST) ;counts existing assignments for a given flag
86 ;This function searches for assignments for a given flag IEN and
87 ;returns the count of assignments. An optional array parameter will
88 ;be loaded with the DFNs assigned to the flag.
89 ;
90 ; Input:
91 ; DGFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file or
92 ; PRF NATIONAL FLAG (#26.15) file.
93 ; DGDFNLST - (optional) Array name to contain list of DFNs
94 ;
95 ; Output:
96 ; Function Value - count of existing assignments
97 ; DGDFNLST - Defined only when existing assignments are found.
98 ; Array of DFNs from existing assignments.
99 ; Example: DGDFNLST(7172421)=assignment IEN
100 ;
101 N DGCNT ;function value
102 N DGDFN ;pointer to PATIENT (#2) file
103 ;
104 S DGCNT=0
105 ;
106 I $G(DGFIEN)]"",$D(^DGPF(26.13,"AFLAG",DGFIEN)) D
107 . ;
108 . ;count the assignments
109 . S DGDFN=0
110 . F S DGDFN=$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN)) Q:'DGDFN D
111 . . S DGCNT=DGCNT+1
112 . . S DGDFNLST(DGDFN)=+$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN,0))
113 ;
114 Q DGCNT
115 ;
116 ;
117CKTIUPN(DGTITLE,DGARRAY) ;check for progress notes linked to a record flag
118 ;This function is used to check all assignment history records of
119 ;patients that are assigned to a given Record Flag for any existing
120 ;associated Progress Note ien values setup.
121 ;
122 ;If any associated Progress Notes are found, the given Record Flag's
123 ;Progress Note Title should not be edited until all the assignment
124 ;history records are un-linked from that given record flag.
125 ;
126 ; Input:
127 ; DGTITLE - IEN pointer to the TIU DOCUMENT (#8925.1) file
128 ; DGARRAY - Name of temp global closed root reference that
129 ; contains the list of DFNs assigned to record flag
130 ; i.e. ^TMP("DGPHTIU",564715668,7172421)=assignment IEN of (#26.13)
131 ;
132 ; Output:
133 ; Function result - "1" = if any linked Progress Notes are found
134 ; - "0" = if none found
135 ;
136 N DGRSLT ;function output - 0 or 1
137 N DGDFN ;pointer to PATIENT (#2) file
138 N DGHTIU ;array of return values for each assignment history record
139 N DGI ;for loop var
140 ;
141 S DGRSLT=0
142 ;
143 I $G(DGTITLE),$G(DGARRAY)]"" D
144 . ;
145 . S DGHTIU=$NA(^TMP("DGHTIU",$J))
146 . S DGDFN=0
147 . F S DGDFN=$O(@DGARRAY@(DGDFN)) Q:DGDFN="" D Q:DGRSLT
148 . . K @DGHTIU
149 . . I $$GETHTIU^DGPFAPI1(DGDFN,DGTITLE,DGHTIU) D
150 . . . S DGI=""
151 . . . F S DGI=$O(@DGHTIU@("HISTORY",DGI)) Q:DGI="" D Q:DGRSLT
152 . . . . I $P($G(@DGHTIU@("HISTORY",DGI,"TIUIEN")),U)]"" S DGRSLT=1
153 . ;
154 . K @DGHTIU
155 ;
156 Q DGRSLT
Note: See TracBrowser for help on using the repository browser.