- 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 Feb 18, 2025@23:33:28 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