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