PRCPCRDK ;WISC/RFJ-instrument kit definition ;01 Sep 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N ALLKITS,X
K X S X(1)="The Definition Instrument Kit Report will print a list of selected instrument kits displaying the items and quantities needed to assemble a instrument kit."
S X(2)="The items in the instrument kit are sorted by the sequence number."
D DISPLAY^PRCPUX2(40,79,.X)
D INSTRKIT^PRCPCRU1
I '$O(^TMP($J,"PRCPKITS",0)),'$D(ALLKITS) Q
I $D(ALLKITS) W !!,"NOTE -- This option will use a lot of paper!"
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
. S ZTDESC="Instrument Kit Definition Report",ZTRTN="DQ^PRCPCRDK"
. S ZTSAVE("PRCP*")="",ZTSAVE("ALLKITS")="",ZTSAVE("^TMP($J,""PRCPKITS"",")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N IKITEM,PRCPFLAG,SCREEN,X,Y
S SCREEN=$$SCRPAUSE^PRCPUREP
I $D(ALLKITS) S IKITEM=0 F S IKITEM=$O(^PRCP(445.8,IKITEM)) Q:'IKITEM!($G(PRCPFLAG)) D
. D PRINT I $G(PRCPFLAG) Q
. I SCREEN,$O(^PRCP(445.8,IKITEM)) D P^PRCPUREP
;
I '$D(ALLKITS) S IKITEM=0 F S IKITEM=$O(^TMP($J,"PRCPKITS",IKITEM)) Q:'IKITEM D PRINT
Q D ^%ZISC K ^TMP($J,"PRCPKITS"),^TMP($J,"PRCPCRDK")
Q
;
;
PRINT ; print a instrument kit definition
N %,%I,CATALOG,IKDATA,IKDATE,IKLOC,IKNAME,IKUSER,DATA,EDITDATE,EDITUSER,ITEMDA,LOCATION,NOW,ONHAND,PAGE,PRCPINNM,PRCPINPT,REUSABLE,SEQUENCE,VENDOR
; sort by sequence number
K ^TMP($J,"PRCPCRDK")
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.8,IKITEM,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)),^TMP($J,"PRCPCRDK",+$P(DATA,"^",3),ITEMDA)=""
;
S IKDATA=$G(^PRCP(445.8,IKITEM,0))
S PRCPINPT=+$P(IKDATA,"^",2),PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
S IKNAME=$$DESCR^PRCPUX1(PRCPINPT,IKITEM),IKUSER=$$USER^PRCPUREP($P(IKDATA,"^",3)),Y=$P(IKDATA,"^",4) D DD^%DT S IKDATE=Y,EDITUSER=$$USER^PRCPUREP($P(IKDATA,"^",5)),Y=$P(IKDATA,"^",6) D DD^%DT S EDITDATE=Y
S IKLOC=$$STORAGE^PRCPESTO(PRCPINPT,IKITEM),ONHAND=$G(^PRCP(445,PRCPINPT,1,IKITEM,0)),ONHAND=$S(ONHAND="":"NOT STORED IN INVENTORY POINT",1:+$P(ONHAND,"^",7))
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1 U IO D H
S SEQUENCE="" F S SEQUENCE=$O(^TMP($J,"PRCPCRDK",SEQUENCE)) Q:SEQUENCE=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPCRDK",SEQUENCE,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. S DATA=$G(^PRCP(445.8,IKITEM,1,ITEMDA,0)) I DATA="" Q
. S VENDOR=$$MANDSRCE^PRCPU441(ITEMDA),CATALOG=$P($G(^PRC(441,ITEMDA,2,+VENDOR,0)),"^",4) I $E(CATALOG,16)'="" S CATALOG=$E(CATALOG,1,15)_"+"
. S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
. S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA),REUSABLE=$S(REUSABLE:"R",1:"D")
. W !,$J(+$P(DATA,"^",2),7),?10,$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,20),?31,ITEMDA,?38,REUSABLE,?40,VENDOR,?48,CATALOG,?67,$E(LOCATION,1,12)
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I $G(PRCPFLAG) Q
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
W !!,"METHOD OF STERILIZATION : ",$$STERILE(IKITEM)
W !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING(IKITEM)
I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
W !!,"SPECIAL INSTRUCTIONS/REMARKS:"
S X=0 F S X=$O(^PRCP(445.8,IKITEM,2,X)) Q:'X!($G(PRCPFLAG)) S DATA=$G(^(X,0)) D
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W !,DATA
D END^PRCPUREP
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"DEFINITION OF INSTRUMENT KIT REPORT FOR: ",$E(PRCPINNM,1,20),?(80-$L(%)),%
W !?9,"NAME: ",IKNAME," (#",IKITEM,") ",?46,"LOCATION: ",IKLOC
W !?15,"CURRENT QUANTITY ASSEMBLED: ",ONHAND
W !?3,"CREATED BY: ",IKUSER,?50,"DATE: ",IKDATE
W !?1,"LAST EDIT BY: ",EDITUSER,?50,"DATE: ",EDITDATE
S %="",$P(%,"-",81)=""
W !,$J("QTY",7),?10,"DESCRIPTION",?31,"MI#",?37,"RD",?40,"VEND#",?48,"CATALOG#",?67,"LOCATION",!,%
Q
;
;
STERILE(V1) ; return method of sterilization for ik v1
N %
S %=$P($G(^PRCP(445.8,+V1,0)),"^",7) I %'="" S %=$P($P($P(^DD(445.8,11,0),"^",3),%_":",2),";")
Q %
;
;
WRAPPING(V1) ; return method of wrapping for ik v1
N %
S %=$P($G(^PRCP(445.8,+V1,0)),"^",8) I %'="" S %=$P($P($P(^DD(445.8,12,0),"^",3),%_":",2),";")
Q %
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCRDK 4299 printed Nov 22, 2024@17:23:16 Page 2
PRCPCRDK ;WISC/RFJ-instrument kit definition ;01 Sep 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW ALLKITS,X
+5 KILL X
SET X(1)="The Definition Instrument Kit Report will print a list of selected instrument kits displaying the items and quantities needed to assemble a instrument kit."
+6 SET X(2)="The items in the instrument kit are sorted by the sequence number."
+7 DO DISPLAY^PRCPUX2(40,79,.X)
+8 DO INSTRKIT^PRCPCRU1
+9 IF '$ORDER(^TMP($JOB,"PRCPKITS",0))
IF '$DATA(ALLKITS)
QUIT
+10 IF $DATA(ALLKITS)
WRITE !!,"NOTE -- This option will use a lot of paper!"
+11 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTDESC="Instrument Kit Definition Report"
SET ZTRTN="DQ^PRCPCRDK"
+13 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ALLKITS")=""
SET ZTSAVE("^TMP($J,""PRCPKITS"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO Q
QUIT
+14 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW IKITEM,PRCPFLAG,SCREEN,X,Y
+2 SET SCREEN=$$SCRPAUSE^PRCPUREP
+3 IF $DATA(ALLKITS)
SET IKITEM=0
FOR
SET IKITEM=$ORDER(^PRCP(445.8,IKITEM))
if 'IKITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 DO PRINT
IF $GET(PRCPFLAG)
QUIT
+5 IF SCREEN
IF $ORDER(^PRCP(445.8,IKITEM))
DO P^PRCPUREP
End DoDot:1
+6 ;
+7 IF '$DATA(ALLKITS)
SET IKITEM=0
FOR
SET IKITEM=$ORDER(^TMP($JOB,"PRCPKITS",IKITEM))
if 'IKITEM
QUIT
DO PRINT
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPKITS"),^TMP($JOB,"PRCPCRDK")
+1 QUIT
+2 ;
+3 ;
PRINT ; print a instrument kit definition
+1 NEW %,%I,CATALOG,IKDATA,IKDATE,IKLOC,IKNAME,IKUSER,DATA,EDITDATE,EDITUSER,ITEMDA,LOCATION,NOW,ONHAND,PAGE,PRCPINNM,PRCPINPT,REUSABLE,SEQUENCE,VENDOR
+2 ; sort by sequence number
+3 KILL ^TMP($JOB,"PRCPCRDK")
+4 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.8,IKITEM,1,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=$GET(^(ITEMDA,0))
SET ^TMP($JOB,"PRCPCRDK",+$PIECE(DATA,"^",3),ITEMDA)=""
+5 ;
+6 SET IKDATA=$GET(^PRCP(445.8,IKITEM,0))
+7 SET PRCPINPT=+$PIECE(IKDATA,"^",2)
SET PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
+8 SET IKNAME=$$DESCR^PRCPUX1(PRCPINPT,IKITEM)
SET IKUSER=$$USER^PRCPUREP($PIECE(IKDATA,"^",3))
SET Y=$PIECE(IKDATA,"^",4)
DO DD^%DT
SET IKDATE=Y
SET EDITUSER=$$USER^PRCPUREP($PIECE(IKDATA,"^",5))
SET Y=$PIECE(IKDATA,"^",6)
DO DD^%DT
SET EDITDATE=Y
+9 SET IKLOC=$$STORAGE^PRCPESTO(PRCPINPT,IKITEM)
SET ONHAND=$GET(^PRCP(445,PRCPINPT,1,IKITEM,0))
SET ONHAND=$SELECT(ONHAND="":"NOT STORED IN INVENTORY POINT",1:+$PIECE(ONHAND,"^",7))
+10 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
USE IO
DO H
+11 SET SEQUENCE=""
FOR
SET SEQUENCE=$ORDER(^TMP($JOB,"PRCPCRDK",SEQUENCE))
if SEQUENCE=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPCRDK",SEQUENCE,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+12 SET DATA=$GET(^PRCP(445.8,IKITEM,1,ITEMDA,0))
IF DATA=""
QUIT
+13 SET VENDOR=$$MANDSRCE^PRCPU441(ITEMDA)
SET CATALOG=$PIECE($GET(^PRC(441,ITEMDA,2,+VENDOR,0)),"^",4)
IF $EXTRACT(CATALOG,16)'=""
SET CATALOG=$EXTRACT(CATALOG,1,15)_"+"
+14 SET LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
+15 SET REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
SET REUSABLE=$SELECT(REUSABLE:"R",1:"D")
+16 WRITE !,$JUSTIFY(+$PIECE(DATA,"^",2),7),?10,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,20),?31,ITEMDA,?38,REUSABLE,?40,VENDOR,?48,CATALOG,?67,$EXTRACT(LOCATION,1,12)
+17 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+18 IF $GET(PRCPFLAG)
QUIT
+19 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+20 WRITE !!,"METHOD OF STERILIZATION : ",$$STERILE(IKITEM)
+21 WRITE !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING(IKITEM)
+22 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+23 WRITE !!,"SPECIAL INSTRUCTIONS/REMARKS:"
+24 SET X=0
FOR
SET X=$ORDER(^PRCP(445.8,IKITEM,2,X))
if 'X!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(X,0))
Begin DoDot:1
+25 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+26 WRITE !,DATA
End DoDot:1
+27 DO END^PRCPUREP
+28 QUIT
+29 ;
+30 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"DEFINITION OF INSTRUMENT KIT REPORT FOR: ",$EXTRACT(PRCPINNM,1,20),?(80-$LENGTH(%)),%
+2 WRITE !?9,"NAME: ",IKNAME," (#",IKITEM,") ",?46,"LOCATION: ",IKLOC
+3 WRITE !?15,"CURRENT QUANTITY ASSEMBLED: ",ONHAND
+4 WRITE !?3,"CREATED BY: ",IKUSER,?50,"DATE: ",IKDATE
+5 WRITE !?1,"LAST EDIT BY: ",EDITUSER,?50,"DATE: ",EDITDATE
+6 SET %=""
SET $PIECE(%,"-",81)=""
+7 WRITE !,$JUSTIFY("QTY",7),?10,"DESCRIPTION",?31,"MI#",?37,"RD",?40,"VEND#",?48,"CATALOG#",?67,"LOCATION",!,%
+8 QUIT
+9 ;
+10 ;
STERILE(V1) ; return method of sterilization for ik v1
+1 NEW %
+2 SET %=$PIECE($GET(^PRCP(445.8,+V1,0)),"^",7)
IF %'=""
SET %=$PIECE($PIECE($PIECE(^DD(445.8,11,0),"^",3),%_":",2),";")
+3 QUIT %
+4 ;
+5 ;
WRAPPING(V1) ; return method of wrapping for ik v1
+1 NEW %
+2 SET %=$PIECE($GET(^PRCP(445.8,+V1,0)),"^",8)
IF %'=""
SET %=$PIECE($PIECE($PIECE(^DD(445.8,12,0),"^",3),%_":",2),";")
+3 QUIT %
