PRCPEITG ;WOIFO/CC-enter/edit inventory items (On-Demand) ; 11/6/06 9:56am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
ODI(PRCPINPT,PRCPITEM) ; ask On-Demand and reason if appropriate, save data
;
; PRCPINPT inventory point ien
; PRCPITEM ien of the selected item
;
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,PRCPARRY,PRCPEDIT,PRCPIEN,PRCPONN,PRCPONO,PRCPREAS,Y
S PRCPONO=$P(^PRCP(445,+PRCPINPT,1,+PRCPITEM,0),"^",30) ; O-D Flag
I PRCPONO'="Y" S PRCPONO="N" ; if no value is defined, O-D Flag is No
; Can user edit this On-Demand setting?
S PRCPEDIT=0
I $D(^PRCP(445,+PRCPINPT,9,"B",DUZ)) S PRCPEDIT=1 ; authorized user
;
; Display On-Demand value. If user is not authorized,
; display << not editable >> , pause and exit
I 'PRCPEDIT D EN^DDIOL("ON-DEMAND: "_$S(PRCPONO="N":"NO",1:"YES")_"// <<may not edit>>") D R^PRCPUREP Q
; if user can edit value, proceed with prompting
YN S DIR(0)="Y",DIR("A")="ON-DEMAND",DIR("B")=PRCPONO
S DIR("?",1)="Enter 'Y'es for low usage items qualifying to be On-Demand"
S DIR("?")=" 'N'o for routinely used (standard) items"
D ^DIR K DIR
; prompt user, default to value on file
; if user up-arrows or times out, exit
I $D(DUOUT)!$D(DTOUT) G NOCHANGE
I Y'=0,Y'=1 W "??" G YN
I Y=1 S PRCPONN="Y"
I Y=0 S PRCPONN="N"
; if new value agrees with current setting, exit
I PRCPONN=PRCPONO Q ; no additional processing required
;
; prompt user for reason
RS S DIR(0)="F^3:30",DIR("A")="REASON FOR CHANGE"
S DIR("?")="Enter 3 - 30 characters with no embedded '^' and no leading spaces"
; if user enters '^', all spaces or just hits return, tell user setting will not be changed - no reason entered, prompt On-Demand again.
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G NOCHANGE
F Q:$E(Y,1)'=" " S Y=$E(Y,2,$L(Y))
I Y']"" W "??" G RS
S PRCPREAS=Y
;
; save new setting, date/time, DUZ, reason in audit file
S PRCPIEN="+1,"_+PRCPITEM_","_+PRCPINPT_","
S PRCPARRY(445.13,PRCPIEN,.01)=$$NOW^XLFDT
S PRCPARRY(445.13,PRCPIEN,1)=DUZ
S PRCPARRY(445.13,PRCPIEN,2)=PRCPREAS
S PRCPARRY(445.13,PRCPIEN,3)=PRCPONN
D UPDATE^DIE("","PRCPARRY")
I $D(^TMP("DIERR",$J)) W "NOTHING SAVED" ; likely system or space err
;
; Save new setting into field .8
S PRCPIEN=+PRCPITEM_","_+PRCPINPT_","
K PRCPARRY S PRCPARRY(445.01,PRCPIEN,.8)=PRCPONN
D UPDATE^DIE("","PRCPARRY")
I $D(^TMP("DIERR",$J)) W "NOTHING SAVED" ; likely system or space err
OD Q
;
NOCHANGE D EN^DDIOL("NO DATA UPDATED. VALID RESPONSE AND/OR REASON NOT ENTERED.")
D R^PRCPUREP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEITG 2631 printed Nov 22, 2024@17:23:47 Page 2
PRCPEITG ;WOIFO/CC-enter/edit inventory items (On-Demand) ; 11/6/06 9:56am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ODI(PRCPINPT,PRCPITEM) ; ask On-Demand and reason if appropriate, save data
+1 ;
+2 ; PRCPINPT inventory point ien
+3 ; PRCPITEM ien of the selected item
+4 ;
+5 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,PRCPARRY,PRCPEDIT,PRCPIEN,PRCPONN,PRCPONO,PRCPREAS,Y
+6 ; O-D Flag
SET PRCPONO=$PIECE(^PRCP(445,+PRCPINPT,1,+PRCPITEM,0),"^",30)
+7 ; if no value is defined, O-D Flag is No
IF PRCPONO'="Y"
SET PRCPONO="N"
+8 ; Can user edit this On-Demand setting?
+9 SET PRCPEDIT=0
+10 ; authorized user
IF $DATA(^PRCP(445,+PRCPINPT,9,"B",DUZ))
SET PRCPEDIT=1
+11 ;
+12 ; Display On-Demand value. If user is not authorized,
+13 ; display << not editable >> , pause and exit
+14 IF 'PRCPEDIT
DO EN^DDIOL("ON-DEMAND: "_$SELECT(PRCPONO="N":"NO",1:"YES")_"// <<may not edit>>")
DO R^PRCPUREP
QUIT
+15 ; if user can edit value, proceed with prompting
YN SET DIR(0)="Y"
SET DIR("A")="ON-DEMAND"
SET DIR("B")=PRCPONO
+1 SET DIR("?",1)="Enter 'Y'es for low usage items qualifying to be On-Demand"
+2 SET DIR("?")=" 'N'o for routinely used (standard) items"
+3 DO ^DIR
KILL DIR
+4 ; prompt user, default to value on file
+5 ; if user up-arrows or times out, exit
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO NOCHANGE
+7 IF Y'=0
IF Y'=1
WRITE "??"
GOTO YN
+8 IF Y=1
SET PRCPONN="Y"
+9 IF Y=0
SET PRCPONN="N"
+10 ; if new value agrees with current setting, exit
+11 ; no additional processing required
IF PRCPONN=PRCPONO
QUIT
+12 ;
+13 ; prompt user for reason
RS SET DIR(0)="F^3:30"
SET DIR("A")="REASON FOR CHANGE"
+1 SET DIR("?")="Enter 3 - 30 characters with no embedded '^' and no leading spaces"
+2 ; if user enters '^', all spaces or just hits return, tell user setting will not be changed - no reason entered, prompt On-Demand again.
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO NOCHANGE
+5 FOR
if $EXTRACT(Y,1)'=" "
QUIT
SET Y=$EXTRACT(Y,2,$LENGTH(Y))
+6 IF Y']""
WRITE "??"
GOTO RS
+7 SET PRCPREAS=Y
+8 ;
+9 ; save new setting, date/time, DUZ, reason in audit file
+10 SET PRCPIEN="+1,"_+PRCPITEM_","_+PRCPINPT_","
+11 SET PRCPARRY(445.13,PRCPIEN,.01)=$$NOW^XLFDT
+12 SET PRCPARRY(445.13,PRCPIEN,1)=DUZ
+13 SET PRCPARRY(445.13,PRCPIEN,2)=PRCPREAS
+14 SET PRCPARRY(445.13,PRCPIEN,3)=PRCPONN
+15 DO UPDATE^DIE("","PRCPARRY")
+16 ; likely system or space err
IF $DATA(^TMP("DIERR",$JOB))
WRITE "NOTHING SAVED"
+17 ;
+18 ; Save new setting into field .8
+19 SET PRCPIEN=+PRCPITEM_","_+PRCPINPT_","
+20 KILL PRCPARRY
SET PRCPARRY(445.01,PRCPIEN,.8)=PRCPONN
+21 DO UPDATE^DIE("","PRCPARRY")
+22 ; likely system or space err
IF $DATA(^TMP("DIERR",$JOB))
WRITE "NOTHING SAVED"
OD QUIT
+1 ;
NOCHANGE DO EN^DDIOL("NO DATA UPDATED. VALID RESPONSE AND/OR REASON NOT ENTERED.")
+1 DO R^PRCPUREP
+2 QUIT
