source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCSOR.m@ 1806

Last change on this file since 1806 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1PRCPCSOR ;WISC/RFJ-surgery order supplies ;01 Sep 93
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N X
5 S X="SROPS" X:$D(^%ZOSF("TEST")) ^("TEST") I '$T D NO Q
6 I '$$VERSION^XPDUTL("SURGERY") D NO Q
7 ;
8 D ^PRCPUSEL Q:'$G(PRCP("I"))
9 I "S"'=PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A SECONDARY INVENTORY POINT." Q
10 N DIPGM,DFN,OPCODE,ORDERDA,PRCPDEV,PRCPFAUT,PRCPFLAG,PRCPFNEW,PRCPFONE,PRCPINNM,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSDAT,PRCPSECO,PRCPSURG,SRTN,Y
11 S PRCPPRIM=+$$SPD^PRCPUDPT(PRCP("I"),1) I 'PRCPPRIM Q
12 S PRCPINNM=$$INVNAME^PRCPUX1(PRCPPRIM)
13 S PRCPSECO=PRCP("I")
14 ;
15 S IOP="HOME" D ^%ZIS K IOP
16 ;
17 ; srops returns ^dpt(dfn,0) and ^srf(srtn,0)
18 F W ! K SRTN D ^SROPS Q:'$G(DFN)!('$G(SRTN)) D
19 . S PRCPPAT=DFN,PRCPSURG=SRTN
20 . D SURGDATA^PRCPCRPL(PRCPSURG,27)
21 . S OPCODE=+$G(PRCPSDAT(130,PRCPSURG,27,"I"))
22 . W !?2,"Operation: ",$S('OPCODE:"<< NONE SPECIFIED >>",1:OPCODE)," ",$P($$ICPT^PRCPCUT1(OPCODE),"^",2)
23 . W !!?2,"** Distribution from inventory point: ",PRCPINNM
24 . ;
25 . ; if no orders placed, cc's linked to operation, ask for automatic
26 . S (PRCPFAUT,PRCPFLAG,PRCPFNEW,ORDERDA)=0
27 . 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
28 . I PRCPFAUT S PRCPFNEW=1
29 . ;
30 . ; if not automatic ordering, ask to select order
31 . I 'PRCPFAUT D ASKORDER Q:'ORDERDA L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) Q
32 . I 'PRCPFAUT D ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies")
33 . ;
34 . ; ask to delete order if order is not new (prcpfnew=1)
35 . I '$G(PRCPFNEW) K PRCPFLAG D I $G(PRCPFLAG) D UNLOCK Q
36 . . S XP=" Do you want to DELETE the order",XH=" Enter 'YES' to delete the order, 'NO' to continue, '^' to exit."
37 . . W !! S %=$$YN^PRCPUYN(2)
38 . . I %=1 D DELORDER^PRCPOPD(ORDERDA) S PRCPFLAG=1 Q
39 . . I %'=2 S PRCPFLAG=1 Q
40 . ;
41 . I 'PRCPFAUT W !! S PRCPFLAG=$$TYPE^PRCPOPUS(ORDERDA) I PRCPFLAG D UNLOCK Q
42 . ;
43 . ; if automatic ordering, add items to order
44 . I PRCPFAUT D AUTOITEM I PRCPFLAG S PRCPFAUT=0
45 . ;
46 . I 'PRCPFAUT D
47 . . ; show items which should be ordered for opcode
48 . . D SHOWCC^PRCPCSOU(OPCODE,ORDERDA)
49 . . D ITEMS^PRCPOPEE(ORDERDA)
50 . I '$O(^PRCP(445.3,ORDERDA,1,0)) D DELORDER^PRCPOPD(ORDERDA) D UNLOCK Q
51 . ;
52 . ; ask remarks
53 . W !! I $$REMARKS^PRCPOPUS(ORDERDA) Q
54 . ; ask to release order
55 . I $$ASKREL^PRCPOPR(ORDERDA,1)=1 D RELEASE^PRCPOPR(ORDERDA)
56 . I $P($G(^PRCP(445.3,ORDERDA,0)),"^",6)'="R" D UNLOCK Q
57 . W !,"* * * ORDER HAS BEEN RELEASED * * *"
58 . ;
59 . ; order is released, print picking ticket automatically
60 . 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
61 . D BUILD^PRCPOPT(ORDERDA)
62 . D VARIABLE^PRCPOPU
63 . S ZTDESC="Print Picking Ticket Automatically",ZTRTN="DQ^PRCPOPT"
64 . S ZTSAVE("PRCP*")="",ZTSAVE("ORDERDA")="",ZTSAVE("^TMP($J,""PRCPOPT PICK LIST"",")="",ZTSAVE("ZTREQ")="@"
65 . D ^%ZTLOAD,Q^PRCPOPT K IO("Q"),ZTSK
66 . W !!,"Picking Ticket Queued on printer ",PRCPDEV," in ",$E(PRCPINNM,1,15)," !"
67 . D UNLOCK
68 Q
69 ;
70 ;
71UNLOCK ; unlock distribution order
72 D CLEAR^PRCPULOC(445.3,ORDERDA,0)
73 L -^PRCP(445.3,ORDERDA,0)
74 Q
75 ;
76 ;
77NO ; not available
78 W !,"NOT AVAILABLE, SURGERY PACKAGE NOT LOADED."
79 Q
80 ;
81 ;
82PATLINK(ORDERDA,PATIENT,SURGERY) ; link patient da and surgery da to order da
83 N %,D0,DA,DI,DIC,DIE,DIPGM,DQ,DR,X,Y
84 I '$D(^PRCP(445.3,ORDERDA,0)) Q
85 S DA=ORDERDA,(DIC,DIE)="^PRCP(445.3,",DR="129///"_$C(96)_PATIENT_";130///"_$C(96)_SURGERY D ^DIE
86 Q
87 ;
88 ;
89AUTOITEM ; automatically put items in order
90 N CCITEM,ITEMDA
91 W !!,"ADDING ITEMS TO THE ORDER:"
92 S (CCITEM,PRCPFLAG)=0 F S CCITEM=$O(^PRCP(445.7,"AOP",OPCODE,CCITEM)) Q:'CCITEM D
93 . W !,$E($$DESCR^PRCPUX1(PRCPPRIM,CCITEM),1,30),?32,"MI#",CCITEM,?45
94 . S ITEMDA=$$ITEMADD^PRCPOPUS(ORDERDA,CCITEM,1)
95 . I 'ITEMDA W "*** ITEM NOT ORDERED ***" S PRCPFLAG=1 Q
96 . W "Item Ordered"
97 Q
98 ;
99 ;
100ASKORDER ; ask for order selection
101 ; show orders already placed for patient and operation
102 D SHOWORD^PRCPCSOU(PRCPPAT,PRCPSURG)
103 W !
104 S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"",1) I 'ORDERDA Q
105 ; tie patient and operation to the order
106 I $G(PRCPFNEW) D PATLINK(ORDERDA,PRCPPAT,PRCPSURG)
107 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
108 Q
Note: See TracBrowser for help on using the repository browser.