PRCHEA ;WOIFO/ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;3/5/98 11:05 AM
V ;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN3 ;ADD A REQUISITION
;
;Variables PRCHNRQ and PRCHZZZ9 are flags stating that this is a
;REQUESITION.
;
N PRCHP,PRCHZZZ9
D ST
EN30 S (PRCHNRQ,PRCHZZZ9)=1,PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT I '$D(PRCHPO) K PRCHNRQ Q
D LCK1 G:'$D(DA) EN30 S X=1,DA=PRCHPO D ENS^PRCHSTAT
S Z=$P(^PRC(442,PRCHPO,0),"-",2),$P(^PRC(442,PRCHPO,18),"^",3)=$S($E(Z):$E(Z,2,6),1:$E(Z)_$E(Z,3,6))
D ^PRCHNPO L
G EN30
;
EN4 ;EDIT A REQUISITION
;
;Variables PRCHNREQ and PRCHZZZ9 are flags stating that this is a
;REQUESITION.
;
N PRCHP,PRCHZZZ9
D ST
EN40 S (PRCHNRQ,PRCHZZZ9)=1,PRCHP("A")="REQUISTION NUMBER: "
S PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)=5!($P(^(0),U,2)=8)!($P(^(0),U,2)=25)!($P(^(0),U,2)=26))"
S:$G(PRCHPC) PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P(^(0),U,2)=25"
D EN3^PRCHPAT I '$D(PRCHPO) K PRCHNRQ Q
I 'X W " ??",$C(7) G EN40
D LCK1 G:'$D(DA) EN40 D ^PRCHNPO L
G EN40
;
EN5 ;EDIT BOC IN ITEM FILE
S DIC="^PRC(441,",DIC(0)="AEMQ",DR=12 D ^DIC G:Y<0 Q S DA=+Y W ! F I=0:0 S I=$O(^PRC(441,DA,1,I)) Q:'I W !?3,^(I,0)
W ! S DIE=DIC D ^DIE,Q W !
G EN5
;
EN6 ;AMENDMENTS
N PRCHP S PRCHFLG=0 D ST
EN60 K PRCHP Q:'$D(PRC("SITE")) S PRCHP("S")="$P($G(^(7)),U,2)>19,(453328'[$P($G(^(7)),U,2)),($P(^(0),U,2)"
S:'$D(PRCHNRQ) PRCHP("S")=PRCHP("S")_"<8)" S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")=PRCHP("S")_"=8"
S PRCHFLG=1 D EN3^PRCHPAT Q:'$D(PRCHPO)
;I X=28!(X=33) W $C(7),!,"Amendments not allowed until after order has been Obligated!!" G EN60
I 'X W $C(7)," ??" G EN60
D ^PRCHAM
G EN60
;
EN7 ;CANCEL UNOBLIGATED PO
N PRCHP D ST
EN70 Q:'$D(PRC("SITE")) S PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)"
S:'$D(PRCHNRQ) PRCHP("S")=PRCHP("S")_"<8!($P(^(0),U,2)>24))"
S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")=PRCHP("S")_"=8)" S:$D(PRCHIMP) PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("S")="($P($G(^(7)),U,2)<9!($P($G(^(7)),U,2)=22))&($P(^(0),U,2)=7)"
D EN3^PRCHPAT Q:'$D(PRCHPO) I 'X W $C(7)," ??" G EN70
I $P(^PRC(442,PRCHPO,0),U,12) W $C(7),!!,"WARNING--2237 HAS NOT BEEN REMOVED FROM THIS ORDER!!" G EN70
D LCK1 G:'$D(DA) EN70 S %A=" SURE YOU WANT TO CANCEL PURCHASE ORDER ",%B="",%="" D ^PRCFYN I %'=1 W ?40," <NOTHING CANCELLED>",$C(7) G EN70
S X=$O(^PRCD(442.3,"C",45,0)),$P(^PRC(442,PRCHPO,0),U,15,16)="0^0" K ^(9) S (X,Y)=45,DA=PRCHPO D UPD^PRCHSTAT
; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D DEL^PRCV442A(PRCHPO)
G EN70
;
EN8 ;GRAB A PO NUMBER
D ST
EN80 Q:'$D(PRC("SITE")) K PRCHX W !!,"How many Purchase Order numbers do you want: " R X:DTIME Q:X["^" I X'=+X!(X<1)!(X>5)!'(X?1N) W " ??",$C(7),!,"Enter a number between 1 and 5." G EN80
S PRCHX=X,DIC="^PRC(442.6,",DIC(0)="QEAMZ",DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6)!($P(^(0),U,5)=7))",D="C" D IX^DIC I Y<0 K DIC Q
S DA=+Y D LCK K DIC G:'$D(DA) EN80 D WAIT^DICD S PRCHY=Y,PRCHY(0)=Y(0) F PRCHI=1:1:PRCHX D EN81
L W !,"Here is your Purchase Order Numbers: " F I=0:0 S I=$O(PRCHX(I)) Q:'I W !?37,PRCHX(I)
R !!,"Press RETURN to continue",X:DTIME K DIC,DA,PRCHX,PRCHY,Z Q
EN81 S X=$P(PRCHY,U,2),Z=$S(+$P(PRCHY(0),U,4)<$P(PRCHY(0),U,2):+$P(PRCHY(0),U,2),1:+$P(PRCHY(0),U,4)),L=$L(X)#2-3
EN82 I Z>$P(PRCHY(0),U,3) L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(PRCHY,U,2),$C(7) S PRCHI=PRCHX+1 Q
S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(PRCHY,U,2) G EN82
S $P(^PRC(442.6,+PRCHY,0),U,4)=+Z,DIC(0)="L",DIC="^PRC(442,",DLAYGO=442 D ^DIC L ^PRC(442.6,+PRCHY):5 G EN82:Y<0!'(+$P(Y,U,3)) E S PRCHI=PRCHX+1 Q
S PRCHX(PRCHI)=$P(Y,U,2) D NOW^%DTC S $P(^PRC(442,+Y,12),U,4,5)=DUZ_U_X S DA=+Y,(X,Y)=1 D UPD^PRCHSTAT
Q
;
Q K DIC,DIE,DR,DA,PRCHREAV,PRCHX,PRCHY L W !
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[HPRCHEA 4244 printed Sep 23, 2025@19:43:09 Page 2
PRCHEA ;WOIFO/ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;3/5/98 11:05 AM
V ;;5.1;IFCAP;**81**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN3 ;ADD A REQUISITION
+1 ;
+2 ;Variables PRCHNRQ and PRCHZZZ9 are flags stating that this is a
+3 ;REQUESITION.
+4 ;
+5 NEW PRCHP,PRCHZZZ9
+6 DO ST
EN30 SET (PRCHNRQ,PRCHZZZ9)=1
SET PRCHP("A")="REQUISITION NUMBER"
SET PRCHP("T")=8
SET PRCHP("S")=1
DO EN^PRCHPAT
IF '$DATA(PRCHPO)
KILL PRCHNRQ
QUIT
+1 DO LCK1
if '$DATA(DA)
GOTO EN30
SET X=1
SET DA=PRCHPO
DO ENS^PRCHSTAT
+2 SET Z=$PIECE(^PRC(442,PRCHPO,0),"-",2)
SET $PIECE(^PRC(442,PRCHPO,18),"^",3)=$SELECT($EXTRACT(Z):$EXTRACT(Z,2,6),1:$EXTRACT(Z)_$EXTRACT(Z,3,6))
+3 DO ^PRCHNPO
LOCK
+4 GOTO EN30
+5 ;
EN4 ;EDIT A REQUISITION
+1 ;
+2 ;Variables PRCHNREQ and PRCHZZZ9 are flags stating that this is a
+3 ;REQUESITION.
+4 ;
+5 NEW PRCHP,PRCHZZZ9
+6 DO ST
EN40 SET (PRCHNRQ,PRCHZZZ9)=1
SET PRCHP("A")="REQUISTION NUMBER: "
+1 SET PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)=5!($P(^(0),U,2)=8)!($P(^(0),U,2)=25)!($P(^(0),U,2)=26))"
+2 if $GET(PRCHPC)
SET PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P(^(0),U,2)=25"
+3 DO EN3^PRCHPAT
IF '$DATA(PRCHPO)
KILL PRCHNRQ
QUIT
+4 IF 'X
WRITE " ??",$CHAR(7)
GOTO EN40
+5 DO LCK1
if '$DATA(DA)
GOTO EN40
DO ^PRCHNPO
LOCK
+6 GOTO EN40
+7 ;
EN5 ;EDIT BOC IN ITEM FILE
+1 SET DIC="^PRC(441,"
SET DIC(0)="AEMQ"
SET DR=12
DO ^DIC
if Y<0
GOTO Q
SET DA=+Y
WRITE !
FOR I=0:0
SET I=$ORDER(^PRC(441,DA,1,I))
if 'I
QUIT
WRITE !?3,^(I,0)
+2 WRITE !
SET DIE=DIC
DO ^DIE
DO Q
WRITE !
+3 GOTO EN5
+4 ;
EN6 ;AMENDMENTS
+1 NEW PRCHP
SET PRCHFLG=0
DO ST
EN60 KILL PRCHP
if '$DATA(PRC("SITE"))
QUIT
SET PRCHP("S")="$P($G(^(7)),U,2)>19,(453328'[$P($G(^(7)),U,2)),($P(^(0),U,2)"
+1 if '$DATA(PRCHNRQ)
SET PRCHP("S")=PRCHP("S")_"<8)"
if $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NO.: "
SET PRCHP("S")=PRCHP("S")_"=8"
+2 SET PRCHFLG=1
DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
+3 ;I X=28!(X=33) W $C(7),!,"Amendments not allowed until after order has been Obligated!!" G EN60
+4 IF 'X
WRITE $CHAR(7)," ??"
GOTO EN60
+5 DO ^PRCHAM
+6 GOTO EN60
+7 ;
EN7 ;CANCEL UNOBLIGATED PO
+1 NEW PRCHP
DO ST
EN70 if '$DATA(PRC("SITE"))
QUIT
SET PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)"
+1 if '$DATA(PRCHNRQ)
SET PRCHP("S")=PRCHP("S")_"<8!($P(^(0),U,2)>24))"
+2 if $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NO.: "
SET PRCHP("S")=PRCHP("S")_"=8)"
if $DATA(PRCHIMP)
SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("S")="($P($G(^(7)),U,2)<9!($P($G(^(7)),U,2)=22))&($P(^(0),U,2)=7)"
+3 DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
IF 'X
WRITE $CHAR(7)," ??"
GOTO EN70
+4 IF $PIECE(^PRC(442,PRCHPO,0),U,12)
WRITE $CHAR(7),!!,"WARNING--2237 HAS NOT BEEN REMOVED FROM THIS ORDER!!"
GOTO EN70
+5 DO LCK1
if '$DATA(DA)
GOTO EN70
SET %A=" SURE YOU WANT TO CANCEL PURCHASE ORDER "
SET %B=""
SET %=""
DO ^PRCFYN
IF %'=1
WRITE ?40," <NOTHING CANCELLED>",$CHAR(7)
GOTO EN70
+6 SET X=$ORDER(^PRCD(442.3,"C",45,0))
SET $PIECE(^PRC(442,PRCHPO,0),U,15,16)="0^0"
KILL ^(9)
SET (X,Y)=45
SET DA=PRCHPO
DO UPD^PRCHSTAT
+7 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
+8 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO DEL^PRCV442A(PRCHPO)
+9 GOTO EN70
+10 ;
EN8 ;GRAB A PO NUMBER
+1 DO ST
EN80 if '$DATA(PRC("SITE"))
QUIT
KILL PRCHX
WRITE !!,"How many Purchase Order numbers do you want: "
READ X:DTIME
if X["^"
QUIT
IF X'=+X!(X<1)!(X>5)!'(X?1N)
WRITE " ??",$CHAR(7),!,"Enter a number between 1 and 5."
GOTO EN80
+1 SET PRCHX=X
SET DIC="^PRC(442.6,"
SET DIC(0)="QEAMZ"
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6)!($P(^(0),U,5)=7))"
SET D="C"
DO IX^DIC
IF Y<0
KILL DIC
QUIT
+2 SET DA=+Y
DO LCK
KILL DIC
if '$DATA(DA)
GOTO EN80
DO WAIT^DICD
SET PRCHY=Y
SET PRCHY(0)=Y(0)
FOR PRCHI=1:1:PRCHX
DO EN81
+3 LOCK
WRITE !,"Here is your Purchase Order Numbers: "
FOR I=0:0
SET I=$ORDER(PRCHX(I))
if 'I
QUIT
WRITE !?37,PRCHX(I)
+4 READ !!,"Press RETURN to continue",X:DTIME
KILL DIC,DA,PRCHX,PRCHY,Z
QUIT
EN81 SET X=$PIECE(PRCHY,U,2)
SET Z=$SELECT(+$PIECE(PRCHY(0),U,4)<$PIECE(PRCHY(0),U,2):+$PIECE(PRCHY(0),U,2),1:+$PIECE(PRCHY(0),U,4))
SET L=$LENGTH(X)#2-3
EN82 IF Z>$PIECE(PRCHY(0),U,3)
LOCK
WRITE !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$PIECE(PRCHY,U,2),$CHAR(7)
SET PRCHI=PRCHX+1
QUIT
+1 SET Z="000"_Z
SET Z=$EXTRACT(Z,$LENGTH(Z)+L,$LENGTH(Z))
SET X=X_Z
IF $DATA(^PRC(442,"B",X))
SET Z=Z+1
SET X=$PIECE(PRCHY,U,2)
GOTO EN82
+2 SET $PIECE(^PRC(442.6,+PRCHY,0),U,4)=+Z
SET DIC(0)="L"
SET DIC="^PRC(442,"
SET DLAYGO=442
DO ^DIC
LOCK ^PRC(442.6,+PRCHY):5
if Y<0!'(+$PIECE(Y,U,3))
GOTO EN82
IF '$TEST
SET PRCHI=PRCHX+1
QUIT
+3 SET PRCHX(PRCHI)=$PIECE(Y,U,2)
DO NOW^%DTC
SET $PIECE(^PRC(442,+Y,12),U,4,5)=DUZ_U_X
SET DA=+Y
SET (X,Y)=1
DO UPD^PRCHSTAT
+4 QUIT
+5 ;
Q KILL DIC,DIE,DR,DA,PRCHREAV,PRCHX,PRCHY
LOCK
WRITE !
+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
