source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREV1.m

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1OREV1 ;SLC/DAN Event delayed orders set up continued ;1/14/03 11:54
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**142,141,165**;Dec 17, 1997
3 ;DBIA reference section
4 ;2686 - ^XTV(8989.5 and ^XTV(8989.51
5 ;519 - ^DIC(45.7
6 ;2263 - XPAR
7 ;10039- ^DIC(42
8 ;10009- DICN
9 ;10018- DIE
10 ;10026- DIR
11 ;10116- VALM1
12 ;10103- XLFDT
13SCR ;Sets DIC("S") for MAS MOVEMENT TYPE field of either file
14 N FILE
15 S FILE="^ORD("_$O(DR(1,0))_","
16 S DIC("S")="S TMP=$P("_FILE_"DA,0),U,2),TTP=$E($P(^DG(405.3,$P(^DG(405.2,Y,0),U,2),0),U)) I $S(TMP=TTP:1,1:0)"_$S('$G(@(FILE_DA_",1)")):"&('$$INUSEDC^OREV1())",1:"")
17 Q
18 ;
19ACT ;Inactivate or reactivate an event or auto dc rule
20 N ORJ,Y,ORTMP,DA,DIC,ORGLOB
21 S VALMBCK="R" D FULL^VALM1
22 S ORGLOB="^ORD(100."_$S(ORTYPE="E":"5,",1:"6,")
23 I $G(ORNMBR)="" S ORNMBR=$$ORDERS("activate/inactivate")
24 F ORJ=1:1:$L(ORNMBR,",")-1 S ORTMP=$P(ORNMBR,",",ORJ),DA=$O(^TMP("OREDO",$J,"IDX",ORTMP,0)) D FLIP(DA)
25 Q
26 ;
27FLIP(DA) ;Check status and flip if necessary
28 N STAT,DIR,DIE,DR,Y,NAME,CDT,MULT,IEN,SUB,USED,EVNTYPE
29 S NAME=$P(@(ORGLOB_DA_",0)"),U),EVNTYPE=$P(^(0),U,2)
30 S CDT=$$NOW^XLFDT
31 S STAT=$S($G(@(ORGLOB_DA_",1)")):^(1),1:0) ;Status is date/time if already inactivated
32 W !!,NAME," is currently ",$S(STAT:"IN",1:"")_"ACTIVE."
33 I ORTYPE="E",$$RELEVNTS(DA),'STAT W !!,"There are delayed orders awaiting release that are associated with this event.",!,"This event, even if inactivated, will still be applied to these delayed orders.",!!
34 I ORTYPE="A",'STAT W !!,"Inactivating auto-dc rules takes effect immediately.",!
35 I STAT,$G(EVNTYPE)="O",$$ACTSURG^OREV4(ORTYPE,DA) D Q
36 .W !,NAME,!,"can not be activated because you already have an active surgery rule for this",!,"division. Only one active surgery rule per division is allowed.",!
37 .S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
38 I STAT,ORTYPE="E",$P($G(^ORD(100.5,DA,0)),U,12),$G(^ORD(100.5,$P(^(0),U,12),1)) D Q ;If inactive child event and parent is inactive don't activate child
39 .W !,NAME,!,"can not be activated until its parent event is active.",!
40 .S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
41 I STAT,ORTYPE="E",'$$CANACT(DA,.USED) D Q
42 .W !,NAME,!,"can not be activated because the following locations",!,"and/or treating specialties are currently in use by other entries.",!
43 .F MULT="LOC","TS" W:$D(USED(MULT)) !,$S(MULT="LOC":"LOCATIONS:",1:"TREATING SPECIALTIES:"),! D
44 ..S IEN=0 F S IEN=$O(USED(MULT,IEN)) Q:'+IEN D
45 ...S SUB=0 F S SUB=$O(USED(MULT,IEN,SUB)) Q:'+SUB D
46 ....W !,$S(MULT="LOC":$P($G(^DIC(42,SUB,0)),"^"),1:$P($G(^DIC(45.7,SUB,0)),"^"))," is in use by ",$P($G(@(ORGLOB_IEN_",0)")),"^"),!
47 .W !,"For active entries, LOCATIONS and TREATING SPECIALTIES",!,"must be unique within division and event type."
48 .S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
49 I STAT I ORTYPE="A" I '$$CANACT(DA,.USED) D Q
50 .W !,NAME,!,"can not be activated because the following MAS movements",!,"are currently in use by other entries.",!
51 .S IEN=0 F S IEN=$O(USED(IEN)) Q:'+IEN D
52 ..S SUB=0 F S SUB=$O(USED(IEN,SUB)) Q:'+SUB D
53 ...W !,$P($G(^DG(405.2,IEN,0)),U)," is in use by ",$P($G(^ORD(100.6,SUB,0)),U)
54 .W !,"For active entries, MAS movements within DIVISION must be unique."
55 .S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
56 ;
57 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to "_$S(STAT:"",1:"IN")_"ACTIVATE this entry" D ^DIR
58 I Y'=1 W !,"Nothing changed!" Q
59 S DIE=ORGLOB,DR="1///"_$S(STAT:"@",1:CDT) D ^DIE W !,NAME," is now "_$S(STAT:"",1:"IN")_"ACTIVATED!"
60 I 'STAT S DA(1)=DA,DA=$O(@(ORGLOB_DA(1)_",2,"_"""ACT"""_",0)")),DIE=ORGLOB_DA(1)_",2,",DR="1///"_CDT D ^DIE D:ORTYPE="E" UPDTCHLD^OREV3(DA(1),CDT) Q
61 D SET(DA,CDT)
62 Q
63 ;
64SET(MIEN,X) ;add new multiple to activation history
65 N DIC,DA
66 S DA(1)=MIEN
67 S DIC=ORGLOB_DA(1)_",2,",DIC(0)="L"
68 D FILE^DICN
69 Q
70 ;
71INUSE(MULT) ;determine if location or treating specialty is already in use
72 N ACTIVE,USED,NAME,TYPE,DIV,FMIEN
73 S USED=0,NAME="",FMIEN=$G(DA(1),DA)
74 S TYPE=$P($G(^ORD(100.5,FMIEN,0)),"^",2) ;movement type of entry being checked
75 S DIV=$P($G(^ORD(100.5,FMIEN,0)),"^",3) ;division of entry being checked
76 F S NAME=$O(^ORD(100.5,"C",NAME)) Q:NAME=""!(USED) D
77 .S ACTIVE=0 F S ACTIVE=$O(^ORD(100.5,"C",NAME,ACTIVE)) Q:'+ACTIVE!USED D
78 ..Q:DIV'=$P($G(^ORD(100.5,ACTIVE,0)),"^",3) ;stop processing if not same division
79 ..Q:TYPE'=$P($G(^ORD(100.5,ACTIVE,0)),"^",2) ;stop processing if not the same type
80 ..S USED=$D(^ORD(100.5,ACTIVE,MULT,"B",Y)) I USED S WHO=ACTIVE
81 Q USED
82 ;
83CANACT(DA,USED) ;Function returns whether or not an entry can be activated.
84 ;For EVENTS, locations and specialties must be unique within division
85 ;and EVENT TYPE. For AUTO DC, movement types must be unique within
86 ;division.
87 N MULT,SUB,Y,CANACT,WHO
88 S CANACT=1
89 I ORTYPE="E" F MULT="LOC","TS" D
90 .S SUB=0 F S SUB=$O(^ORD(100.5,DA,MULT,SUB)) Q:'+SUB D
91 ..S Y=$G(^(SUB,0)) I Y I $$INUSE(MULT) S CANACT=0,USED(MULT,WHO,Y)=""
92 ;
93 I ORTYPE="A" D
94 .S SUB=0 F S SUB=$O(^ORD(100.6,DA,3,SUB)) Q:'+SUB D
95 ..S Y=+$G(^(SUB,0)) I Y I $$INUSEDC() S CANACT=0,USED(Y,WHO)=""
96 Q CANACT
97 ;
98INUSEDC() ;Checks AUTO-DC rules for unique movement types
99 N DIV,USED
100 S USED=0
101 S DIV=+$P($G(^ORD(100.6,DA,0)),U,3)
102 I DIV I $D(^ORD(100.6,"AC",DIV,Y)) S WHO=$O(^(Y,0)),USED=1
103 Q USED
104 ;
105HASREQD() ;Function returns whether entry has required entries or not
106 N REQD
107 S REQD=0
108 I ORTYPE="E" D
109 .I "^22^23^24^"[("^"_$P($G(^ORD(100.5,DA,0)),U,7)_"^") S REQD=1 Q ;From pass (transfer) doesn't require treating specialty
110 .I $O(^ORD(100.5,DA,"LOC",0))>0!($O(^ORD(100.5,DA,"TS",0))>0) S REQD=1 ;Has locations or treating specialties
111 .I $O(^ORD(100.5,DA,"LOC",0))>0&($O(^ORD(100.5,DA,"TS",0))>0) S REQD=2 ;Warn user that both must be true if both defined.
112 I ORTYPE="A" D
113 .I $P($G(^ORD(100.6,DA,0)),U,2)="O" S REQD=1 ;If type is operating room then movements not required
114 .I $P($G(^ORD(100.6,DA,0)),U,2)'="O"&($O(^ORD(100.6,DA,3,0))>0) S REQD=1 ;movement type exists
115 .I $P($G(^ORD(100.6,DA,0)),U,2)="T",$D(^ORD(100.6,DA,3,"B",4)),$P($G(^ORD(100.6,DA,3,0)),U,4)>1 S REQD=2 ;If transfer type and interward transfer type not by itself
116 Q REQD
117 ;
118CHKTYP(IEN) ;Check type of event and delete fields that are no longer needed based on the event type
119 N J,DR,DIE,DA,DIC,TYPE
120 I ORTYPE="E" D Q
121 .S TYPE=$P(^ORD(100.5,IEN,0),U,2)
122 .I TYPE'="A"&(TYPE'="T") D DELMUL(100.5,IEN,"""LOC"""),DELMUL(100.5,IEN,"""TS""") ;if not admit or transfer delete locations and treating specialties
123 .S DA=IEN,DIE=100.5,DR="7///@" D ^DIE ;Delete MAS MOVEMENT when type changes as movement types are associated with event type
124 ;If not event type must be auto-dc
125 S TYPE=$P(^ORD(100.6,IEN,0),U,2)
126 I TYPE'="D" S DA=IEN,DIE=100.6,DR="6///@" D ^DIE ;Delete 'except from observation" if not discharge type
127 D DELMUL(100.6,IEN,3) ;delete MAS MOVEMENT
128 I TYPE'="S" D DELMUL(100.6,IEN,4) ;If not specialty type delete excluded treating specialties
129 I TYPE'="T" D DELMUL(100.6,IEN,5),DELMUL(100.6,IEN,6) ;If not transfer type delete included locations and included divisions
130 Q
131 ;
132ORDERS(ACTION) ; -- Return order numbers to act on, if action chosen first
133 N X,Y,DIR,MAX
134 S MAX=$G(VALMCNT) Q:MAX'>0 ""
135 I ACTION="edit" W !!,"Enter item number to edit or press enter to create a new entry"
136 S DIR(0)="LAO^1:"_MAX,DIR("A")="Select item(s): "
137 S DIR("?")="Enter the items you wish to "_ACTION_", as a range or list of numbers."_$S(ACTION="edit":" Press enter to create a NEW entry",1:"")
138 D ^DIR S:$D(DTOUT) Y="^"
139 I $D(Y(1)) W !,">>>Too many entries selected, try using smaller ranges" H 2 S Y="^"
140 Q Y
141 ;
142 ;
143CANDEL(FILE) ;Determines if event or rule can be deleted
144 N DEL,EVENT,LIST,I,J
145 S DEL=1
146 S EVENT=$O(^XTV(8989.51,"B","ORWDX WRITE ORDERS EVENT LIST",0))
147 S LIST=$O(^XTV(8989.51,"B","OREVNT COMMON LIST",0))
148 I FILE=100.5 D
149 .I $O(^ORE(100.2,"E",DA,0)) W !,"< Can't delete this event because file 100.2 is pointing to it > " S DEL=0 Q
150 .I $D(^ORD(100.5,"DAD",DA)) W !,"< Can't delete parent events that have children > " S DEL=0 Q
151 .S FND=0
152 .K LST D ENVAL^XPAR(.LST,LIST)
153 .S I="" F S I=$O(LST(I)) Q:I=""!(FND) D
154 ..S J="" F S J=$O(LST(I,J)) Q:J=""!(FND) I LST(I,J)=DA S FND=1
155 .I 'FND K LST D ENVAL^XPAR(.LST,EVENT) D
156 ..S I="" F S I=$O(LST(I)) Q:I=""!(FND) D
157 ...S J="" F S J=$O(LST(I,J)) Q:J=""!(FND) I DA=J S FND=1
158 .I FND W !,"< Can't delete event because parameters are pointing to it > " S DEL=0
159 ;
160 I FILE=100.6 D
161 .I $O(^ORE(100.2,"DC",DA,0)) S DEL=0 W !,"< Can't delete this rule because file 100.2 is pointing to it > " Q
162 ;
163 Q 'DEL ;Reverse value of DEL so that $T is set correctly for fileman to determine if entry can be deleted. Code is in ^DD(file#,.01,"DEL",.01,0)
164 ;
165ASKOBS() ;Function to determine if 'except from observation' field should be asked.
166 N ANS
167 S ANS=1
168 I ETYPE="D" I $D(^ORD(100.6,DA,3,"B",12))!($D(^ORD(100.6,DA,3,"B",38))) S ANS=0 ;Don't ask if MAS MOVEMENT TYPE is 12 (death) or 38 (death with autopsy)
169 I ETYPE="T" I '$D(^ORD(100.6,DA,3,"B",14)) S ANS=0 ;If MAS MOVEMENT TYPE doesn't contain FROM ASIH (VAH) when type is transfer then don't ask
170 Q ANS
171 ;
172DELMUL(FILE,IEN,LOC) ;Delete multiple entries for entry IEN in file FILE stored at location LOC
173 N I,DR,DIE,DA,DIC,GLOB,Y,DQ,DP,DL,DM,DI,DK
174 S GLOB="^ORD("_FILE_","_IEN_","
175 S I=0 F S I=$O(@(GLOB_LOC_","_I_")")) Q:'+I S DA(1)=IEN,DA=I,DR=".01///@",DIE="^ORD("_FILE_",DA(1),"_LOC_"," D ^DIE
176 Q
177 ;
178RELEVNTS(DA) ;Check to see if release event is currently being pointed to
179 N DFN,EVENT
180 S (DFN,EVENT)=0
181 F S DFN=$O(^ORE(100.2,"AE",DFN)) Q:'+DFN I $D(^ORE(100.2,"AE",DFN,DA)) S EVENT=1 Q
182 Q EVENT
Note: See TracBrowser for help on using the repository browser.