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