Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPCRPL

PRCPCRPL.m

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