PRCPAWU0 ;WISC/RFJ-adjustment utilities ;11 Mar 94
;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ITEM() ; select item from tmp($j,"prcpawap","item",*itemnumber*) global
N %,COUNT,ITEMDA,PRCPFLAG,X
F D Q:ITEMDA'=""
. W !," Select ITEM: "
. R X:DTIME I '$T!(X["^")!(X="") S ITEMDA="^" Q
. I $D(^TMP($J,"PRCPAWAP","ITEM",+X)) S ITEMDA=+X Q
. S ITEMDA=""
. W !,"Select the ITEM NUMBER from the list below:",!
. S COUNT=0,X="" F S X=$O(^TMP($J,"PRCPAWAP","ITEM",X)) Q:X=""!($G(PRCPFLAG)) D
. . W " ITEM NUMBER: ",X,?23,$E($$DESCR^PRCPUX1(PRCP("I"),+X),1,30),?58,"NSN: ",$$NSN^PRCPUX1(+X) S COUNT=COUNT+1
. . I COUNT#20=0 D P^PRCPUREP S %="",$P(%," ",80)="" W $C(13),%
. . W !
Q ITEMDA
;
;
VOUCHER() ; enter reference voucher number
N DIR,X,Y
S DIR(0)="FA^5:5",DIR("A")=" VOUCHER NUMBER: ",DIR("A",1)=" >> Enter DOCUMENT IDENTIFIER number. <<"
D ^DIR
Q Y
;
;
QTY(LOW,HIGH) ; adjust quantity from low to high
; return qty, qty=^ for ^ entered
N DIR,X,Y
S DIR(0)="NA^"_LOW_":"_HIGH_":0",DIR("A")=" ADJUSTED QUANTITY: ",DIR("B")=0
S DIR("A",1)=" >> Enter the adjusted quantity in the range "_LOW_" to "_HIGH_". <<"
D ^DIR
Q Y
;
;
VALUE(LOW,HIGH,PROMPT,DEFAULT) ; adjust value from low to high
; ask in prompt with default value
N DIR,X,Y
S DIR(0)="NAO^"_LOW_":"_HIGH_":2",DIR("A")=" ADJUSTED TOTAL"_PROMPT_" VALUE: " S:DEFAULT'="" DIR("B")=DEFAULT
S DIR("A",1)=" >> Enter the adjusted value in the range "_LOW_" to "_HIGH_". <<"
D ^DIR
Q Y
;
;
REASON(DEFAULT,NODISV) ; enter reason text
;NODISV=1 will stop default reason from ^DISV
N DIR,REASON,X,Y
I DEFAULT="",'$G(NODISV) S REASON=$G(^DISV(+$G(DUZ),"PRCPAWU0","REASON"))
S DIR(0)="F^1:80",DIR("A")=" REASON TEXT",DIR("B")=$S(DEFAULT=""&'$G(NODISV):$G(REASON),1:DEFAULT)
S DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
D ^DIR
I (DEFAULT=""&'$G(NODISV)),Y'["^" S ^DISV(DUZ,"PRCPAWU0","REASON")=Y
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWU0 2130 printed Oct 16, 2024@18:13:42 Page 2
PRCPAWU0 ;WISC/RFJ-adjustment utilities ;11 Mar 94
+1 ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ITEM() ; select item from tmp($j,"prcpawap","item",*itemnumber*) global
+1 NEW %,COUNT,ITEMDA,PRCPFLAG,X
+2 FOR
Begin DoDot:1
+3 WRITE !," Select ITEM: "
+4 READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET ITEMDA="^"
QUIT
+5 IF $DATA(^TMP($JOB,"PRCPAWAP","ITEM",+X))
SET ITEMDA=+X
QUIT
+6 SET ITEMDA=""
+7 WRITE !,"Select the ITEM NUMBER from the list below:",!
+8 SET COUNT=0
SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"PRCPAWAP","ITEM",X))
if X=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+9 WRITE " ITEM NUMBER: ",X,?23,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),+X),1,30),?58,"NSN: ",$$NSN^PRCPUX1(+X)
SET COUNT=COUNT+1
+10 IF COUNT#20=0
DO P^PRCPUREP
SET %=""
SET $PIECE(%," ",80)=""
WRITE $CHAR(13),%
+11 WRITE !
End DoDot:2
End DoDot:1
if ITEMDA'=""
QUIT
+12 QUIT ITEMDA
+13 ;
+14 ;
VOUCHER() ; enter reference voucher number
+1 NEW DIR,X,Y
+2 SET DIR(0)="FA^5:5"
SET DIR("A")=" VOUCHER NUMBER: "
SET DIR("A",1)=" >> Enter DOCUMENT IDENTIFIER number. <<"
+3 DO ^DIR
+4 QUIT Y
+5 ;
+6 ;
QTY(LOW,HIGH) ; adjust quantity from low to high
+1 ; return qty, qty=^ for ^ entered
+2 NEW DIR,X,Y
+3 SET DIR(0)="NA^"_LOW_":"_HIGH_":0"
SET DIR("A")=" ADJUSTED QUANTITY: "
SET DIR("B")=0
+4 SET DIR("A",1)=" >> Enter the adjusted quantity in the range "_LOW_" to "_HIGH_". <<"
+5 DO ^DIR
+6 QUIT Y
+7 ;
+8 ;
VALUE(LOW,HIGH,PROMPT,DEFAULT) ; adjust value from low to high
+1 ; ask in prompt with default value
+2 NEW DIR,X,Y
+3 SET DIR(0)="NAO^"_LOW_":"_HIGH_":2"
SET DIR("A")=" ADJUSTED TOTAL"_PROMPT_" VALUE: "
if DEFAULT'=""
SET DIR("B")=DEFAULT
+4 SET DIR("A",1)=" >> Enter the adjusted value in the range "_LOW_" to "_HIGH_". <<"
+5 DO ^DIR
+6 QUIT Y
+7 ;
+8 ;
REASON(DEFAULT,NODISV) ; enter reason text
+1 ;NODISV=1 will stop default reason from ^DISV
+2 NEW DIR,REASON,X,Y
+3 IF DEFAULT=""
IF '$GET(NODISV)
SET REASON=$GET(^DISV(+$GET(DUZ),"PRCPAWU0","REASON"))
+4 SET DIR(0)="F^1:80"
SET DIR("A")=" REASON TEXT"
SET DIR("B")=$SELECT(DEFAULT=""&'$GET(NODISV):$GET(REASON),1:DEFAULT)
+5 SET DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
+6 DO ^DIR
+7 IF (DEFAULT=""&'$GET(NODISV))
IF Y'["^"
SET ^DISV(DUZ,"PRCPAWU0","REASON")=Y
+8 QUIT Y
