- PRCPCED0 ;WISC/RFJ-enter edit case cart or instrument kit ;01 Sep 93
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- INSTRKIT ; enter edit instrument kit
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,D0,D1,DA,DDC,DG,DI,DIC,DIE,DQ,DR,PRCPPRIV,PRCPSET,PRCPFLAG,X,Y
- K X S X(1)="Before you can create an instrument kit, an item must be defined in the Item Master File as non-purchasable." D DISPLAY^PRCPUX2(2,40,.X)
- F S DA=$$SELECT("K",1,PRCP("I")) Q:DA<1 D
- . D LOCATE(PRCP("I"),DA) I $G(PRCPFLAG) K PRCPFLAG W !! Q
- . S (DIC,DIE)="^PRCP(445.8,",DR=".01;5////"_DUZ_";6///NOW;1;7;11;12;10",PRCPSET="I 1",PRCPPRIV=1 D ^DIE
- . W !!
- Q
- ;
- ;
- CASECART ; enter edit case cart
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,D0,D1,DA,DI,DIC,DIE,DQ,DR,PRCPPRIV,PRCPSET,X,Y
- K X S X(1)="Before you can create a case cart, an item must be defined in the Item Master File as non-purchasable." D DISPLAY^PRCPUX2(2,40,.X)
- F S DA=$$SELECT("C",1,PRCP("I")) Q:DA<1 D
- . S (DIC,DIE)="^PRCP(445.7,",DR=".01;5////"_DUZ_";6///NOW;1;7;10",PRCPSET="I 1",PRCPPRIV=1 D ^DIE
- . W !!
- Q
- ;
- ;
- OPCODES ; enter opcodes tied to a case cart
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,D0,D1,DA,DI,DIC,DIE,DIZ,DLAYGO,DQ,DR,X,Y
- K X S X(1)="This option allows operation codes to be linked to case carts. When a patient is scheduled for an operation code, the system will recommend ordering the case carts tied to the operation code."
- D DISPLAY^PRCPUX2(2,40,.X)
- F S DA=$$SELECT("C",0,$S(PRCP("DPTYPE")="P":PRCP("I"),1:0)) Q:DA<1 D
- . S (DIC,DIE)="^PRCP(445.7,",DR=81 W ! D ^DIE
- . W !!
- Q
- ;
- ;
- SELECT(TYPE,ADDNEW,INVPT) ; select a case cart or instrument kit
- ; type='C'ase cart or instrument 'K'it
- ; addnew=1 for adding new entries
- ; invpt to screen cc or ik owned by inventory point
- N %,DIC,DLAYGO,I,PRCPINPT,PRCPFILE,PRCPNAME,PRCPSET,PRCPPRIV,X,Y
- S PRCPFILE=445.7,PRCPNAME="CASE CART",PRCPPRIV=1
- I TYPE="K" S PRCPFILE=445.8,PRCPNAME="INSTRUMENT KIT"
- S DIC="^PRCP("_PRCPFILE_",",DIC(0)="QEAM",DIC("A")="Select "_PRCPNAME_" Item Number: ",PRCPSET="I 1"
- I INVPT S DIC("S")="I $P(^PRCP("_PRCPFILE_",+Y,0),U,2)="_INVPT,PRCPINPT=INVPT
- S DIC("W")="W ?20,$E($$DESCR^PRCPUX1(+$G(PRCPINPT),+Y),1,20) I $G(PRCPINPT) S %=$G(^PRCP(445,PRCPINPT,1,+Y,0)) W ?45,"" "",$S(%="""":""Not Stored In InvPt"",1:""Qty On-Hand: ""_+$P(%,U,7))"
- I ADDNEW S DIC(0)="QEALM",DLAYGO=PRCPFILE,DIC("DR")="2////"_PRCP("I")_";3////"_DUZ_";4///NOW"
- D ^DIC
- Q $S(Y<1:0,1:+Y)
- ;
- ;
- LOCATE(INVPT,IKITEM) ; locate any case carts containing instrument kits ikitem
- S IOP="HOME" D ^%ZIS K IOP
- K ^TMP($J,"PRCPCED0")
- N CCITEM,SCREEN,QTY,X
- S CCITEM=0 F S CCITEM=$O(^PRCP(445.7,"AI",IKITEM,CCITEM)) Q:'CCITEM S QTY=+$P($G(^PRCP(445,INVPT,1,CCITEM,0)),"^",7) I QTY S ^TMP($J,"PRCPCED0",CCITEM)=QTY
- I '$O(^TMP($J,"PRCPCED0",0)) Q
- ; show where iks are
- W ! D H
- S SCREEN=1,(CCITEM,PRCPFLAG)=0 F S CCITEM=$O(^TMP($J,"PRCPCED0",CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) S QTY=^(CCITEM) D
- . W !,CCITEM,?7,$E($$DESCR^PRCPUX1(INVPT,CCITEM),1,22),?44,$J(QTY,13)
- . S SCREEN=SCREEN+1
- . I SCREEN'<IOSL D P^PRCPUREP Q:$D(PRCPFLAG) D H S SCREEN=1
- I SCREEN>(IOSL-16) D R^PRCPUREP
- K X S X(1)="WARNING -- This Instrument Kit has been assembled and is contained in the above case cart(s)."
- S X(2)="If you continue editing the definition of this instrument kit, disassembling of the above case cart(s) and instrument kit may cause incorrect quantities for items contained within this instrument kit."
- S X(3)="To prevent incorrect quantities, please disassemble the above case cart(s) and the instrument kit before editing the definition."
- D DISPLAY^PRCPUX2(20,60,.X)
- K ^TMP($J,"PRCPCED0")
- S PRCPFLAG=1
- Q
- ;
- ;
- H ; display header on display
- S %="",$P(%,"-",81)=""
- W !,"IM#",?7,"DESCRIPTION",?44,$J("QTY ON-HAND",13),!,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCED0 3905 printed Feb 18, 2025@23:39:32 Page 2
- PRCPCED0 ;WISC/RFJ-enter edit case cart or instrument kit ;01 Sep 93
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- INSTRKIT ; enter edit instrument kit
- +1 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +2 NEW %,D0,D1,DA,DDC,DG,DI,DIC,DIE,DQ,DR,PRCPPRIV,PRCPSET,PRCPFLAG,X,Y
- +3 KILL X
- SET X(1)="Before you can create an instrument kit, an item must be defined in the Item Master File as non-purchasable."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +4 FOR
- SET DA=$$SELECT("K",1,PRCP("I"))
- if DA<1
- QUIT
- Begin DoDot:1
- +5 DO LOCATE(PRCP("I"),DA)
- IF $GET(PRCPFLAG)
- KILL PRCPFLAG
- WRITE !!
- QUIT
- +6 SET (DIC,DIE)="^PRCP(445.8,"
- SET DR=".01;5////"_DUZ_";6///NOW;1;7;11;12;10"
- SET PRCPSET="I 1"
- SET PRCPPRIV=1
- DO ^DIE
- +7 WRITE !!
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;
- CASECART ; enter edit case cart
- +1 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +2 NEW %,D0,D1,DA,DI,DIC,DIE,DQ,DR,PRCPPRIV,PRCPSET,X,Y
- +3 KILL X
- SET X(1)="Before you can create a case cart, an item must be defined in the Item Master File as non-purchasable."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +4 FOR
- SET DA=$$SELECT("C",1,PRCP("I"))
- if DA<1
- QUIT
- Begin DoDot:1
- +5 SET (DIC,DIE)="^PRCP(445.7,"
- SET DR=".01;5////"_DUZ_";6///NOW;1;7;10"
- SET PRCPSET="I 1"
- SET PRCPPRIV=1
- DO ^DIE
- +6 WRITE !!
- End DoDot:1
- +7 QUIT
- +8 ;
- +9 ;
- OPCODES ; enter opcodes tied to a case cart
- +1 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +2 NEW %,D0,D1,DA,DI,DIC,DIE,DIZ,DLAYGO,DQ,DR,X,Y
- +3 KILL X
- SET X(1)="This option allows operation codes to be linked to case carts. When a patient is scheduled for an operation code, the system will recommend ordering the case carts tied to the operation code."
- +4 DO DISPLAY^PRCPUX2(2,40,.X)
- +5 FOR
- SET DA=$$SELECT("C",0,$SELECT(PRCP("DPTYPE")="P":PRCP("I"),1:0))
- if DA<1
- QUIT
- Begin DoDot:1
- +6 SET (DIC,DIE)="^PRCP(445.7,"
- SET DR=81
- WRITE !
- DO ^DIE
- +7 WRITE !!
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;
- SELECT(TYPE,ADDNEW,INVPT) ; select a case cart or instrument kit
- +1 ; type='C'ase cart or instrument 'K'it
- +2 ; addnew=1 for adding new entries
- +3 ; invpt to screen cc or ik owned by inventory point
- +4 NEW %,DIC,DLAYGO,I,PRCPINPT,PRCPFILE,PRCPNAME,PRCPSET,PRCPPRIV,X,Y
- +5 SET PRCPFILE=445.7
- SET PRCPNAME="CASE CART"
- SET PRCPPRIV=1
- +6 IF TYPE="K"
- SET PRCPFILE=445.8
- SET PRCPNAME="INSTRUMENT KIT"
- +7 SET DIC="^PRCP("_PRCPFILE_","
- SET DIC(0)="QEAM"
- SET DIC("A")="Select "_PRCPNAME_" Item Number: "
- SET PRCPSET="I 1"
- +8 IF INVPT
- SET DIC("S")="I $P(^PRCP("_PRCPFILE_",+Y,0),U,2)="_INVPT
- SET PRCPINPT=INVPT
- +9 SET DIC("W")="W ?20,$E($$DESCR^PRCPUX1(+$G(PRCPINPT),+Y),1,20) I $G(PRCPINPT) S %=$G(^PRCP(445,PRCPINPT,1,+Y,0)) W ?45,"" "",$S(%="""":""Not Stored In InvPt"",1:""Qty On-Hand: ""_+$P(%,U,7))"
- +10 IF ADDNEW
- SET DIC(0)="QEALM"
- SET DLAYGO=PRCPFILE
- SET DIC("DR")="2////"_PRCP("I")_";3////"_DUZ_";4///NOW"
- +11 DO ^DIC
- +12 QUIT $SELECT(Y<1:0,1:+Y)
- +13 ;
- +14 ;
- LOCATE(INVPT,IKITEM) ; locate any case carts containing instrument kits ikitem
- +1 SET IOP="HOME"
- DO ^%ZIS
- KILL IOP
- +2 KILL ^TMP($JOB,"PRCPCED0")
- +3 NEW CCITEM,SCREEN,QTY,X
- +4 SET CCITEM=0
- FOR
- SET CCITEM=$ORDER(^PRCP(445.7,"AI",IKITEM,CCITEM))
- if 'CCITEM
- QUIT
- SET QTY=+$PIECE($GET(^PRCP(445,INVPT,1,CCITEM,0)),"^",7)
- IF QTY
- SET ^TMP($JOB,"PRCPCED0",CCITEM)=QTY
- +5 IF '$ORDER(^TMP($JOB,"PRCPCED0",0))
- QUIT
- +6 ; show where iks are
- +7 WRITE !
- DO H
- +8 SET SCREEN=1
- SET (CCITEM,PRCPFLAG)=0
- FOR
- SET CCITEM=$ORDER(^TMP($JOB,"PRCPCED0",CCITEM))
- if 'CCITEM!($GET(PRCPFLAG))
- QUIT
- SET QTY=^(CCITEM)
- Begin DoDot:1
- +9 WRITE !,CCITEM,?7,$EXTRACT($$DESCR^PRCPUX1(INVPT,CCITEM),1,22),?44,$JUSTIFY(QTY,13)
- +10 SET SCREEN=SCREEN+1
- +11 IF SCREEN'<IOSL
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- SET SCREEN=1
- End DoDot:1
- +12 IF SCREEN>(IOSL-16)
- DO R^PRCPUREP
- +13 KILL X
- SET X(1)="WARNING -- This Instrument Kit has been assembled and is contained in the above case cart(s)."
- +14 SET X(2)="If you continue editing the definition of this instrument kit, disassembling of the above case cart(s) and instrument kit may cause incorrect quantities for items contained within this instrument kit."
- +15 SET X(3)="To prevent incorrect quantities, please disassemble the above case cart(s) and the instrument kit before editing the definition."
- +16 DO DISPLAY^PRCPUX2(20,60,.X)
- +17 KILL ^TMP($JOB,"PRCPCED0")
- +18 SET PRCPFLAG=1
- +19 QUIT
- +20 ;
- +21 ;
- H ; display header on display
- +1 SET %=""
- SET $PIECE(%,"-",81)=""
- +2 WRITE !,"IM#",?7,"DESCRIPTION",?44,$JUSTIFY("QTY ON-HAND",13),!,%
- +3 QUIT