PRCPCRPL ;WISC/RFJ/DWA-cc and ik preparation list ; 06/23/2009 2:15 PM
;;5.1;IFCAP;**27,49,136**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
DQ ; called from prcpopt to print preparation list on picking ticket
; print cc from ^tmp($j,"prcpcrpl-cc",itemda)
; print ik from ^tmp($j,"prcpcrpl-ik",itemda)
N %,CCIKITEM,COMMENTS,DESCR,DFN,ITEMDATA,LOCATION,OPCODE,OPDATE,OPDATEI,ORROOM,PATNAME,PATSSN,PRCPDATA,PRCPSDAT,PRCPFILE,PRCPINPT,PRCPPAT,PRCPSURG,SEQ,SURGEON,VADM,VAERR,X,Y
D PAT
D SURG
D CART
D IK
D Q
Q
;
Q ; clean up ^TMP
K ^TMP("PRCPCRPL-CC"),^TMP("PRCPCRPL-IK"),^TMP("PRCPCRPL-KIT"),^TMP("PRCPCRPLSEQ"),^TMP("PRCPCRPLSEQ2")
Q
;
PAT ; get patient data
S PRCPPAT=+$P($G(^PRCP(445.3,ORDERDA,2)),"^"),PRCPSURG=+$P($G(^(2)),"^",2)
S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT
S PATNAME=$G(VADM(1)),PATSSN=$P($G(VADM(2)),"^")
Q
;
SURG ; get surgery data
D SURGDATA(PRCPSURG,".02;.09;.14;.28;27")
S ORROOM=$G(PRCPSDAT(130,PRCPSURG,.02,"E")),OPDATE=$G(PRCPSDAT(130,PRCPSURG,.09,"E")),SURGEON=$G(PRCPSDAT(130,PRCPSURG,.14,"E")),OPCODE=$G(PRCPSDAT(130,PRCPSURG,27,"I"))
S OPDATEI=$G(PRCPSDAT(130,PRCPSURG,.09,"I")),OPCODE=$TR($$ICPT^PRCPCUT1(+OPCODE,OPDATEI),"^"," ")
;
Q
;
CART ; process case carts
I $D(^TMP($J,"PRCPCRPL-CC")) D
. S CCIKITEM=0,PRCPFILE=445.7
. K ^TMP($J,"PRCPCRPL-KIT")
. F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-CC",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
. . D H
. . S PRCPFILE=445.7
. . D CCIKNAME Q:$G(PRCPFLAG)
. . D CART2,CART3 Q:$G(PRCPFLAG)
. . D COMMENTS Q:$G(PRCPFLAG)
. . K ^TMP($J,"PRCPCRPLSEQ")
. . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
. . I $D(^TMP($J,"PRCPCRPL-KIT")) D KIT K ^TMP($J,"PRCPCRPL-KIT")
I $G(PRCPFLAG) Q
Q
CART2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of carts
Q:$G(PRCPFLAG)
S ITEMDA=0
F S ITEMDA=$O(^PRCP(445.7,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. S SEQ=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
. I SEQ="" S SEQ="?"
. S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
. I $D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPCRPL-KIT",CCIKITEM,ITEMDA)=""
Q
;
CART3 ; print out carts
Q:$G(PRCPFLAG)
S SEQ=""
F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:SEQ=""!($G(PRCPFLAG)) D
. S ITEMDA=""
. F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. . S ITEMDATA=$G(^PRCP(445.7,CCIKITEM,1,ITEMDA,0))
. . D WRITE
. . Q:$G(PRCPFLAG)
Q
;
IK ; process freestanding instrument kits
Q:$G(PRCPFLAG)
I $D(^TMP($J,"PRCPCRPL-IK")) D
. S CCIKITEM=0,PRCPFILE=445.8
. F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-IK",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
. . D H
. . D CCIKNAME Q:$G(PRCPFLAG)
. . D IK2,IK3 Q:$G(PRCPFLAG)
. . D COMMENTS Q:$G(PRCPFLAG)
. . K ^TMP($J,"PRCPCRPLSEQ")
. . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
I $G(PRCPFLAG) Q
Q
IK2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of kits
Q:$G(PRCPFLAG)
K ^TMP($J,"PRCPCRPLSEQ")
S ITEMDA=0
F S ITEMDA=$O(^PRCP(445.8,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. S SEQ=$P(^PRCP(445.8,CCIKITEM,1,ITEMDA,0),"^",3)
. I SEQ="" S SEQ=99.99
. S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
Q
;
IK3 ; print out kits
Q:$G(PRCPFLAG)
S SEQ=0
F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D
. S ITEMDA=0
. F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. . S ITEMDATA=$G(^PRCP(445.8,CCIKITEM,1,ITEMDA,0))
. . D WRITE
. . Q:$G(PRCPFLAG)
Q
;
KIT ; process kits associated with cart
Q:$G(PRCPFLAG)
N CCITEM,CCIKITEM
S PRCPFILE=445.8
S CCITEM=0
F S CCITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D
. S CCIKITEM=0
. F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM,CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
. . D H,CCIKNAME
. . Q:$G(PRCPFLAG)
. . D KIT2,KIT3 Q:$G(PRCPFLAG)
. . D COMMENTS Q:$G(PRCPFLAG)
. . K ^TMP($J,"PRCPCRPLSEQ2")
. D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
Q
KIT2 ; set up ^TMP($J,"PRCPCRPLSEQ2", for print of kits
Q:$G(PRCPFLAG)
K ^TMP($J,"PRCPCRPLSEQ2")
S ITEMDA=0
F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
. S SEQ=$P(ITEMDATA,"^",3)
. I SEQ="" S SEQ=99.99
. S ^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)=""
Q
KIT3 ; print out kits
Q:$G(PRCPFLAG)
S SEQ=0
F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D
. S ITEMDA=0
. F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. . S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
. . D WRITE
. . Q:$G(PRCPFLAG)
Q
;
WRITE ; write data
I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,33)_" (#"_ITEMDA_")"
W !?2,DESCR,?45,$J(+$P(ITEMDATA,"^",2),5),$J($P($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"^"),"^",2),4)," ",$E(LOCATION,1,15),?72,"__ __ __"
Q
;
;
CCIKNAME ; write cc or ik name
I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
S PRCPDATA=$G(^PRCP(PRCPFILE,CCIKITEM,0))
S PRCPINPT=$P(PRCPDATA,"^",2)
S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,CCIKITEM)
S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,CCIKITEM),1,40)_" (#"_CCIKITEM_") .............................................................."
W !!?22,"* * * * * ",$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")," * * * * *"
W !,$E(DESCR,1,55),?56,$E(LOCATION,1,15),?72,"__ __ __"
W !?10,"from: ",$$INVNAME^PRCPUX1(PRCPINPT)
Q
;
;
I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I PRCPFILE=445.8 D
. W !,"METHOD OF STERILIZATION : ",$$STERILE^PRCPCRDK(CCIKITEM)
. W !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING^PRCPCRDK(CCIKITEM)
W !,$S(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")," SPECIAL INSTRUCTIONS/REMARKS:"
S X=0 F S X=$O(^PRCP(PRCPFILE,CCIKITEM,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
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"CASE CART OR INSTRUMENT KIT PREPARATION LIST ",?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !?1,"PATIENT: ",$E(PATNAME,1,28),?40,"SSN: ",PATSSN,?63,"RETURNED BY ____."
W !?1,"DATE OF OPERATION: ",OPDATE,?32,"OR ROOM: ",$E(ORROOM,1,18),?60,"RECEIVED BY ____. |"
W !?1,"PRINCIPAL OPERATION CODE: ",OPCODE,?59,"PICKED BY ____. | |"
W !?1,"SURGEON: ",SURGEON,?73,"| | |"
W !?73,"V V V"
W !,"DESCRIPTION (#MI)",?45,$J("QTY",5),$J("UI",4),?56,"LOCATION",?72,"CK CK CK",!,%
W !?1,"COMMENTS:"
S %=0 F S %=$O(COMMENTS(%)) Q:'% W !,COMMENTS(%)
W !
Q
;
;
SURGDATA(DA,DR) ; get surgery data
N D0,DIC,DIQ,QPQPQ
K PRCPSDAT
S QPQPQ=1 ; to prevent executing field 27 opcode transform
S DIC="^SRF(",DIQ="PRCPSDAT",DIQ(0)="IEN" D EN^DIQ1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCRPL 6978 printed Dec 13, 2024@02:13:14 Page 2
PRCPCRPL ;WISC/RFJ/DWA-cc and ik preparation list ; 06/23/2009 2:15 PM
+1 ;;5.1;IFCAP;**27,49,136**;Oct 20, 2000;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DQ ; called from prcpopt to print preparation list on picking ticket
+1 ; print cc from ^tmp($j,"prcpcrpl-cc",itemda)
+2 ; print ik from ^tmp($j,"prcpcrpl-ik",itemda)
+3 NEW %,CCIKITEM,COMMENTS,DESCR,DFN,ITEMDATA,LOCATION,OPCODE,OPDATE,OPDATEI,ORROOM,PATNAME,PATSSN,PRCPDATA,PRCPSDAT,PRCPFILE,PRCPINPT,PRCPPAT,PRCPSURG,SEQ,SURGEON,VADM,VAERR,X,Y
+4 DO PAT
+5 DO SURG
+6 DO CART
+7 DO IK
+8 DO Q
+9 QUIT
+10 ;
Q ; clean up ^TMP
+1 KILL ^TMP("PRCPCRPL-CC"),^TMP("PRCPCRPL-IK"),^TMP("PRCPCRPL-KIT"),^TMP("PRCPCRPLSEQ"),^TMP("PRCPCRPLSEQ2")
+2 QUIT
+3 ;
PAT ; get patient data
+1 SET PRCPPAT=+$PIECE($GET(^PRCP(445.3,ORDERDA,2)),"^")
SET PRCPSURG=+$PIECE($GET(^(2)),"^",2)
+2 SET DFN=PRCPPAT
IF $$VERSION^XPDUTL("DG")
DO DEM^VADPT
+3 SET PATNAME=$GET(VADM(1))
SET PATSSN=$PIECE($GET(VADM(2)),"^")
+4 QUIT
+5 ;
SURG ; get surgery data
+1 DO SURGDATA(PRCPSURG,".02;.09;.14;.28;27")
+2 SET ORROOM=$GET(PRCPSDAT(130,PRCPSURG,.02,"E"))
SET OPDATE=$GET(PRCPSDAT(130,PRCPSURG,.09,"E"))
SET SURGEON=$GET(PRCPSDAT(130,PRCPSURG,.14,"E"))
SET OPCODE=$GET(PRCPSDAT(130,PRCPSURG,27,"I"))
+3 SET OPDATEI=$GET(PRCPSDAT(130,PRCPSURG,.09,"I"))
SET OPCODE=$TRANSLATE($$ICPT^PRCPCUT1(+OPCODE,OPDATEI),"^"," ")
+4 ;
+5 QUIT
+6 ;
CART ; process case carts
+1 IF $DATA(^TMP($JOB,"PRCPCRPL-CC"))
Begin DoDot:1
+2 SET CCIKITEM=0
SET PRCPFILE=445.7
+3 KILL ^TMP($JOB,"PRCPCRPL-KIT")
+4 FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPCRPL-CC",CCIKITEM))
if 'CCIKITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+5 DO H
+6 SET PRCPFILE=445.7
+7 DO CCIKNAME
if $GET(PRCPFLAG)
QUIT
+8 DO CART2
DO CART3
if $GET(PRCPFLAG)
QUIT
+9 DO COMMENTS
if $GET(PRCPFLAG)
QUIT
+10 KILL ^TMP($JOB,"PRCPCRPLSEQ")
+11 if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
+12 IF $DATA(^TMP($JOB,"PRCPCRPL-KIT"))
DO KIT
KILL ^TMP($JOB,"PRCPCRPL-KIT")
End DoDot:2
End DoDot:1
+13 IF $GET(PRCPFLAG)
QUIT
+14 QUIT
CART2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of carts
+1 if $GET(PRCPFLAG)
QUIT
+2 SET ITEMDA=0
+3 FOR
SET ITEMDA=$ORDER(^PRCP(445.7,CCIKITEM,1,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 SET SEQ=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
+5 IF SEQ=""
SET SEQ="?"
+6 SET ^TMP($JOB,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
+7 IF $DATA(^PRCP(445.8,ITEMDA))
SET ^TMP($JOB,"PRCPCRPL-KIT",CCIKITEM,ITEMDA)=""
End DoDot:1
+8 QUIT
+9 ;
CART3 ; print out carts
+1 if $GET(PRCPFLAG)
QUIT
+2 SET SEQ=""
+3 FOR
SET SEQ=$ORDER(^TMP($JOB,"PRCPCRPLSEQ",SEQ))
if SEQ=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 SET ITEMDA=""
+5 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+6 SET ITEMDATA=$GET(^PRCP(445.7,CCIKITEM,1,ITEMDA,0))
+7 DO WRITE
+8 if $GET(PRCPFLAG)
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
IK ; process freestanding instrument kits
+1 if $GET(PRCPFLAG)
QUIT
+2 IF $DATA(^TMP($JOB,"PRCPCRPL-IK"))
Begin DoDot:1
+3 SET CCIKITEM=0
SET PRCPFILE=445.8
+4 FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPCRPL-IK",CCIKITEM))
if 'CCIKITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+5 DO H
+6 DO CCIKNAME
if $GET(PRCPFLAG)
QUIT
+7 DO IK2
DO IK3
if $GET(PRCPFLAG)
QUIT
+8 DO COMMENTS
if $GET(PRCPFLAG)
QUIT
+9 KILL ^TMP($JOB,"PRCPCRPLSEQ")
+10 if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
End DoDot:2
End DoDot:1
+11 IF $GET(PRCPFLAG)
QUIT
+12 QUIT
IK2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of kits
+1 if $GET(PRCPFLAG)
QUIT
+2 KILL ^TMP($JOB,"PRCPCRPLSEQ")
+3 SET ITEMDA=0
+4 FOR
SET ITEMDA=$ORDER(^PRCP(445.8,CCIKITEM,1,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+5 SET SEQ=$PIECE(^PRCP(445.8,CCIKITEM,1,ITEMDA,0),"^",3)
+6 IF SEQ=""
SET SEQ=99.99
+7 SET ^TMP($JOB,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
End DoDot:1
+8 QUIT
+9 ;
IK3 ; print out kits
+1 if $GET(PRCPFLAG)
QUIT
+2 SET SEQ=0
+3 FOR
SET SEQ=$ORDER(^TMP($JOB,"PRCPCRPLSEQ",SEQ))
if 'SEQ!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 SET ITEMDA=0
+5 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+6 SET ITEMDATA=$GET(^PRCP(445.8,CCIKITEM,1,ITEMDA,0))
+7 DO WRITE
+8 if $GET(PRCPFLAG)
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
KIT ; process kits associated with cart
+1 if $GET(PRCPFLAG)
QUIT
+2 NEW CCITEM,CCIKITEM
+3 SET PRCPFILE=445.8
+4 SET CCITEM=0
+5 FOR
SET CCITEM=$ORDER(^TMP($JOB,"PRCPCRPL-KIT",CCITEM))
if 'CCITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+6 SET CCIKITEM=0
+7 FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPCRPL-KIT",CCITEM,CCIKITEM))
if 'CCIKITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+8 DO H
DO CCIKNAME
+9 if $GET(PRCPFLAG)
QUIT
+10 DO KIT2
DO KIT3
if $GET(PRCPFLAG)
QUIT
+11 DO COMMENTS
if $GET(PRCPFLAG)
QUIT
+12 KILL ^TMP($JOB,"PRCPCRPLSEQ2")
End DoDot:2
+13 if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
End DoDot:1
+14 QUIT
KIT2 ; set up ^TMP($J,"PRCPCRPLSEQ2", for print of kits
+1 if $GET(PRCPFLAG)
QUIT
+2 KILL ^TMP($JOB,"PRCPCRPLSEQ2")
+3 SET ITEMDA=0
+4 FOR
SET ITEMDA=$ORDER(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+5 SET ITEMDATA=$GET(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
+6 SET SEQ=$PIECE(ITEMDATA,"^",3)
+7 IF SEQ=""
SET SEQ=99.99
+8 SET ^TMP($JOB,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)=""
End DoDot:1
+9 QUIT
KIT3 ; print out kits
+1 if $GET(PRCPFLAG)
QUIT
+2 SET SEQ=0
+3 FOR
SET SEQ=$ORDER(^TMP($JOB,"PRCPCRPLSEQ2",SEQ))
if 'SEQ!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 SET ITEMDA=0
+5 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+6 SET ITEMDATA=$GET(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
+7 DO WRITE
+8 if $GET(PRCPFLAG)
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
WRITE ; write data
+1 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+2 SET LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
+3 SET DESCR=$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,33)_" (#"_ITEMDA_")"
+4 WRITE !?2,DESCR,?45,$JUSTIFY(+$PIECE(ITEMDATA,"^",2),5),$JUSTIFY($PIECE($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"^"),"^",2),4)," ",$EXTRACT(LOCATION,1,15),?72,"__ __ __"
+5 QUIT
+6 ;
+7 ;
CCIKNAME ; write cc or ik name
+1 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+2 SET PRCPDATA=$GET(^PRCP(PRCPFILE,CCIKITEM,0))
+3 SET PRCPINPT=$PIECE(PRCPDATA,"^",2)
+4 SET LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,CCIKITEM)
+5 SET DESCR=$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,CCIKITEM),1,40)_" (#"_CCIKITEM_") .............................................................."
+6 WRITE !!?22,"* * * * * ",$SELECT(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")," * * * * *"
+7 WRITE !,$EXTRACT(DESCR,1,55),?56,$EXTRACT(LOCATION,1,15),?72,"__ __ __"
+8 WRITE !?10,"from: ",$$INVNAME^PRCPUX1(PRCPINPT)
+9 QUIT
+10 ;
+11 ;
+1 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+2 IF PRCPFILE=445.8
Begin DoDot:1
+3 WRITE !,"METHOD OF STERILIZATION : ",$$STERILE^PRCPCRDK(CCIKITEM)
+4 WRITE !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING^PRCPCRDK(CCIKITEM)
End DoDot:1
+5 WRITE !,$SELECT(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")," SPECIAL INSTRUCTIONS/REMARKS:"
+6 SET X=0
FOR
SET X=$ORDER(^PRCP(PRCPFILE,CCIKITEM,2,X))
if 'X!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(X,0))
Begin DoDot:1
+7 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+8 WRITE !,DATA
End DoDot:1
+9 QUIT
+10 ;
+11 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"CASE CART OR INSTRUMENT KIT PREPARATION LIST ",?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 WRITE !?1,"PATIENT: ",$EXTRACT(PATNAME,1,28),?40,"SSN: ",PATSSN,?63,"RETURNED BY ____."
+4 WRITE !?1,"DATE OF OPERATION: ",OPDATE,?32,"OR ROOM: ",$EXTRACT(ORROOM,1,18),?60,"RECEIVED BY ____. |"
+5 WRITE !?1,"PRINCIPAL OPERATION CODE: ",OPCODE,?59,"PICKED BY ____. | |"
+6 WRITE !?1,"SURGEON: ",SURGEON,?73,"| | |"
+7 WRITE !?73,"V V V"
+8 WRITE !,"DESCRIPTION (#MI)",?45,$JUSTIFY("QTY",5),$JUSTIFY("UI",4),?56,"LOCATION",?72,"CK CK CK",!,%
+9 WRITE !?1,"COMMENTS:"
+10 SET %=0
FOR
SET %=$ORDER(COMMENTS(%))
if '%
QUIT
WRITE !,COMMENTS(%)
+11 WRITE !
+12 QUIT
+13 ;
+14 ;
SURGDATA(DA,DR) ; get surgery data
+1 NEW D0,DIC,DIQ,QPQPQ
+2 KILL PRCPSDAT
+3 ; to prevent executing field 27 opcode transform
SET QPQPQ=1
+4 SET DIC="^SRF("
SET DIQ="PRCPSDAT"
SET DIQ(0)="IEN"
DO EN^DIQ1
+5 QUIT
