PRCPEITG.m

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 ---PRCPEITG   2631     printed  Mar 13, 2025@21:18:29                                                                                                                                                                                                    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