PRCHEB ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;11-20-92/12:01
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;CANCEL UNOBLIGATED REQUISITION
S PRCHNRQ=1 D EN7^PRCHEA K PRCHNRQ
Q
;
EN0 ;REMOVE 2237 FROM REQUISITION
S PRCHNRQ=1 D ^PRCHE2 K PRCHNRQ
Q
;
EN1 ;AMENDMENT TO REQUISITION
S PRCHNRQ=1 D EN6^PRCHEA K PRCHNRQ
Q
;
EN2 ;ADJUSTMENT VOUCHER TO RECV.REPORT FOR REQUISITION
S (PRCHREQ,PRCHNRQ)=1 D EN14^PRCHE K PRCHNRQ
Q
;
EN3 ; CREATE A NEW IMPREST FUND P.O.
D ST Q:'$D(PRC("SITE"))
EN30 S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q:'$D(PRCHPO) D LCK1 G:'$D(DA) EN30 S X=1 D ENS^PRCHSTAT,^PRCHNPO L
G EN30
;
EN4 ;EDIT AN IMPREST FUND P.O.
D ST Q:'$D(PRC("SITE"))
;
EN40 S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("S")="$P(^(0),U,2)=7" D EN3^PRCHPAT Q:'$D(PRCHPO) I X>9!'X W " ??",$C(7) G EN40
D LCK1 G:'$D(DA) EN40 D ^PRCHNPO L
G EN40
;
EN5 ;RECEIVING FOR IMPREST FUND P.O.
S PRCHPGM="EN5^PRCHEB",PRCHIMP=1 D ^PRCHREC K PRCHPGM,PRCHIMP
Q
;
EN6 ;CANCEL UNOBLIGATED IF P.O.
S PRCHIMP=1 D EN7^PRCHEA K PRCHIMP
Q
;
EN7 ;REMOVE 2237 FROM IF P.O.
S PRCHIMP=1 D ^PRCHE2 K PRCHIMP
Q
;
EN8 ;ENTER COMPLETED DEPOT/GSA PUSH P.O. IN REGISTER
D ST Q:'$D(PRC("SITE"))
W !!!,"NOTE: This option will just reserve the PAT (P.O.) numbers needed for",!,"a DEPOT or GSA PUSH transaction. It will take 3 entries to complete the",!
W "order (Regular, Drugs & Subsistence). The Control Point obligated balance for",!
W "the warehouse will NOT be updated. Both the PUSH RELEASE (acquisitions",!,"and the RECEIPTS RELEASE (receiving) LOG code sheets must be generated",!,"using the 'CREATE A CODE SHEET' option."
EN80 S PRCHNRQ=1,PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1,PRCHP("S2")=",$P(^(0),U,1)[""G""" D EN^PRCHPAT I '$D(PRCHPO) K PRCHNRQ G Q^PRCHEA
D LCK1 G:'$D(DA) EN80 S PRCHPUSH=1,DIE=DIC,DR="[PRCHPUSH]" D ^DIE,EN3^PRCHNPO7 L
G EN80
;
EN9 ;EDIT COMPLETED DEPOT/GSA PUSH P.O. IN REGISTER
D ST Q:'$D(PRC("SITE"))
EN90 S PRCHNRQ=1,PRCHP("A")="REQUISITION NUMBER: ",PRCHP("T")=8,PRCHP("S")="$P(^(0),U,1)[""G""" D EN3^PRCHPAT I '$D(PRCHPO) K PRCHNRQ G Q^PRCHEA
I X>9!'X W " ??",$C(7) G EN90
D LCK1 G:'$D(DA) EN90 S PRCHPUSH=1,DIE=DIC,DR="[PRCHPUSH]" D ^DIE,EN3^PRCHNPO7 L
G EN90
;
ENA ;CHANGE DELIVERY DATE ON REQUISITION
S PRCHNRQ=1 D EN12^PRCHE K PRCHNRQ
Q
;
ENB ;RETURN SUPPLY FUND P.O. FROM PPM TO P&C FOR RE-EDITING
D ST Q:'$D(PRC("SITE"))
ENB1 S PRCHP("S")="""137""[$P(^(0),U,2),$P(^(0),U,19)=2,$D(^(7)),$P(^(7),U,2)=22,$D(^PRC(442,""AE"",""N"",+Y))"
D EN3^PRCHPAT G:Y'>0 Q
W !,$C(7) S %A="Are you sure that you want to return this to P&C for re-editing"
S %=1,%B="Answering 'YES' will remove the Purchasing Agent's signature so that they",%B(1)="can re-edit the P.O." D ^PRCFYN G:%=2 ENB1 I %<0 W !,"No Action Taken." R X:3 G ENB1
S DA=PRCHPO D LCK1 G:'$D(DA) ENB1
;S $P(^PRC(442,DA,12),"^",2,3)="^",X=6 D ENS^PRCHSTAT W !,"Purchase Order has been returned, please notify P&C, IMMEDIATELY",$C(7),! L G Q
D REMOVE^PRCHES5(DA) S X=6 D ENS^PRCHSTAT W !,"Purchase Order has been returned, please notify P&C, IMMEDIATELY",$C(7),! L
G Q
;
Q K DA,DIC,PRC,PRCF,PRCHP,PRCHPO
Q
;
LCK1 S DIC="^PRC(442,"
;
LCK L @(DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
Q
;
ST S PRCF("X")="S" D ^PRCFSITE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEB 3461 printed Oct 16, 2024@18:07:52 Page 2
PRCHEB ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;11-20-92/12:01
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;CANCEL UNOBLIGATED REQUISITION
+1 SET PRCHNRQ=1
DO EN7^PRCHEA
KILL PRCHNRQ
+2 QUIT
+3 ;
EN0 ;REMOVE 2237 FROM REQUISITION
+1 SET PRCHNRQ=1
DO ^PRCHE2
KILL PRCHNRQ
+2 QUIT
+3 ;
EN1 ;AMENDMENT TO REQUISITION
+1 SET PRCHNRQ=1
DO EN6^PRCHEA
KILL PRCHNRQ
+2 QUIT
+3 ;
EN2 ;ADJUSTMENT VOUCHER TO RECV.REPORT FOR REQUISITION
+1 SET (PRCHREQ,PRCHNRQ)=1
DO EN14^PRCHE
KILL PRCHNRQ
+2 QUIT
+3 ;
EN3 ; CREATE A NEW IMPREST FUND P.O.
+1 DO ST
if '$DATA(PRC("SITE"))
QUIT
EN30 SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("T")=7
SET PRCHP("S")=3
DO EN^PRCHPAT
if '$DATA(PRCHPO)
QUIT
DO LCK1
if '$DATA(DA)
GOTO EN30
SET X=1
DO ENS^PRCHSTAT
DO ^PRCHNPO
LOCK
+1 GOTO EN30
+2 ;
EN4 ;EDIT AN IMPREST FUND P.O.
+1 DO ST
if '$DATA(PRC("SITE"))
QUIT
+2 ;
EN40 SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("S")="$P(^(0),U,2)=7"
DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
IF X>9!'X
WRITE " ??",$CHAR(7)
GOTO EN40
+1 DO LCK1
if '$DATA(DA)
GOTO EN40
DO ^PRCHNPO
LOCK
+2 GOTO EN40
+3 ;
EN5 ;RECEIVING FOR IMPREST FUND P.O.
+1 SET PRCHPGM="EN5^PRCHEB"
SET PRCHIMP=1
DO ^PRCHREC
KILL PRCHPGM,PRCHIMP
+2 QUIT
+3 ;
EN6 ;CANCEL UNOBLIGATED IF P.O.
+1 SET PRCHIMP=1
DO EN7^PRCHEA
KILL PRCHIMP
+2 QUIT
+3 ;
EN7 ;REMOVE 2237 FROM IF P.O.
+1 SET PRCHIMP=1
DO ^PRCHE2
KILL PRCHIMP
+2 QUIT
+3 ;
EN8 ;ENTER COMPLETED DEPOT/GSA PUSH P.O. IN REGISTER
+1 DO ST
if '$DATA(PRC("SITE"))
QUIT
+2 WRITE !!!,"NOTE: This option will just reserve the PAT (P.O.) numbers needed for",!,"a DEPOT or GSA PUSH transaction. It will take 3 entries to complete the",!
+3 WRITE "order (Regular, Drugs & Subsistence). The Control Point obligated balance for",!
+4 WRITE "the warehouse will NOT be updated. Both the PUSH RELEASE (acquisitions",!,"and the RECEIPTS RELEASE (receiving) LOG code sheets must be generated",!,"using the 'CREATE A CODE SHEET' option."
EN80 SET PRCHNRQ=1
SET PRCHP("A")="REQUISITION NUMBER"
SET PRCHP("T")=8
SET PRCHP("S")=1
SET PRCHP("S2")=",$P(^(0),U,1)[""G"""
DO EN^PRCHPAT
IF '$DATA(PRCHPO)
KILL PRCHNRQ
GOTO Q^PRCHEA
+1 DO LCK1
if '$DATA(DA)
GOTO EN80
SET PRCHPUSH=1
SET DIE=DIC
SET DR="[PRCHPUSH]"
DO ^DIE
DO EN3^PRCHNPO7
LOCK
+2 GOTO EN80
+3 ;
EN9 ;EDIT COMPLETED DEPOT/GSA PUSH P.O. IN REGISTER
+1 DO ST
if '$DATA(PRC("SITE"))
QUIT
EN90 SET PRCHNRQ=1
SET PRCHP("A")="REQUISITION NUMBER: "
SET PRCHP("T")=8
SET PRCHP("S")="$P(^(0),U,1)[""G"""
DO EN3^PRCHPAT
IF '$DATA(PRCHPO)
KILL PRCHNRQ
GOTO Q^PRCHEA
+1 IF X>9!'X
WRITE " ??",$CHAR(7)
GOTO EN90
+2 DO LCK1
if '$DATA(DA)
GOTO EN90
SET PRCHPUSH=1
SET DIE=DIC
SET DR="[PRCHPUSH]"
DO ^DIE
DO EN3^PRCHNPO7
LOCK
+3 GOTO EN90
+4 ;
ENA ;CHANGE DELIVERY DATE ON REQUISITION
+1 SET PRCHNRQ=1
DO EN12^PRCHE
KILL PRCHNRQ
+2 QUIT
+3 ;
ENB ;RETURN SUPPLY FUND P.O. FROM PPM TO P&C FOR RE-EDITING
+1 DO ST
if '$DATA(PRC("SITE"))
QUIT
ENB1 SET PRCHP("S")="""137""[$P(^(0),U,2),$P(^(0),U,19)=2,$D(^(7)),$P(^(7),U,2)=22,$D(^PRC(442,""AE"",""N"",+Y))"
+1 DO EN3^PRCHPAT
if Y'>0
GOTO Q
+2 WRITE !,$CHAR(7)
SET %A="Are you sure that you want to return this to P&C for re-editing"
+3 SET %=1
SET %B="Answering 'YES' will remove the Purchasing Agent's signature so that they"
SET %B(1)="can re-edit the P.O."
DO ^PRCFYN
if %=2
GOTO ENB1
IF %<0
WRITE !,"No Action Taken."
READ X:3
GOTO ENB1
+4 SET DA=PRCHPO
DO LCK1
if '$DATA(DA)
GOTO ENB1
+5 ;S $P(^PRC(442,DA,12),"^",2,3)="^",X=6 D ENS^PRCHSTAT W !,"Purchase Order has been returned, please notify P&C, IMMEDIATELY",$C(7),! L G Q
+6 DO REMOVE^PRCHES5(DA)
SET X=6
DO ENS^PRCHSTAT
WRITE !,"Purchase Order has been returned, please notify P&C, IMMEDIATELY",$CHAR(7),!
LOCK
+7 GOTO Q
+8 ;
Q KILL DA,DIC,PRC,PRCF,PRCHP,PRCHPO
+1 QUIT
+2 ;
LCK1 SET DIC="^PRC(442,"
+1 ;
LCK LOCK @(DIC_DA_"):0")
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+1 QUIT
+2 ;
ST SET PRCF("X")="S"
DO ^PRCFSITE
+1 QUIT
