source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP1.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: 6.6 KB
Line 
1ORLP1 ; SLC/DCM,CLA - Patient Lists, Store ; [1/3/01 1:37pm]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,63,90,98**;Dec 17, 1997
3 ;
4STOR ;called by ORLP0 - Store lists
5 N %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
6 W !!,"Store list for future reference"
7 S %=1 D YN^DICN Q:%=-1
8 I %=0 W !,"You may store the newly compiled list. Answer YES or NO." G STOR
9 Q:%=2
10 ;
11GETNAME ; Call DIR to get user entry for new list name:
12 N ORTNAM
13 S ORTNAM=""
14 N ORNEWL ; Flag used to indicate a new list (v. existing list).
15 S ORNEWL=1 ; Begin w/assumption of a new list name.
16 F D Q:$D(X)
17 .S DIR(0)="FAO^3:30",DIR("A")="Enter a name for this list: "
18 .D ^DIR
19 .I '$D(X)!($D(DIRUT)) K DIRUT W " List not permanently stored." Q
20 .S (ORLN,ORTNAM)=X
21 .S X=$G(X),DIC="^OR(100.21,"
22 .D ^DIC
23 I '$D(X)!(X="") Q
24 I +Y>0 S ORLIST=+Y,ORLN=$P(Y,U,2) K DIC S Y=ORLIST S ORNEWL=0 ; List name already exists.
25 ;
26OVRWR ;
27 N ORABORT ; Flag for aborting process.
28 S ORABORT=0
29 ;
30 ; Check for problems with name entry:
31 I 'ORNEWL D
32 .I $$NAMCH(+ORLIST) S ORABORT=1
33 I ORABORT G GETNAME
34 ;
35 ; Ask - overwrite if an existing team by that name already?:
36 I 'ORNEWL D
37 .I $O(^OR(100.21,+Y,10,0)) D Q:%'=1 ; Any patients on list yet?
38 ..F D Q:%
39 ...W !,ORLN_" already has patients. Do you want to overwrite it"
40 ...S %=2 D YN^DICN
41 ...I %=2!(%=-1) W !,"List ",ORLN," unchanged.",! S ORABORT=1 Q
42 ...I '% W !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",! Q
43 .I ORABORT Q
44 .L +^OR(100.21,+ORLIST)
45 .I '$D(^OR(100.21,ORLIST,10,0))#2 S ^(0)="^100.2101AV^"
46 .I '$D(^OR(100.21,ORLIST,1,0))#2 S ^(0)="^100.212PA^"
47 .S I=0 F S I=$O(^OR(100.21,ORLIST,10,I)) Q:'I S DA=+I,DA(1)=+ORLIST,DIK="^OR(100.21,"_ORLIST_",10," D ^DIK
48 .L -^OR(100.21,+ORLIST)
49 I ORABORT G GETNAME
50 ;
51 ; If a new list name, write new team into OE/RR LIST file:
52 I ORNEWL D
53 .S DIC="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ"
54 .D ^DIC
55 .I (Y<0!'$D(X)) S ORABORT=1 Q ; User aborted or there was a problem.
56 .S ORLIST=+Y
57 I ORABORT K DIC Q
58 ;
59 ; Assure other required entries if necessary:
60 I ORNEWL D
61 .I $P($G(^OR(100.21,+ORLIST,1,0)),U,2)'="P" D
62 ..S DIE="^OR(100.21,",DA=ORLIST,DR="1///^S X=""P"""
63 ..D ^DIE
64 ..K DIE,DA
65 .I '$D(^OR(100.21,+ORLIST,1,DUZ)) S DA(1)=ORLIST,DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="LX",X="`"_DUZ D ^DIC K DIC
66 ;
67 ; Add selected patients to list (if any):
68 L +^OR(100.21,+ORLIST)
69 S ORI=0
70 F S ORI=$O(^XUTL("OR",$J,"ORLP",ORI)) Q:ORI<1 I $D(^(ORI,0)) S X=^(0),X="PT.`"_+$P(X,"^",3),DA(1)=ORLIST,DIC="^OR(100.21,"_ORLIST_",10,",DIC(0)="LX" D ^DIC
71 K DIC,ORI
72 L -^OR(100.21,ORLIST)
73 W !!,"List has been stored."
74 Q
75 ;
76MERG ;called by option ORLP MERG - merge patient lists
77 D CLEAR^ORLP ;clear XUTL for merge
78 D ASK^ORLP0(.X)
79 I (X<0)!(X>1) Q
80 S:'$D(ORCNT) ORCNT=0
81 W @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
82 S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I ""PT""[$E($P(^(0),U,2))"
83 F ORK=1:1 S ORCT=0,DIC("A")="Select LIST "_ORK_": " D P1^ORLP0 Q:ORY<1 I ORCNT>0 W !!,ORCT_" Patients added, "_ORCNT_" total"
84 Q:$D(DTOUT)!($D(DUOUT))
85 I 'ORCNT W !!,"List empty.",! D END^ORLP0 Q
86 D PR2^ORLA1(OROPREF)
87 W !!,"LIST PATIENTS MERGED"
88 D LIST^ORLP0
89 D STOR,END^ORLP0
90 D BUILD^ORLA1 ;load XUTL with user's primary list
91 K DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
92 Q
93 ;
94DEL ;called by option ORLP DELETE - delete a list
95 I '$D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)'=""P""",DIC("A")="Select Team PATIENT LIST to delete: "
96 I $D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""P""&($D(^OR(100.21,""C"",DUZ,+Y)))",DIC("A")="Select Personal PATIENT LIST to delete: "
97 D ^DIC
98 K DIC
99 I Y<1 Q
100 S DLIST=Y
101 ;
102D2 ;
103 S %=""
104 I $$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")=+DLIST W !!,"This is your primary patient list, are you sure you want to remove it" S %=2 D YN^DICN
105 I %=0 W !,"Answer YES if you really want to remove this list." G D2
106 I %'="" Q:%'=1
107 W !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
108 ;
109D1 ;
110 W !,"Are you ready to delete list ",$P(DLIST,"^",2)
111 S %=2 D YN^DICN
112 I %=0 W !,"Enter YES to delete the list, NO to quit." G D1
113 Q:%'=1
114 W !,"Processing........"
115 L +^OR(100.21,+DLIST)
116 S DA=+DLIST,DIK="^OR(100.21,"
117 D ^DIK
118 K DA,DIC,DIK
119 ;
120 ; Next 2 lines added by PKS, 2/8/2000:
121 W !,"Searching for/removing Consults pointers to deleted team..."
122 D CLNLIST^GMRCTU(+DLIST,0) ; Dump pointers to team in file 123.5.
123 ;
124 W !,"List deletion completed.",!
125 L -^OR(100.21,+DLIST)
126 K DLIST,ORLPDUZ,Y,XX,^TMP("ORLP",$J,"TLIST") ;KILL temporary list
127 G DEL
128 Q
129 ;
130CLEAR(X) ;called by option ORLP CLEAR - clear active list
131 I '$D(^XUTL("OR",$J,"ORLP")) W !!,"No list currently defined" S X=1 Q
132 F D Q:X
133 . W !!,"Are you sure you want to clear the current pt selection list"
134 . S %=2 D YN^DICN
135 . I %=-1 S X=% Q
136 . I %=0 W !!,"YES will clear the current pt selection list and leave you with a blank slate to work from." S X=0 Q
137 . I %=1 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S:$D(ORCNT) ORCNT=0 W !!,"List cleared" S X=% Q
138 . W !!,"Nothing done."
139 . S X=2
140 Q
141 ;
142NAMCH(ORTEAM) ; Check for name duplication, proper team type.
143 ;
144 ; Variables used:
145 ;
146 ; ORTEAM = IEN of team in Team List file (^OR100.21).
147 ;
148 ; Check for name duplication and not a "Personal" type team:
149 I $P($G(^OR(100.21,ORTEAM,0)),U,2)'="P" D Q 1
150 .W !,ORTNAM," name already used - can't overwrite.",!
151 .K X,Y,ORLIST,ORLN
152 ;
153 ; Check for "Personal" type but not current user's team:
154 ; ("CREATOR" field was added later, so not used here.)
155 ; Is this user's DUZ in "USER" multiple?
156 I '$D(^OR(100.21,"C",DUZ,ORTEAM)) D Q 1
157 .W !,ORTNAM," name exists, you are not a user - can't overwrite.",!
158 .K X,Y,ORLIST,ORLN
159 ;
160 Q 0
161 ;
162OWNER ; Get input from CAC for list user/owner.
163 ;
164 ; Variables used herein:
165 ;
166 ; DIR,X,Y = FM call variables.
167 ; ORYY = NEW'd in calling routine (ORLP).
168 ; OROWNER = NEW'd in calling routine (ORLP).
169 ;
170 N DIR,X,Y
171 ;
172 ; Assign variables and get input from CAC for user/owner of list:
173 S OROWNER="" ; Default.
174 S DIR(0)="PAO^200,:AEMNQ"
175 S DIR("A")=" Enter owner of this Personal type list: "
176 S DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
177 S DIR("?")="Only owner you specify can edit list after creation."
178 D ^DIR
179 S OROWNER=Y
180 K DIR,X,Y ; Clean up.
181 I OROWNER<1 S OROWNER="" Q ; No acceptable entry.
182 S OROWNER=+OROWNER ; Selected user's DUZ.
183 S $P(^OR(100.21,+ORYY,0),U,5)=OROWNER ; Assign CREATOR field.
184 ;
185 Q
186 ;
Note: See TracBrowser for help on using the repository browser.