PRCPCUT1 ;WISC/RFJ-case cart & instrument kit utilities             ;01 Sep 93
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
 ;
FILENUMB(ITEMDA) ;  return file number for item
 I $D(^PRCP(445.7,+ITEMDA,0)) Q 445.7
 I $D(^PRCP(445.8,+ITEMDA)) Q 445.8
 Q 0
 ;
 ;
CHECK(INVPT,NOWRITE) ;  check inventory point keeping perpetual and history
 ;  if $g(nowrite)=1 do not write information on screen
 ;  return 1 if keep perpetual or keep tran reg is no
 N %,PRCPFLAG
 S %=$G(^PRCP(445,+INVPT,0)),PRCPFLAG=0
 I $P(%,"^",2)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A PERPETUAL INVENTORY'." S PRCPFLAG=1
 I $P(%,"^",6)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A DETAILED TRANSACTION HISTORY'." S PRCPFLAG=1
 Q PRCPFLAG
 ;
 ;
ADDCCIK(INVPT,CCIKITEM,ITEMDA,QUANTITY) ;  add case cart or instrument kit
 ;  add itemda to ccikitem in invpt with quantity
 N D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
 I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,0)) Q
 I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,8,0)) S ^(0)="^445.121IP^^"
 S DIC="^PRCP(445,"_INVPT_",1,"_CCIKITEM_",8,",DIC(0)="L",DLAYGO=445,DA(2)=INVPT,DA(1)=CCIKITEM,(X,DINUM)=ITEMDA
 S DIC("DR")="1////"_QUANTITY
 D FILE^DICN
 Q
 ;
 ;
GETDEF(FILE,ITEMDA) ;  get definition of items in cc (file=445.7) or ik (file=445.8)
 ;  return:
 ;  ^tmp($j,"prcplist",itemda)=qty      <- both reusable and disposable
 ;  ^tmp($j,"prcplist-disp",itemda)=qty <- disposables only
 N %,QTY
 K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP")
 S %=0 F  S %=$O(^PRCP(FILE,ITEMDA,1,%)) Q:'%  S QTY=+$P($G(^PRCP(FILE,ITEMDA,1,%,0)),"^",2),^TMP($J,"PRCPLIST",%)=QTY I '$$REUSABLE^PRCPU441(%) S ^TMP($J,"PRCPLIST-DISP",%)=QTY
 Q
 ;
 ;
QUANTITY(HIGHNUM,TYPE) ;  enter quantity to assemble or disassemble
 ;  highnum=high range
 ;  type='A'ssemble or 'D'isassemble
 N DIR,X,Y
 S DIR(0)="NA^0:"_HIGHNUM_":0",DIR("A")="  QUANTITY TO "_$S(TYPE="A":"ASSEMBLE",1:"DISASSEMBLE")_": ",DIR("B")=1
 S DIR("A",1)="Enter the quantity of case carts to "_$S(TYPE="A":"assemble",1:"disassemble")_" from 0 to "_HIGHNUM_"."
 D ^DIR K DIR
 Q $S(Y<1:0,1:+Y)
 ;
 ;
ICPT(DA) ;  return icpt code and name
 N D0,DIC,DIQ,DR,PRCPX
 S DIC="^ICPT(",DR=".01;2",DIQ="PRCPX",DIQ(0)="IEN" D EN^DIQ1
 Q $G(PRCPX(81,DA,.01,"E"))_"^"_$G(PRCPX(81,DA,2,"E"))