source: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREV3.m

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1OREV3 ;SLC/DAN Event delayed orders set up continued ;12/23/02 13:28
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165**;Dec 17, 1997
3 ;DBIA reference section
4 ;10116 - VALM1
5 ;2324 - USRLM
6 ;10009 - DICN
7 ;2056 - DIQ
8 ;2336 - XPAREDIT
9 ;2263 - XPAR
10 ;10006 - DIC
11 ;10026 - DIR
12 ;10018 - DIE
13 ;10103 - XLFDT
14 ;
15ACE ;Add child events to existing events
16 N DIC,ORJ,ORTMP,DA,Y,ORGLOB,ADD
17 D FULL^VALM1 ;get full screen
18 S VALMBCK="R"
19 S (DIC,ORGLOB)="^ORD(100.5,"
20 I $G(ORNMBR)="" S ORNMBR=$$ORDERS^OREV1("add child events to") Q:ORNMBR="^" ;If action selected before items, get items
21 I $G(ORNMBR)="" D Q
22 .S DIC(0)="AEMQ",DIC("S")="I '+$P($G(^(0)),U,12)" ;Screen children from being parents
23 .D ^DIC Q:Y=-1 S DA=+Y
24 .Q:'$$PARENTOK^OREV4
25 .L +@(ORGLOB_DA_")"):1 I '$T W !!,"This entry is being edited by another user." H 3 Q
26 .W !!,"Adding children to parent ",$P(^ORD(100.5,DA,0),U)
27 .D ADDCHLD(DA,.ADD) ;Add child to selected event
28 .I $G(ADD) D AUDIT^OREV(DA,"E"),CHKPRM^OREV4 ;If child event added update audit history and check parameters
29 .L -@(ORGLOB_DA_")")
30 F ORJ=1:1:$L(ORNMBR,",")-1 S ORTMP=$P(ORNMBR,",",ORJ),DA=$O(^TMP("OREDO",$J,"IDX",ORTMP,0)) D
31 .I $P($G(^ORD(100.5,DA,0)),U,12) W !!,"You may not add child events to events that are already children.",!,$P($G(^ORD(100.5,DA,0)),U)," - SKIPPED!",! H 3 Q
32 .Q:'$$PARENTOK^OREV4
33 .L +@(ORGLOB_DA_")"):1 I '$T W !!,"This entry is being edited by another user." H 3 Q ;Lock global
34 .W !!,"Adding children to parent ",$P(^ORD(100.5,DA,0),U)
35 .D ADDCHLD(DA,.ADD) ;Add child to selected event
36 .I $G(ADD) D AUDIT^OREV(DA,"E"),CHKPRM^OREV4 ;If child event added update audit history and check paramters
37 .L -@(ORGLOB_DA_")") ;Unlock global
38 Q
39 ;
40ADDCHLD(ENTRY,ADD) ;Add child(ren) to event
41 ;ENTRY - Internal entry number of event that will be the parent
42 ;ADD - Will be set to 1 if a child is successfully added
43 ;
44 N DIR,Y,DIC,DIE,DA,DR,DIRUT,X,NEW
45 F D Q:$G(DIRUT)
46 .W !
47 .S DIR(0)="FAO^3:50"
48 .S DIR("A")="OE/RR CHILD RELEASE EVENT NAME: "
49 .S DIR("?")="Enter the name of the child event you wish to create. It must be free text between 3 and 50 characters and be unique."
50 .D ^DIR
51 .Q:$G(DIRUT)
52 .I $D(^ORD(100.5,"B",Y)) W !,"There is already an entry with this name. Please select a different name." Q
53 .S DIC="^ORD(100.5,",DIC(0)="",X=Y D FILE^DICN ;Add child to file
54 .Q:Y=-1
55 .S DIE=DIC
56 .S DR="[OREV CHILD EVENT"
57 .S DA=+Y
58 .S NEW=1
59 .D ^DIE
60 .Q:'$G(DA) ;Child event deleted, stop processing
61 .D AUDIT^OREV(DA,"N") ;Update audit history for child
62 .S DR="1///"_$$NOW^XLFDT_";14///`"_ENTRY D ^DIE ;Add parent pointer to child entry
63 .S ADD=1 ;Indicate that child was added
64 .W !!,"Enter next child name or press enter to stop adding children."
65 Q
66 ;
67UPDTCHLD(PARENT,CDT) ;Update children to inactive when parent is inactivated
68 N DA,DIE,CHILD,DR,DONE
69 S DONE=0
70 S CHILD="" F S CHILD=$O(^ORD(100.5,"DAD",PARENT,CHILD)) Q:'+CHILD D
71 .I 'DONE W !!,"Updating children..." S DONE=1
72 .Q:$G(^ORD(100.5,CHILD,1)) ;Child is already inactive
73 .S DA=CHILD
74 .S DIE="^ORD(100.5,"
75 .S DR="1///"_CDT
76 .D ^DIE ;Sets inactivated date/time for child
77 .;
78 .S DA(1)=DA
79 .S DA=$O(^ORD(100.5,DA(1),2,"ACT",0))
80 .S DIE="^ORD(100.5,DA(1),2,"
81 .S DR="1///"_CDT
82 .D ^DIE ;Update inactivated date/time of activation multiple for child
83 Q
84 ;
85PARAM ;Allow user to edit event delayed order parameters
86 N DIR,Y
87 S VALMBCK="R" D FULL^VALM1
88 F D Q:'Y
89 .S DIR(0)="SO^1:Write orders list by event;2:Default release event;3:Common release event list;4:Manual release controlled by;5:Set manual release parameter;6:Exclude display groups from copy"
90 .S DIR("A")="Select parameter to edit"
91 .D ^DIR Q:'Y
92 .I Y=2!(Y=3) D:Y=2 SETDFLT() D:Y=3 EVENTLST Q
93 .D EDITPAR^XPAREDIT($S(Y=1:"ORWDX WRITE ORDERS EVENT LIST",Y=4:"OREVNT MANUAL RELEASE CONTROL",Y=5:"OREVNT MANUAL RELEASE",1:"OREVNT EXCLUDE DGRP"))
94 Q
95 ;
96CANREL() ;Function to determine if delayed order can be manually released
97 N ORMAN,CAN
98 S ORMAN=$$GET^XPAR("ALL","OREVNT MANUAL RELEASE CONTROL")
99 S:ORMAN="" ORMAN="K" ;If no value found, default to checking for keys
100 I ORMAN="K",'$$KEY Q 0
101 I ORMAN="P",'$$MANPARAM Q 0
102 I ORMAN="B" D Q:$G(CAN)=0 0
103 .I $$KEY,$$MANPARAM=0 S CAN=0 Q
104 .I '$$KEY,'$$MANPARAM S CAN=0
105 Q 1
106 ;
107KEY() ;Check for ORES or ORELSE keys
108 I '$D(^XUSEC("ORES",DUZ))&('$D(^XUSEC("ORELSE",DUZ))) Q 0
109 Q 1
110 ;
111MANPARAM() ;Check setting of OREVNT MANUAL RELEASE parameter
112 N LST,I,FND,PRM,X,Y,DIC,EXP,STR,VAL,FNDNO
113 S DIC=8989.51,DIC(0)="MX",X="OREVNT MANUAL RELEASE" D ^DIC
114 I Y=-1 Q 0 ;Parameter not found so quit
115 S PRM=+Y
116 ;Check USER level
117 S VAL=$$GET^XPAR("USR",PRM) I VAL'="" Q VAL
118 ;Check USER CLASS
119 D WHATIS^USRLM(DUZ,"LST")
120 I $O(LST(0))'="" D I FND'="" Q FND
121 .S FND=""
122 .S I=0 F S I=$O(LST(I)) Q:I=""!(FND) S EXP=+$P(LST(I),U,5),STR=+$P(LST(I),U,4) I 'EXP!(EXP'<DT) I 'STR!(STR'>DT) S FND=$G(^XTV(8989.5,"AC",PRM,$P(LST(I),U)_";USR(8930,",1)) I FND=0 S FNDNO=1
123 .I 'FND,$G(FNDNO) S FND=0
124 ;Check OE/RR Teams
125 K LST,FNDNO
126 D TEAMPR^ORQPTQ1(.LST,DUZ)
127 I +$G(LST(1)) D I FND'="" Q FND
128 .S FND=""
129 .S I=0 F S I=$O(LST(I)) Q:I=""!(FND) S FND=$G(^XTV(8989.5,"AC",PRM,$P(LST(I),U)_";OR(100.21,",1)) S:FND=0 FNDNO=1
130 .I 'FND,$G(FNDNO) S FND=0
131 ;Check location
132 I +$G(LOC) S VAL=$$GET^XPAR("LOC.`"_+$G(LOC),PRM) I VAL'="" Q VAL
133 ;Check Service
134 S VAL=$G(^XTV(8989.5,"AC",PRM,+$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,",1)) I VAL'="" Q VAL
135 ;Check Division and System
136 S VAL=$$GET^XPAR("DIV^SYS",PRM) I VAL'="" Q VAL
137 Q ""
138 ;
139DEFHELP ;Provide detailed help for setting default treating specialty
140 N DEF,DEFTS,DEFTSNM
141 I $D(^ORD(100.5,DA(1),"TS","DEF")) D Q
142 .S DEF=$O(^ORD(100.5,DA(1),"TS","DEF",1,0))
143 .I DEF=DA Q ;Default is current entry
144 .S DEFTS=$P(^ORD(100.5,DA(1),"TS",DEF,0),U)
145 .S DEFTSNM=$$GET1^DIQ(45.7,DEFTS_",",.01)
146 .W !?5,"You may not set this treating specialty as the default because"
147 .W !?5,DEFTSNM," is already set as the default."
148 .W !?5,"If you would like to change the default you must first delete the",!?5,"default designation from the above mentioned treating specialty.",!
149 ;
150 W !?5,"Currently there is no default treating specialty set for this event.",!
151 Q
152 ;
153EVENTLST ;Allow user to edit OREVNT COMMON LIST parameter and set a default for that list
154 N DIC,X,Y,PRM,ORENT
155 S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC
156 Q:Y=-1 ;Parameter doesn't exist
157 S PRM=Y
158 D GETENT^XPAREDIT(.ORENT,PRM)
159 Q:ORENT="" ;Nothing selected
160 D EDIT^XPAREDIT(ORENT,PRM) ;edit selected entity
161 Q:$G(DUOUT)!($G(DTOUT)) ;User ^ or timed out
162 I '$D(^XTV(8989.5,"AC",+PRM,ORENT)) Q ;No value stored for entity don't ask for default
163 D SETDFLT(ORENT,PRM)
164 Q
165 ;
166SETDFLT(ORENT,PRM) ;Set default for given list
167 N DIC,Y,X,PRMD,DEF,I,J,DIR,FND,ORLST
168 I $G(PRM)="" S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC Q:Y=-1 S PRM=Y
169 S DIC=8989.51,DIC(0)="MX",X="OREVNT DEFAULT" D ^DIC
170 Q:Y=-1 ;Parameter doesn't exist
171 S PRMD=Y
172 I $G(ORENT)="" D GETENT^XPAREDIT(.ORENT,PRMD) Q:ORENT="" ;Nothing selected
173 D GETLST^XPAR(.ORLST,ORENT,+PRM)
174 I ORLST=0 W !!,"No common list is defined for this entity and therefore a default",!,"may not be set. Create a common list first.",! Q
175 S DEF=$$GET^XPAR(ORENT,+PRMD,,"B") F I=1:1:ORLST I $P(ORLST(I),U,2)=+DEF S FND=1
176 I '$G(FND) S DEF="" D EN^XPAR(ORENT,+PRMD,,"@") ;Delete default if no longer in list
177 W !!,$S(DEF'="":"Current DEFAULT is "_$P(DEF,U,2)_$S($G(^ORD(100.5,+DEF,1)):" (*INACTIVE*)",1:""),1:"No DEFAULT has been set yet.")
178 W ! F J=1:1:ORLST W !,J,") ",$P(^ORD(100.5,$P(ORLST(J),U,2),0),U),$S($G(^(1)):" (*INACTIVE*)",1:"")
179 I DEF'="" S ORLST=ORLST+1 W !!,ORLST,") DELETE CURRENT DEFAULT"
180 W ! S DIR(0)="NO^1:"_ORLST,DIR("A")="Select default release event"_$S(DEF'="":" or delete current event",1:"") D ^DIR
181 I 'Y Q ;No selection made
182 I Y=ORLST&(DEF'="") D EN^XPAR(ORENT,+PRMD,,"@") W !,"Default deleted" Q
183 I $G(^ORD(100.5,$P(ORLST(Y),U,2),1)) W !,"You cannot set an inactive event as the default." Q ;No inactive defaults can be set
184 ;write updated parameter
185 D EN^XPAR(ORENT,+PRMD,,"`"_$P(ORLST(Y),"^",2))
186 Q
187 ;
188GETLST(LST) ;Return common list and default event
189 N I,FND,PRM,X,Y,DIC,TLST,ORCLST,ENT,EXP,STR
190 S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC
191 I Y=-1 Q ;Parameter not found so quit
192 S PRM=+Y
193 D ENVAL^XPAR(.ORCLST,PRM) Q:ORCLST=0 ;Nothing defined at any level
194 ;Check USER level
195 S ENT=DUZ_";VA(200," I $D(ORCLST(ENT)) D RETLST Q
196 ;Check USER CLASS
197 D WHATIS^USRLM(DUZ,"TLST")
198 I $O(TLST(0))'="" D I FND Q
199 .S FND=0
200 .S I=0 F S I=$O(TLST(I)) Q:I=""!(FND) S ENT=$P(TLST(I),U)_";USR(8930," S EXP=+$P(TLST(I),U,5),STR=+$P(TLST(I),U,4) I 'EXP!(EXP'<DT) I 'STR!(STR'>DT) I $D(ORCLST(ENT)) D RETLST S FND=1
201 ;Check OE/RR Teams
202 K TLST
203 D TEAMPR^ORQPTQ1(.TLST,DUZ)
204 I +$G(TLST(1)) D I FND Q
205 .S FND=0
206 .S I=0 F S I=$O(TLST(I)) Q:I=""!(FND) S ENT=$P(TLST(I),U)_"OR(100.21," I $D(ORCLST(ENT)) D RETLST S FND=1
207 ;Check location
208 I +$G(LOC) S ENT=+LOC_";SC(" I $D(ORCLST(ENT)) D RETLST Q
209 ;Check Service
210 S ENT=$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,"
211 I $D(ORCLST(ENT)) D RETLST Q
212 ;Check Division
213 S ENT=DUZ(2)_";DIC(4," I $D(ORCLST(ENT)) D RETLST Q
214 Q
215 ;
216RETLST ;Sets up list for entity
217 N DEF,Y,DIC,I,CNT,X
218 S DIC=8989.51,DIC(0)="MQ",X="OREVNT DEFAULT" D ^DIC
219 Q:'Y ;Stop if parameter doesn't exist
220 S CNT=1
221 S DEF=$$GET^XPAR(ENT,+Y,,"B")
222 S I=0 F S I=$O(ORCLST(ENT,I)) Q:'+I I '$G(^ORD(100.5,ORCLST(ENT,I),1))&('$D(^ORD(100.5,"DAD",ORCLST(ENT,I)))) S LST(CNT)=ORCLST(ENT,I) S:ORCLST(ENT,I)=+DEF $P(LST(CNT),U,2)=1 S CNT=CNT+1
223 Q
Note: See TracBrowser for help on using the repository browser.