source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPEITG.m@ 623

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1PRCPEITG ;WOIFO/CC-enter/edit inventory items (On-Demand) ; 11/6/06 9:56am
2 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6 ;
7ODI(PRCPINPT,PRCPITEM) ; ask On-Demand and reason if appropriate, save data
8 ;
9 ; PRCPINPT inventory point ien
10 ; PRCPITEM ien of the selected item
11 ;
12 N DIR,DIRUT,DIROUT,DTOUT,DUOUT,PRCPARRY,PRCPEDIT,PRCPIEN,PRCPONN,PRCPONO,PRCPREAS,Y
13 S PRCPONO=$P(^PRCP(445,+PRCPINPT,1,+PRCPITEM,0),"^",30) ; O-D Flag
14 I PRCPONO'="Y" S PRCPONO="N" ; if no value is defined, O-D Flag is No
15 ; Can user edit this On-Demand setting?
16 S PRCPEDIT=0
17 I $D(^PRCP(445,+PRCPINPT,9,"B",DUZ)) S PRCPEDIT=1 ; authorized user
18 ;
19 ; Display On-Demand value. If user is not authorized,
20 ; display << not editable >> , pause and exit
21 I 'PRCPEDIT D EN^DDIOL("ON-DEMAND: "_$S(PRCPONO="N":"NO",1:"YES")_"// <<may not edit>>") D R^PRCPUREP Q
22 ; if user can edit value, proceed with prompting
23YN S DIR(0)="Y",DIR("A")="ON-DEMAND",DIR("B")=PRCPONO
24 S DIR("?",1)="Enter 'Y'es for low usage items qualifying to be On-Demand"
25 S DIR("?")=" 'N'o for routinely used (standard) items"
26 D ^DIR K DIR
27 ; prompt user, default to value on file
28 ; if user up-arrows or times out, exit
29 I $D(DUOUT)!$D(DTOUT) G NOCHANGE
30 I Y'=0,Y'=1 W "??" G YN
31 I Y=1 S PRCPONN="Y"
32 I Y=0 S PRCPONN="N"
33 ; if new value agrees with current setting, exit
34 I PRCPONN=PRCPONO Q ; no additional processing required
35 ;
36 ; prompt user for reason
37RS S DIR(0)="F^3:30",DIR("A")="REASON FOR CHANGE"
38 S DIR("?")="Enter 3 - 30 characters with no embedded '^' and no leading spaces"
39 ; if user enters '^', all spaces or just hits return, tell user setting will not be changed - no reason entered, prompt On-Demand again.
40 D ^DIR K DIR
41 I $D(DUOUT)!$D(DTOUT) G NOCHANGE
42 F Q:$E(Y,1)'=" " S Y=$E(Y,2,$L(Y))
43 I Y']"" W "??" G RS
44 S PRCPREAS=Y
45 ;
46 ; save new setting, date/time, DUZ, reason in audit file
47 S PRCPIEN="+1,"_+PRCPITEM_","_+PRCPINPT_","
48 S PRCPARRY(445.13,PRCPIEN,.01)=$$NOW^XLFDT
49 S PRCPARRY(445.13,PRCPIEN,1)=DUZ
50 S PRCPARRY(445.13,PRCPIEN,2)=PRCPREAS
51 S PRCPARRY(445.13,PRCPIEN,3)=PRCPONN
52 D UPDATE^DIE("","PRCPARRY")
53 I $D(^TMP("DIERR",$J)) W "NOTHING SAVED" ; likely system or space err
54 ;
55 ; Save new setting into field .8
56 S PRCPIEN=+PRCPITEM_","_+PRCPINPT_","
57 K PRCPARRY S PRCPARRY(445.01,PRCPIEN,.8)=PRCPONN
58 D UPDATE^DIE("","PRCPARRY")
59 I $D(^TMP("DIERR",$J)) W "NOTHING SAVED" ; likely system or space err
60OD Q
61 ;
62NOCHANGE D EN^DDIOL("NO DATA UPDATED. VALID RESPONSE AND/OR REASON NOT ENTERED.")
63 D R^PRCPUREP
64 Q
Note: See TracBrowser for help on using the repository browser.