| [613] | 1 | PRCPCUT1 ;WISC/RFJ-case cart & instrument kit utilities ;01 Sep 93
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | FILENUMB(ITEMDA) ; return file number for item
|
|---|
| 8 | I $D(^PRCP(445.7,+ITEMDA,0)) Q 445.7
|
|---|
| 9 | I $D(^PRCP(445.8,+ITEMDA)) Q 445.8
|
|---|
| 10 | Q 0
|
|---|
| 11 | ;
|
|---|
| 12 | ;
|
|---|
| 13 | CHECK(INVPT,NOWRITE) ; check inventory point keeping perpetual and history
|
|---|
| 14 | ; if $g(nowrite)=1 do not write information on screen
|
|---|
| 15 | ; return 1 if keep perpetual or keep tran reg is no
|
|---|
| 16 | N %,PRCPFLAG
|
|---|
| 17 | S %=$G(^PRCP(445,+INVPT,0)),PRCPFLAG=0
|
|---|
| 18 | I $P(%,"^",2)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A PERPETUAL INVENTORY'." S PRCPFLAG=1
|
|---|
| 19 | I $P(%,"^",6)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A DETAILED TRANSACTION HISTORY'." S PRCPFLAG=1
|
|---|
| 20 | Q PRCPFLAG
|
|---|
| 21 | ;
|
|---|
| 22 | ;
|
|---|
| 23 | ADDCCIK(INVPT,CCIKITEM,ITEMDA,QUANTITY) ; add case cart or instrument kit
|
|---|
| 24 | ; add itemda to ccikitem in invpt with quantity
|
|---|
| 25 | N D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
|
|---|
| 26 | I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,0)) Q
|
|---|
| 27 | I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,8,0)) S ^(0)="^445.121IP^^"
|
|---|
| 28 | S DIC="^PRCP(445,"_INVPT_",1,"_CCIKITEM_",8,",DIC(0)="L",DLAYGO=445,DA(2)=INVPT,DA(1)=CCIKITEM,(X,DINUM)=ITEMDA
|
|---|
| 29 | S DIC("DR")="1////"_QUANTITY
|
|---|
| 30 | D FILE^DICN
|
|---|
| 31 | Q
|
|---|
| 32 | ;
|
|---|
| 33 | ;
|
|---|
| 34 | GETDEF(FILE,ITEMDA) ; get definition of items in cc (file=445.7) or ik (file=445.8)
|
|---|
| 35 | ; return:
|
|---|
| 36 | ; ^tmp($j,"prcplist",itemda)=qty <- both reusable and disposable
|
|---|
| 37 | ; ^tmp($j,"prcplist-disp",itemda)=qty <- disposables only
|
|---|
| 38 | N %,QTY
|
|---|
| 39 | K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP")
|
|---|
| 40 | 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
|
|---|
| 41 | Q
|
|---|
| 42 | ;
|
|---|
| 43 | ;
|
|---|
| 44 | QUANTITY(HIGHNUM,TYPE) ; enter quantity to assemble or disassemble
|
|---|
| 45 | ; highnum=high range
|
|---|
| 46 | ; type='A'ssemble or 'D'isassemble
|
|---|
| 47 | N DIR,X,Y
|
|---|
| 48 | S DIR(0)="NA^0:"_HIGHNUM_":0",DIR("A")=" QUANTITY TO "_$S(TYPE="A":"ASSEMBLE",1:"DISASSEMBLE")_": ",DIR("B")=1
|
|---|
| 49 | S DIR("A",1)="Enter the quantity of case carts to "_$S(TYPE="A":"assemble",1:"disassemble")_" from 0 to "_HIGHNUM_"."
|
|---|
| 50 | D ^DIR K DIR
|
|---|
| 51 | Q $S(Y<1:0,1:+Y)
|
|---|
| 52 | ;
|
|---|
| 53 | ;
|
|---|
| 54 | ICPT(DA) ; return icpt code and name
|
|---|
| 55 | N D0,DIC,DIQ,DR,PRCPX
|
|---|
| 56 | S DIC="^ICPT(",DR=".01;2",DIQ="PRCPX",DIQ(0)="IEN" D EN^DIQ1
|
|---|
| 57 | Q $G(PRCPX(81,DA,.01,"E"))_"^"_$G(PRCPX(81,DA,2,"E"))
|
|---|
