- 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 Feb 18, 2025@23:39:36 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