source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSSQT.m@ 1389

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

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1PRCPSSQT ;WISC/CC-Request GIP QOH be overwitten by supply station values ;04/01
2V ;;5.1;IFCAP;**24**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; option requires multiple keys and other access privileges.
5 N %,%DT,DA,DIE,DIR,DR,DTOUT,DUOUT,PRCPACT,PRCPDATA,PRCPNEXT
6 N PRCPREQ,PRCPSTOP,PRCPTIME,X,Y,%
7 ;
8 I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"
9 D ^PRCPUSEL Q:'$G(PRCP("I"))
10 I PRCP("DPTYPE")'="S" Q
11 I $P($G(^PRCP(445,PRCP("I"),5)),"^",1)']"" D EN^DDIOL("This secondary is not linked to a supply station") Q
12 I '$$KEY^PRCPUREP("PRCP2 MGRKEY",DUZ) D EN^DDIOL("You must be a secondary inventory point manager to user this option.") Q
13 I '$$KEY^PRCPUREP("PRCPSSQOH",DUZ) D EN^DDIOL("You must be authorized to request an adjustment to supply station values") Q
14 I '$D(^PRCP(445,PRCP("I"),8,DUZ,0)) D Q
15 . D EN^DDIOL("You may not request an update for this inventory point.")
16 . D EN^DDIOL("Please contact your application coordinator.")
17 ;
18 L +^PRCP(445,PRCP("I"),7):3 I $T=0 D EN^DDIOL("The request file is busy. Please try again later.") Q
19 D ADD^PRCPULOC(445,PRCP("I")_"-7",0,"Request GIP Quantity Replacement")
20 S PRCPSTOP=0
21 ;
22 ; check to see if request is pending - allow deletion if exists
23 S PRCPREQ=$G(^PRCP(445,PRCP("I"),7))
24 I $P(PRCPREQ,"^")]"" D I PRCPSTOP G EXIT
25 . S Y=$P(PRCPREQ,"^",2) X ^DD("DD")
26 . S PRCPTIME=Y
27 . D EN^DDIOL(" ")
28 . N DA,DIE,DIR,DR
29 . S DIR(0)="Y"
30 . S DIR("A",1)=$P(^VA(200,+PRCPREQ,0),"^")_" made a request on "_PRCPTIME
31 . S DIR("A",2)=" "
32 . S DIR("A")="Do you wish to remove this"
33 . S DIR("?")="Enter 'Y' or 'YES' to delete the current request"
34 . S DIR("?",1)="Enter 'N' or 'NO' to retain the current request and quit"
35 . D ^DIR
36 . I $D(DUOUT)!$D(DTOUT) S PRCPSTOP=1 Q
37 . I Y=0 S PRCPSTOP=1 Q
38 . S DIE="^PRCP(445,",DA=PRCP("I"),DR="24////@;25////@"
39 . D ^DIE
40 . D EN^DDIOL("The current request has been deleted.")
41 . Q
42 ;
43 K X S X(1)="WARNING: USE THIS OPTION ONLY IF THE INTERFACE IS FUNCTIONING WELL AND IS "
44 S X(2)=" UP-TO-DATE ON PROCESSING TRANSACTIONS."
45 D DISPLAY^PRCPUX2(1,79,.X)
46 D EN^DDIOL(" ")
47 D EN^DDIOL("Your name will be on the Transaction Register for all adjusted items.")
48 D EN^DDIOL("Please keep any records needed to justify these adjustments.")
49 ;
50 ; ask if they wish to proceed.
51 D EN^DDIOL(" ")
52 S DIR(0)="Y"
53 S DIR("A")="Do you wish to create a new request"
54 D ^DIR K DIR
55 I $D(DUOUT)!$D(DTOUT) G EXIT
56 I Y=0 D EN^DDIOL("No request created.") G EXIT
57 ;
58 I $$ORDCHK^PRCPUITM(0,+PRCP("I"),"R","R") D G EXIT
59 . D EN^DDIOL(" ")
60 . D EN^DDIOL("This inventory has released orders that are not yet posted.")
61 . D EN^DDIOL("YOU MUST FIRST POST OR DELETE ALL RELEASED ORDERS ON THIS INVENTORY POINT.")
62 ;
63 D EN^DDIOL(" ")
64 S DIR("A")="Is recent supply station activity on the transaction register"
65 S DIR(0)="Y"
66 D ^DIR K DIR
67 I Y=0 D I PRCPSTOP G EXIT
68 . S X(1)="Do not run this option until you know the interface is working correctly. "
69 . S X(2)="Call your IRM to verify:"
70 . S X(3)="1) TaskMan is running"
71 . S X(4)="2) PRCP2 SUPPLY STATION TXN RUN is scheduled for every 3-5 minutes."
72 . S X(5)="3) The interface links are set up properly and are open."
73 . D DISPLAY^PRCPUX2(1,79,.X)
74 . S PRCPSTOP=1
75 ;
76 ; check for unprocessed transactions, stop if first transaction is older than 20 minutes
77 S PRCPNEXT=$O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),""))
78 I PRCPNEXT]"" D I PRCPSTOP=1 G EXIT
79 . ; get info about txn, if older than 20 minutes, stop
80 . N DIR,PRCPACT,PRCPTIME
81 . D EN^DDIOL(" ")
82 . D EN^DDIOL("There are supply station transactions waiting to be processed.")
83 . S PRCPDATA=^PRCP(447.1,PRCPNEXT,0)
84 . S %DT="S",Y=$P(PRCPDATA,"^",4) D DD^%DT S PRCPACT=Y
85 . D EN^DDIOL("The oldest transaction was created at "_PRCPACT)
86 . S %DT="S",Y=$P(PRCPDATA,"^",8) D DD^%DT S PRCPTIME=Y
87 . D EN^DDIOL("and was received by VistA at "_PRCPTIME)
88 . S Y=$P(PRCPDATA,"^",8) D NOW^%DTC
89 . I %-Y>.002 D S PRCPSTOP=1 QUIT
90 . . S X(1)="This is more than 20 minutes ago. You may not proceed until these"
91 . . S X(2)="transactions are processed. Call IRM and verify the PRCP2 Supply Station"
92 . . S X(3)="TXN Run option is scheduled to run every 3 to 5 minutes in TaskMan."
93 . . D DISPLAY^PRCPUX2(1,79,.X)
94 . S Y=$P(PRCPDATA,"^",4),PRCPTIME=$P(PRCPDATA,"^",8)
95 . I PRCPTIME-PRCPDATA>0 D
96 . . D EN^DDIOL(" ")
97 . . D EN^DDIOL("This transaction implies the clock setting on the supply station is wrong.")
98 . . D EN^DDIOL("Please adjust the time on the supply station system to match the VistA")
99 . . D EN^DDIOL("system before filing your request")
100 . S DIR("A")="Do you wish to proceed?"
101 . S DIR(0)="Y"
102 . D ^DIR
103 . I $D(DUOUT)!$D(DTOUT) S PRCPSTOP=1 QUIT
104 . I Y=0 S PRCPSTOP=1 QUIT
105 . Q
106 ;
107 ; ask for signature, if verified save DUZ and date/time in node 7 of file 445
108 D ESIG^PRCUESIG(DUZ,.PRCPSTOP)
109 I PRCPSTOP'=1 D EN^DDIOL("No request to replace the GIP quantities was filed.")
110 I PRCPSTOP=1 D
111 . W !
112 . D NOW^%DTC
113 . S ^PRCP(445,PRCP("I"),7)=DUZ_"^"_%
114 . D EN^DDIOL("Your request to replace GIP values is now on file.")
115 . D BLDSEG^PRCPHLQU(PRCP("I"))
116 . D EN^DDIOL(" ")
117 . D EN^DDIOL("Sending request for quantity information to supply station...")
118 . D EN^DDIOL(" ")
119 . D EN^DDIOL("The first QOH transaction time stamped by the supply station after")
120 . S Y=% X ^DD("DD")
121 . D EN^DDIOL(Y_" will cause the GIP values to be replaced.")
122 . S PRCPSTOP=0
123 ;
124EXIT L -^PRCP(445,PRCP("I"),7)
125 D CLEAR^PRCPULOC(445,PRCP("I")_"-7",0)
126 Q
Note: See TracBrowser for help on using the repository browser.