PRCPCSOR ;WISC/RFJ-surgery order supplies ; 06/23/2009 2:23 PM
;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
N X
S X="SROPS" X:$D(^%ZOSF("TEST")) ^("TEST") I '$T D NO Q
I '$$VERSION^XPDUTL("SURGERY") D NO Q
;
D ^PRCPUSEL Q:'$G(PRCP("I"))
I "S"'=PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A SECONDARY INVENTORY POINT." Q
N DIPGM,DFN,OPCODE,OPDATEI,ORDERDA,PRCPDEV,PRCPFAUT,PRCPFLAG,PRCPFNEW,PRCPFONE,PRCPINNM,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSDAT,PRCPSECO,PRCPSURG,SRTN,Y
S PRCPPRIM=+$$SPD^PRCPUDPT(PRCP("I"),1) I 'PRCPPRIM Q
S PRCPINNM=$$INVNAME^PRCPUX1(PRCPPRIM)
S PRCPSECO=PRCP("I")
;
S IOP="HOME" D ^%ZIS K IOP
;
; srops returns ^dpt(dfn,0) and ^srf(srtn,0)
F W ! K SRTN D ^SROPS Q:'$G(DFN)!('$G(SRTN)) D
. S PRCPPAT=DFN,PRCPSURG=SRTN
. D SURGDATA^PRCPCRPL(PRCPSURG,".09;27")
. S OPCODE=+$G(PRCPSDAT(130,PRCPSURG,27,"I")),OPDATEI=$G(PRCPSDAT(130,PRCPSURG,.09,"I"))
. W !?2,"Operation: ",$S('OPCODE:"<< NONE SPECIFIED >>",1:$TR($$ICPT^PRCPCUT1(OPCODE,OPDATEI),"^"," "))
. W !!?2,"** Distribution from inventory point: ",PRCPINNM
. ;
. ; if no orders placed, cc's linked to operation, ask for automatic
. S (PRCPFAUT,PRCPFLAG,PRCPFNEW,ORDERDA)=0
. I '$D(^PRCP(445.3,"ASR",PRCPPAT,PRCPSURG)),$D(^PRCP(445.7,"AOP",+OPCODE)) S PRCPFAUT=1 D AUTOORD^PRCPCSO1 Q:PRCPFLAG I 'ORDERDA S PRCPFAUT=0
. I PRCPFAUT S PRCPFNEW=1
. ;
. ; if not automatic ordering, ask to select order
. I 'PRCPFAUT D ASKORDER Q:'ORDERDA L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) Q
. I 'PRCPFAUT D ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies")
. ;
. ; ask to delete order if order is not new (prcpfnew=1)
. I '$G(PRCPFNEW) K PRCPFLAG D I $G(PRCPFLAG) D UNLOCK Q
. . S XP=" Do you want to DELETE the order",XH=" Enter 'YES' to delete the order, 'NO' to continue, '^' to exit."
. . W !! S %=$$YN^PRCPUYN(2)
. . I %=1 D DELORDER^PRCPOPD(ORDERDA) S PRCPFLAG=1 Q
. . I %'=2 S PRCPFLAG=1 Q
. ;
. I 'PRCPFAUT W !! S PRCPFLAG=$$TYPE^PRCPOPUS(ORDERDA) I PRCPFLAG D UNLOCK Q
. ;
. ; if automatic ordering, add items to order
. I PRCPFAUT D AUTOITEM I PRCPFLAG S PRCPFAUT=0
. ;
. I 'PRCPFAUT D
. . ; show items which should be ordered for opcode
. . D SHOWCC^PRCPCSOU(OPCODE,ORDERDA,OPDATEI)
. . D ITEMS^PRCPOPEE(ORDERDA)
. I '$O(^PRCP(445.3,ORDERDA,1,0)) D DELORDER^PRCPOPD(ORDERDA) D UNLOCK Q
. ;
. ; ask remarks
. W !! I $$REMARKS^PRCPOPUS(ORDERDA) Q
. ; ask to release order
. I $$ASKREL^PRCPOPR(ORDERDA,1)=1 D RELEASE^PRCPOPR(ORDERDA)
. I $P($G(^PRCP(445.3,ORDERDA,0)),"^",6)'="R" D UNLOCK Q
. W !,"* * * ORDER HAS BEEN RELEASED * * *"
. ;
. ; order is released, print picking ticket automatically
. S (PRCPDEV,ZTIO)=$P($G(^PRCP(445,PRCPPRIM,"DEV")),"^") I ZTIO="" W !,"NO DEVICE SPECIFIED FOR PRINTING THE PICKING TICKET IN ",$E(PRCPINNM,1,15) D UNLOCK Q
. D BUILD^PRCPOPT(ORDERDA)
. D VARIABLE^PRCPOPU
. S ZTDESC="Print Picking Ticket Automatically",ZTRTN="DQ^PRCPOPT"
. S ZTSAVE("PRCP*")="",ZTSAVE("ORDERDA")="",ZTSAVE("^TMP($J,""PRCPOPT PICK LIST"",")="",ZTSAVE("ZTREQ")="@"
. D ^%ZTLOAD,Q^PRCPOPT K IO("Q"),ZTSK
. W !!,"Picking Ticket Queued on printer ",PRCPDEV," in ",$E(PRCPINNM,1,15)," !"
. D UNLOCK
Q
;
;
UNLOCK ; unlock distribution order
D CLEAR^PRCPULOC(445.3,ORDERDA,0)
L -^PRCP(445.3,ORDERDA,0)
Q
;
;
NO ; not available
W !,"NOT AVAILABLE, SURGERY PACKAGE NOT LOADED."
Q
;
;
PATLINK(ORDERDA,PATIENT,SURGERY) ; link patient da and surgery da to order da
N %,D0,DA,DI,DIC,DIE,DIPGM,DQ,DR,X,Y
I '$D(^PRCP(445.3,ORDERDA,0)) Q
S DA=ORDERDA,(DIC,DIE)="^PRCP(445.3,",DR="129///"_$C(96)_PATIENT_";130///"_$C(96)_SURGERY D ^DIE
Q
;
;
AUTOITEM ; automatically put items in order
N CCITEM,ITEMDA
W !!,"ADDING ITEMS TO THE ORDER:"
S (CCITEM,PRCPFLAG)=0 F S CCITEM=$O(^PRCP(445.7,"AOP",OPCODE,CCITEM)) Q:'CCITEM D
. W !,$E($$DESCR^PRCPUX1(PRCPPRIM,CCITEM),1,30),?32,"MI#",CCITEM,?45
. S ITEMDA=$$ITEMADD^PRCPOPUS(ORDERDA,CCITEM,1)
. I 'ITEMDA W "*** ITEM NOT ORDERED ***" S PRCPFLAG=1 Q
. W "Item Ordered"
Q
;
;
ASKORDER ; ask for order selection
; show orders already placed for patient and operation
D SHOWORD^PRCPCSOU(PRCPPAT,PRCPSURG)
W !
S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"",1) I 'ORDERDA Q
; tie patient and operation to the order
I $G(PRCPFNEW) D PATLINK(ORDERDA,PRCPPAT,PRCPSURG)
I $P($G(^PRCP(445.3,ORDERDA,2)),"^",1,2)'=(PRCPPAT_"^"_PRCPSURG) W !,"YOU CAN ONLY SELECT ORDERS WHICH HAVE BEEN PLACED FOR THIS PATIENT AND OPERATION" G ASKORDER
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCSOR 4798 printed Sep 23, 2025@19:49:21 Page 2
PRCPCSOR ;WISC/RFJ-surgery order supplies ; 06/23/2009 2:23 PM
+1 ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW X
+4 SET X="SROPS"
if $DATA(^%ZOSF("TEST"))
XECUTE ^("TEST")
IF '$TEST
DO NO
QUIT
+5 IF '$$VERSION^XPDUTL("SURGERY")
DO NO
QUIT
+6 ;
+7 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+8 IF "S"'=PRCP("DPTYPE")
WRITE !,"THIS OPTION SHOULD ONLY BE USED BY A SECONDARY INVENTORY POINT."
QUIT
+9 NEW DIPGM,DFN,OPCODE,OPDATEI,ORDERDA,PRCPDEV,PRCPFAUT,PRCPFLAG,PRCPFNEW,PRCPFONE,PRCPINNM,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSDAT,PRCPSECO,PRCPSURG,SRTN,Y
+10 SET PRCPPRIM=+$$SPD^PRCPUDPT(PRCP("I"),1)
IF 'PRCPPRIM
QUIT
+11 SET PRCPINNM=$$INVNAME^PRCPUX1(PRCPPRIM)
+12 SET PRCPSECO=PRCP("I")
+13 ;
+14 SET IOP="HOME"
DO ^%ZIS
KILL IOP
+15 ;
+16 ; srops returns ^dpt(dfn,0) and ^srf(srtn,0)
+17 FOR
WRITE !
KILL SRTN
DO ^SROPS
if '$GET(DFN)!('$GET(SRTN))
QUIT
Begin DoDot:1
+18 SET PRCPPAT=DFN
SET PRCPSURG=SRTN
+19 DO SURGDATA^PRCPCRPL(PRCPSURG,".09;27")
+20 SET OPCODE=+$GET(PRCPSDAT(130,PRCPSURG,27,"I"))
SET OPDATEI=$GET(PRCPSDAT(130,PRCPSURG,.09,"I"))
+21 WRITE !?2,"Operation: ",$SELECT('OPCODE:"<< NONE SPECIFIED >>",1:$TRANSLATE($$ICPT^PRCPCUT1(OPCODE,OPDATEI),"^"," "))
+22 WRITE !!?2,"** Distribution from inventory point: ",PRCPINNM
+23 ;
+24 ; if no orders placed, cc's linked to operation, ask for automatic
+25 SET (PRCPFAUT,PRCPFLAG,PRCPFNEW,ORDERDA)=0
+26 IF '$DATA(^PRCP(445.3,"ASR",PRCPPAT,PRCPSURG))
IF $DATA(^PRCP(445.7,"AOP",+OPCODE))
SET PRCPFAUT=1
DO AUTOORD^PRCPCSO1
if PRCPFLAG
QUIT
IF 'ORDERDA
SET PRCPFAUT=0
+27 IF PRCPFAUT
SET PRCPFNEW=1
+28 ;
+29 ; if not automatic ordering, ask to select order
+30 IF 'PRCPFAUT
DO ASKORDER
if 'ORDERDA
QUIT
LOCK +^PRCP(445.3,ORDERDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445.3,ORDERDA,0)
QUIT
+31 IF 'PRCPFAUT
DO ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies")
+32 ;
+33 ; ask to delete order if order is not new (prcpfnew=1)
+34 IF '$GET(PRCPFNEW)
KILL PRCPFLAG
Begin DoDot:2
+35 SET XP=" Do you want to DELETE the order"
SET XH=" Enter 'YES' to delete the order, 'NO' to continue, '^' to exit."
+36 WRITE !!
SET %=$$YN^PRCPUYN(2)
+37 IF %=1
DO DELORDER^PRCPOPD(ORDERDA)
SET PRCPFLAG=1
QUIT
+38 IF %'=2
SET PRCPFLAG=1
QUIT
End DoDot:2
IF $GET(PRCPFLAG)
DO UNLOCK
QUIT
+39 ;
+40 IF 'PRCPFAUT
WRITE !!
SET PRCPFLAG=$$TYPE^PRCPOPUS(ORDERDA)
IF PRCPFLAG
DO UNLOCK
QUIT
+41 ;
+42 ; if automatic ordering, add items to order
+43 IF PRCPFAUT
DO AUTOITEM
IF PRCPFLAG
SET PRCPFAUT=0
+44 ;
+45 IF 'PRCPFAUT
Begin DoDot:2
+46 ; show items which should be ordered for opcode
+47 DO SHOWCC^PRCPCSOU(OPCODE,ORDERDA,OPDATEI)
+48 DO ITEMS^PRCPOPEE(ORDERDA)
End DoDot:2
+49 IF '$ORDER(^PRCP(445.3,ORDERDA,1,0))
DO DELORDER^PRCPOPD(ORDERDA)
DO UNLOCK
QUIT
+50 ;
+51 ; ask remarks
+52 WRITE !!
IF $$REMARKS^PRCPOPUS(ORDERDA)
QUIT
+53 ; ask to release order
+54 IF $$ASKREL^PRCPOPR(ORDERDA,1)=1
DO RELEASE^PRCPOPR(ORDERDA)
+55 IF $PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",6)'="R"
DO UNLOCK
QUIT
+56 WRITE !,"* * * ORDER HAS BEEN RELEASED * * *"
+57 ;
+58 ; order is released, print picking ticket automatically
+59 SET (PRCPDEV,ZTIO)=$PIECE($GET(^PRCP(445,PRCPPRIM,"DEV")),"^")
IF ZTIO=""
WRITE !,"NO DEVICE SPECIFIED FOR PRINTING THE PICKING TICKET IN ",$EXTRACT(PRCPINNM,1,15)
DO UNLOCK
QUIT
+60 DO BUILD^PRCPOPT(ORDERDA)
+61 DO VARIABLE^PRCPOPU
+62 SET ZTDESC="Print Picking Ticket Automatically"
SET ZTRTN="DQ^PRCPOPT"
+63 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ORDERDA")=""
SET ZTSAVE("^TMP($J,""PRCPOPT PICK LIST"",")=""
SET ZTSAVE("ZTREQ")="@"
+64 DO ^%ZTLOAD
DO Q^PRCPOPT
KILL IO("Q"),ZTSK
+65 WRITE !!,"Picking Ticket Queued on printer ",PRCPDEV," in ",$EXTRACT(PRCPINNM,1,15)," !"
+66 DO UNLOCK
End DoDot:1
+67 QUIT
+68 ;
+69 ;
UNLOCK ; unlock distribution order
+1 DO CLEAR^PRCPULOC(445.3,ORDERDA,0)
+2 LOCK -^PRCP(445.3,ORDERDA,0)
+3 QUIT
+4 ;
+5 ;
NO ; not available
+1 WRITE !,"NOT AVAILABLE, SURGERY PACKAGE NOT LOADED."
+2 QUIT
+3 ;
+4 ;
PATLINK(ORDERDA,PATIENT,SURGERY) ; link patient da and surgery da to order da
+1 NEW %,D0,DA,DI,DIC,DIE,DIPGM,DQ,DR,X,Y
+2 IF '$DATA(^PRCP(445.3,ORDERDA,0))
QUIT
+3 SET DA=ORDERDA
SET (DIC,DIE)="^PRCP(445.3,"
SET DR="129///"_$CHAR(96)_PATIENT_";130///"_$CHAR(96)_SURGERY
DO ^DIE
+4 QUIT
+5 ;
+6 ;
AUTOITEM ; automatically put items in order
+1 NEW CCITEM,ITEMDA
+2 WRITE !!,"ADDING ITEMS TO THE ORDER:"
+3 SET (CCITEM,PRCPFLAG)=0
FOR
SET CCITEM=$ORDER(^PRCP(445.7,"AOP",OPCODE,CCITEM))
if 'CCITEM
QUIT
Begin DoDot:1
+4 WRITE !,$EXTRACT($$DESCR^PRCPUX1(PRCPPRIM,CCITEM),1,30),?32,"MI#",CCITEM,?45
+5 SET ITEMDA=$$ITEMADD^PRCPOPUS(ORDERDA,CCITEM,1)
+6 IF 'ITEMDA
WRITE "*** ITEM NOT ORDERED ***"
SET PRCPFLAG=1
QUIT
+7 WRITE "Item Ordered"
End DoDot:1
+8 QUIT
+9 ;
+10 ;
ASKORDER ; ask for order selection
+1 ; show orders already placed for patient and operation
+2 DO SHOWORD^PRCPCSOU(PRCPPAT,PRCPSURG)
+3 WRITE !
+4 SET ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"",1)
IF 'ORDERDA
QUIT
+5 ; tie patient and operation to the order
+6 IF $GET(PRCPFNEW)
DO PATLINK(ORDERDA,PRCPPAT,PRCPSURG)
+7 IF $PIECE($GET(^PRCP(445.3,ORDERDA,2)),"^",1,2)'=(PRCPPAT_"^"_PRCPSURG)
WRITE !,"YOU CAN ONLY SELECT ORDERS WHICH HAVE BEEN PLACED FOR THIS PATIENT AND OPERATION"
GOTO ASKORDER
+8 QUIT
