Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPAWU0

PRCPAWU0.m

Go to the documentation of this file.
  1. PRCPAWU0 ;WISC/RFJ-adjustment utilities ;11 Mar 94
  1. ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. ITEM() ; select item from tmp($j,"prcpawap","item",*itemnumber*) global
  1. N %,COUNT,ITEMDA,PRCPFLAG,X
  1. F D Q:ITEMDA'=""
  1. . W !," Select ITEM: "
  1. . R X:DTIME I '$T!(X["^")!(X="") S ITEMDA="^" Q
  1. . I $D(^TMP($J,"PRCPAWAP","ITEM",+X)) S ITEMDA=+X Q
  1. . S ITEMDA=""
  1. . W !,"Select the ITEM NUMBER from the list below:",!
  1. . S COUNT=0,X="" F S X=$O(^TMP($J,"PRCPAWAP","ITEM",X)) Q:X=""!($G(PRCPFLAG)) D
  1. . . W " ITEM NUMBER: ",X,?23,$E($$DESCR^PRCPUX1(PRCP("I"),+X),1,30),?58,"NSN: ",$$NSN^PRCPUX1(+X) S COUNT=COUNT+1
  1. . . I COUNT#20=0 D P^PRCPUREP S %="",$P(%," ",80)="" W $C(13),%
  1. . . W !
  1. Q ITEMDA
  1. ;
  1. ;
  1. VOUCHER() ; enter reference voucher number
  1. N DIR,X,Y
  1. S DIR(0)="FA^5:5",DIR("A")=" VOUCHER NUMBER: ",DIR("A",1)=" >> Enter DOCUMENT IDENTIFIER number. <<"
  1. D ^DIR
  1. Q Y
  1. ;
  1. ;
  1. QTY(LOW,HIGH) ; adjust quantity from low to high
  1. ; return qty, qty=^ for ^ entered
  1. N DIR,X,Y
  1. S DIR(0)="NA^"_LOW_":"_HIGH_":0",DIR("A")=" ADJUSTED QUANTITY: ",DIR("B")=0
  1. S DIR("A",1)=" >> Enter the adjusted quantity in the range "_LOW_" to "_HIGH_". <<"
  1. D ^DIR
  1. Q Y
  1. ;
  1. ;
  1. VALUE(LOW,HIGH,PROMPT,DEFAULT) ; adjust value from low to high
  1. ; ask in prompt with default value
  1. N DIR,X,Y
  1. S DIR(0)="NAO^"_LOW_":"_HIGH_":2",DIR("A")=" ADJUSTED TOTAL"_PROMPT_" VALUE: " S:DEFAULT'="" DIR("B")=DEFAULT
  1. S DIR("A",1)=" >> Enter the adjusted value in the range "_LOW_" to "_HIGH_". <<"
  1. D ^DIR
  1. Q Y
  1. ;
  1. ;
  1. REASON(DEFAULT,NODISV) ; enter reason text
  1. ;NODISV=1 will stop default reason from ^DISV
  1. N DIR,REASON,X,Y
  1. I DEFAULT="",'$G(NODISV) S REASON=$G(^DISV(+$G(DUZ),"PRCPAWU0","REASON"))
  1. S DIR(0)="F^1:80",DIR("A")=" REASON TEXT",DIR("B")=$S(DEFAULT=""&'$G(NODISV):$G(REASON),1:DEFAULT)
  1. S DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
  1. D ^DIR
  1. I (DEFAULT=""&'$G(NODISV)),Y'["^" S ^DISV(DUZ,"PRCPAWU0","REASON")=Y
  1. Q Y