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

PRCPCSOR.m

Go to the documentation of this file. 
  1. PRCPCSOR ;WISC/RFJ-surgery order supplies ; 06/23/2009  2:23 PM
  1.  ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  N X
  1.  S X="SROPS" X:$D(^%ZOSF("TEST")) ^("TEST") I '$T D NO Q
  1.  I '$$VERSION^XPDUTL("SURGERY") D NO Q
  1.  ;
  1.  D ^PRCPUSEL Q:'$G(PRCP("I"))
  1.  I "S"'=PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A SECONDARY INVENTORY POINT." Q
  1.  N DIPGM,DFN,OPCODE,OPDATEI,ORDERDA,PRCPDEV,PRCPFAUT,PRCPFLAG,PRCPFNEW,PRCPFONE,PRCPINNM,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSDAT,PRCPSECO,PRCPSURG,SRTN,Y
  1.  S PRCPPRIM=+$$SPD^PRCPUDPT(PRCP("I"),1) I 'PRCPPRIM Q
  1.  S PRCPINNM=$$INVNAME^PRCPUX1(PRCPPRIM)
  1.  S PRCPSECO=PRCP("I")
  1.  ;
  1.  S IOP="HOME" D ^%ZIS K IOP
  1.  ;
  1.  ;  srops returns ^dpt(dfn,0) and ^srf(srtn,0)
  1.  F  W ! K SRTN D ^SROPS Q:'$G(DFN)!('$G(SRTN))  D
  1.  .   S PRCPPAT=DFN,PRCPSURG=SRTN
  1.  .   D SURGDATA^PRCPCRPL(PRCPSURG,".09;27")
  1.  .   S OPCODE=+$G(PRCPSDAT(130,PRCPSURG,27,"I")),OPDATEI=$G(PRCPSDAT(130,PRCPSURG,.09,"I"))
  1.  .   W !?2,"Operation: ",$S('OPCODE:"<< NONE SPECIFIED >>",1:$TR($$ICPT^PRCPCUT1(OPCODE,OPDATEI),"^"," "))
  1.  .   W !!?2,"** Distribution from inventory point: ",PRCPINNM
  1.  .   ;
  1.  .   ;  if no orders placed, cc's linked to operation, ask for automatic
  1.  .   S (PRCPFAUT,PRCPFLAG,PRCPFNEW,ORDERDA)=0
  1.  .   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
  1.  .   I PRCPFAUT S PRCPFNEW=1
  1.  .   ;
  1.  .   ;  if not automatic ordering, ask to select order
  1.  .   I 'PRCPFAUT D ASKORDER Q:'ORDERDA  L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) Q
  1.  .   I 'PRCPFAUT D ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies")
  1.  .   ;
  1.  .   ;  ask to delete order if order is not new (prcpfnew=1)
  1.  .   I '$G(PRCPFNEW) K PRCPFLAG D  I $G(PRCPFLAG) D UNLOCK Q
  1.  .   .   S XP="  Do you want to DELETE the order",XH="  Enter 'YES' to delete the order, 'NO' to continue, '^' to exit."
  1.  .   .   W !! S %=$$YN^PRCPUYN(2)
  1.  .   .   I %=1 D DELORDER^PRCPOPD(ORDERDA) S PRCPFLAG=1 Q
  1.  .   .   I %'=2 S PRCPFLAG=1 Q
  1.  .   ;
  1.  .   I 'PRCPFAUT W !! S PRCPFLAG=$$TYPE^PRCPOPUS(ORDERDA) I PRCPFLAG D UNLOCK Q
  1.  .   ;
  1.  .   ;  if automatic ordering, add items to order
  1.  .   I PRCPFAUT D AUTOITEM I PRCPFLAG S PRCPFAUT=0
  1.  .   ;
  1.  .   I 'PRCPFAUT D
  1.  .   .   ;  show items which should be ordered for opcode
  1.  .   .   D SHOWCC^PRCPCSOU(OPCODE,ORDERDA,OPDATEI)
  1.  .   .   D ITEMS^PRCPOPEE(ORDERDA)
  1.  .   I '$O(^PRCP(445.3,ORDERDA,1,0)) D DELORDER^PRCPOPD(ORDERDA) D UNLOCK Q
  1.  .   ;
  1.  .   ;  ask remarks
  1.  .   W !! I $$REMARKS^PRCPOPUS(ORDERDA) Q
  1.  .   ;  ask to release order
  1.  .   I $$ASKREL^PRCPOPR(ORDERDA,1)=1 D RELEASE^PRCPOPR(ORDERDA)
  1.  .   I $P($G(^PRCP(445.3,ORDERDA,0)),"^",6)'="R" D UNLOCK Q
  1.  .   W !,"* * * ORDER HAS BEEN RELEASED * * *"
  1.  .   ;
  1.  .   ;  order is released, print picking ticket automatically
  1.  .   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
  1.  .   D BUILD^PRCPOPT(ORDERDA)
  1.  .   D VARIABLE^PRCPOPU
  1.  .   S ZTDESC="Print Picking Ticket Automatically",ZTRTN="DQ^PRCPOPT"
  1.  .   S ZTSAVE("PRCP*")="",ZTSAVE("ORDERDA")="",ZTSAVE("^TMP($J,""PRCPOPT PICK LIST"",")="",ZTSAVE("ZTREQ")="@"
  1.  .   D ^%ZTLOAD,Q^PRCPOPT K IO("Q"),ZTSK
  1.  .   W !!,"Picking Ticket Queued on printer ",PRCPDEV," in ",$E(PRCPINNM,1,15)," !"
  1.  .   D UNLOCK
  1.  Q
  1.  ;
  1.  ;
  1. UNLOCK ;  unlock distribution order
  1.  D CLEAR^PRCPULOC(445.3,ORDERDA,0)
  1.  L -^PRCP(445.3,ORDERDA,0)
  1.  Q
  1.  ;
  1.  ;
  1. NO ;  not available
  1.  W !,"NOT AVAILABLE, SURGERY PACKAGE NOT LOADED."
  1.  Q
  1.  ;
  1.  ;
  1.  N %,D0,DA,DI,DIC,DIE,DIPGM,DQ,DR,X,Y
  1.  I '$D(^PRCP(445.3,ORDERDA,0)) Q
  1.  S DA=ORDERDA,(DIC,DIE)="^PRCP(445.3,",DR="129///"_$C(96)_PATIENT_";130///"_$C(96)_SURGERY D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. AUTOITEM ;  automatically put items in order
  1.  N CCITEM,ITEMDA
  1.  W !!,"ADDING ITEMS TO THE ORDER:"
  1.  S (CCITEM,PRCPFLAG)=0 F  S CCITEM=$O(^PRCP(445.7,"AOP",OPCODE,CCITEM)) Q:'CCITEM  D
  1.  .   W !,$E($$DESCR^PRCPUX1(PRCPPRIM,CCITEM),1,30),?32,"MI#",CCITEM,?45
  1.  .   S ITEMDA=$$ITEMADD^PRCPOPUS(ORDERDA,CCITEM,1)
  1.  .   I 'ITEMDA W "*** ITEM NOT ORDERED ***" S PRCPFLAG=1 Q
  1.  .   W "Item Ordered"
  1.  Q
  1.  ;
  1.  ;
  1. ASKORDER ;  ask for order selection
  1.  ;  show orders already placed for patient and operation
  1.  D SHOWORD^PRCPCSOU(PRCPPAT,PRCPSURG)
  1.  W !
  1.  S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"",1) I 'ORDERDA Q
  1.  ;  tie patient and operation to the order
  1.  I $G(PRCPFNEW) D PATLINK(ORDERDA,PRCPPAT,PRCPSURG)
  1.  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
  1.  Q