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

PRCPCUT1.m

Go to the documentation of this file.
  1. PRCPCUT1 ;WISC/RFJ-case cart & instrument kit utilities ; 06/23/2009 2:09 PM
  1. ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. FILENUMB(ITEMDA) ; return file number for item
  1. I $D(^PRCP(445.7,+ITEMDA,0)) Q 445.7
  1. I $D(^PRCP(445.8,+ITEMDA)) Q 445.8
  1. Q 0
  1. ;
  1. ;
  1. CHECK(INVPT,NOWRITE) ; check inventory point keeping perpetual and history
  1. ; if $g(nowrite)=1 do not write information on screen
  1. ; return 1 if keep perpetual or keep tran reg is no
  1. N %,PRCPFLAG
  1. S %=$G(^PRCP(445,+INVPT,0)),PRCPFLAG=0
  1. I $P(%,"^",2)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A PERPETUAL INVENTORY'." S PRCPFLAG=1
  1. I $P(%,"^",6)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A DETAILED TRANSACTION HISTORY'." S PRCPFLAG=1
  1. Q PRCPFLAG
  1. ;
  1. ;
  1. ADDCCIK(INVPT,CCIKITEM,ITEMDA,QUANTITY) ; add case cart or instrument kit
  1. ; add itemda to ccikitem in invpt with quantity
  1. N D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
  1. I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,0)) Q
  1. I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,8,0)) S ^(0)="^445.121IP^^"
  1. S DIC="^PRCP(445,"_INVPT_",1,"_CCIKITEM_",8,",DIC(0)="L",DLAYGO=445,DA(2)=INVPT,DA(1)=CCIKITEM,(X,DINUM)=ITEMDA
  1. S DIC("DR")="1////"_QUANTITY
  1. D FILE^DICN
  1. Q
  1. ;
  1. ;
  1. GETDEF(FILE,ITEMDA) ; get definition of items in cc (file=445.7) or ik (file=445.8)
  1. ; return:
  1. ; ^tmp($j,"prcplist",itemda)=qty <- both reusable and disposable
  1. ; ^tmp($j,"prcplist-disp",itemda)=qty <- disposables only
  1. N %,QTY
  1. K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP")
  1. 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
  1. Q
  1. ;
  1. ;
  1. QUANTITY(HIGHNUM,TYPE) ; enter quantity to assemble or disassemble
  1. ; highnum=high range
  1. ; type='A'ssemble or 'D'isassemble
  1. N DIR,X,Y
  1. S DIR(0)="NA^0:"_HIGHNUM_":0",DIR("A")=" QUANTITY TO "_$S(TYPE="A":"ASSEMBLE",1:"DISASSEMBLE")_": ",DIR("B")=1
  1. S DIR("A",1)="Enter the quantity of case carts to "_$S(TYPE="A":"assemble",1:"disassemble")_" from 0 to "_HIGHNUM_"."
  1. D ^DIR K DIR
  1. Q $S(Y<1:0,1:+Y)
  1. ;
  1. ;da - ien of file #81
  1. ;prcdt - fileman date (or date.time)
  1. ICPT(DA,PRCDT) ; ef - return icpt code and name
  1. QUIT $P($$CPT^ICPTCOD(DA,$G(PRCDT),"",""),U,2,3)