PRCHMA2 ;WISC/AKS-Amendments to purchase orders and requisitions ;6/9/96 20:44
;;5.1;IFCAP;**191**;Oct 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*191 Modify Prompt Pay % handling during Amendment to
; insure ONLY one PP entry is allowed and only able
; to allow/edit one entry in what is defined as a
; multiple field.
;
EN10 ;EST. SHIPPING Edit
N X,I,PRCHO,PRCHN,PRCHOO,PRCH0,PRCHSBOC,PRCH12,PRCHGNP,PRCHGPO,PRCHGSHP
N PRCHSHP
S (I,ER)=0,X=""
;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
D CAN^PRCHMA3
I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE ESTIMATED SHIPPING!",$C(7) Q
S PRCH0=$G(^PRC(443.6,PRCHPO,0))
S PRCHO=$P(PRCH0,U,13),PRCHOO=$P(^PRC(443.6,PRCHPO,23),U)
S PRCH12=$G(^PRC(443.6,PRCHPO,12)) I PRCH12]"" D
.S PRCHGNO=$P(PRCH12,U,7),PRCHGPO=$P(PRCH12,U,8),PRCHGSHP=$P(PRCH12,U,9)
S DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
S DIE="^PRC(443.6,",DA=PRCHPO
I $P(^PRC(442,PRCHPO,0),U,19)=2 D
.S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U)
.S DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
D ^DIE
S PRCHN("FOB")=$P($G(^PRC(443.6,PRCHPO,1)),U,6),PRCHSHP=$P(^(0),U,13)
I $P($G(^PRC(443.6,PRCHPO,0)),U,13)]"" D
.I (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S DR="13.2;13.4;13.3" D ^DIE K DIE
I PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0)) D GBL
S PRCHX=X
I PRCHO'=$P($G(^PRC(443.6,PRCHPO,0)),U,13) S X=$S(PRCHO]"":PRCHO,1:0) D EN4^PRCHAMXC
I PRCHOO'=$P($G(^PRC(443.6,PRCHPO,23)),U) S X=$S(PRCHOO]"":PRCHOO,1:0) D EN11^PRCHAMXC
I PRCHGNO'=$P($G(^PRC(443.6,PRCHPO,12)),U,7) S X=$S(PRCHGNO]"":PRCHGNO,1:0) D EN12^PRCHAMXC
I PRCHGPO'=$P($G(^PRC(443.6,PRCHPO,12)),U,8) S X=$S(PRCHGPO]"":PRCHGPO,1:0) D EN14^PRCHAMXC
I PRCHGSHP'=$P($G(^PRC(443.6,PRCHPO,12)),U,9) S X=$S(PRCHGSHP]"":PRCHGSHP,1:0) D EN13^PRCHAMXC
S X=PRCHX,PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) K PRCHX,PRCHOO
I PRCHO=""&(PRCHN]"") D
.S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)+1
.S $P(^PRC(443.6,PRCHPO,0),U,18)=$P(PRCH0,U,14)+1
I PRCHO]""&(PRCHN="") D
.S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1,$P(^(0),U,18)=""
.S $P(^PRC(443.6,PRCHPO,23),U)=""
S DELIVER=1 W !
QUIT
EN11 ;F.C.P. Edit
N X,I
S (I,ER)=0,X=""
;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
D CAN^PRCHMA3
I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE FUND CONTROL POINT!",$C(7) Q
I $P(^PRC(442,PRCHPO,0),U,12)>0 W !!,?5,"This purchase order has a 2237 attached to it.",!,?5,"To change F.C.P. you must do the following: " D QUIT
.W !!,?7,"1. Cancel the purchase order." Q:$G(PRCHAUTH)
.W !,?7,"2. Copy the 2237 to another 2237 with new FCP."
.W !,?7,"3. Have it signed by CP Official and Accountable Officer."
.W !,?7,"4. Attach the 2237 to a new purchase order."
S DR="1;2;5.2",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
QUIT
EN12 ;Change Vendor
N X,I,DLAYGO,N,NN
S (I,ER)=0,X=""
;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
D CAN^PRCHMA3
I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE VENDOR!",$C(7) Q
S DIC="^PRC(440,",DIC(0)="AEQ"
S:$D(PRCHREQ) DIC("S")="I $P($G(^(2)),U,2)'="""""
S:'$D(PRCHREQ) DIC("S")="I $P($G(^(2)),U,2)="""""
S:$P($G(^PRC(443.6,PRCHPO,1)),U) DIC("B")=$P(^PRC(440,$P(^(1),U),0),U)
D ^DIC K DIC Q:Y<0 S PRCHN=+Y
S DR="5///"_+Y,DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
S N=""
F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S NN=$P(^(N,0),U,5) I '$D(^PRC(441,NN,2,PRCHN)) D
.W !,"For item, ",$P(^PRC(441,NN,0),U,2)
.W !?5,"Enter the following information: "
.S DA(1)=NN,DIC="^PRC(441,"_DA(1)_",2,",DIC(0)="LZ",DIC("DR")="1;1.5;2;3;4"
.S DIE("NO^")="",DLAYGO=441,(DA,DA(1))=NN,X=PRCHN D ^DIC K DIC,DIE("NO^")
.S DIE="^PRC(441,"_DA(1)_",2,",DA=1,DR=6 D ^DIE
S N=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N I $P($G(^PRC(443.6,PRCHPO,2,N,2)),U,2)]'"" D
. W !,"For line item: ",+^PRC(443.6,PRCHPO,2,N,0)
. W !?5,"Enter the following information: "
. S DA(1)=PRCHPO,DA=N,DIE="^PRC(443.6,"_DA(1)_",2,",DR=4 D ^DIE K DA,DIE,DR
S DELIVER=1 W !
QUIT
;
EN14 ;Prompt payment edit
N DIC,DIE,DA,DR,Y,PRCHX,PRCHXX,PRCHVAL,PRCHDA,%X,%Y,PRCHPP
I '$D(^PRC(443.6,PRCHPO,5)) D
.S %X="^PRC(442,PRCHPO,5,",%Y="^PRC(443.6,PRCHPO,5," D %XY^%RCR
;PRC*5.1*191 Code below insures only a single Prompt Pay entry
; allowed and only that single entry can be edited,
; if one defined in multiple field.
;Begin PRC*191
S PRCHPP=$O(^PRC(443.6,PRCHPO,5,0)) D:PRCHPP
. S (PRCHDA,DA)=PRCHPP
. S PRCHVAL=$G(^PRC(443.6,PRCHPO,5,DA,0)),Y(0)=PRCHVAL
. S PRCHP0=Y(0),PRCHO=$P(Y(0),U)_"/"_$P(Y(0),U,2),PRCHXX=$P(Y(0),U,3)
. S DR=".01//^S X=""NET"";1//^S X=30"
. S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",5," D ^DIE
I 'PRCHPP S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",5,",DIC(0)="AELQZ" D ^DIC Q:Y<0 S (PRCHDA,DA)=+Y,PRCHXX=$P(Y,U,3) D
. S PRCHVAL=$G(^PRC(443.6,PRCHPO,5,DA,0))
. S PRCHP0=Y(0),PRCHO=$P(Y(0),U)_"/"_$P(Y(0),U,2)
. S $P(^PRC(443.6,PRCHPO,5,0),U,2)=$P(^DD(443.6,9.2,0),U,2)
. S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",5,"
. S DR=".01//^S X=""NET"";1//^S X=30"
. D ^DIE
;End PRC*191
S DA(1)=PRCHPO,DA=PRCHDA,PRCHX=X
S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U)) D EN0^PRCHAMXB
S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U,2)) D EN1^PRCHAMXB
;S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U,5)) D EN11^PRCHAMXB
S X=PRCHX
W !
QUIT
GBL ;Delete GBL information
N DIE,DA,DR
S DIE="^PRC(443.6,",DA=PRCHPO,DR="13.2///@;13.4///@;13.3///@"
D ^DIE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMA2 5776 printed Apr 09, 2024@21:18:14 Page 2
PRCHMA2 ;WISC/AKS-Amendments to purchase orders and requisitions ;6/9/96 20:44
+1 ;;5.1;IFCAP;**191**;Oct 20, 2000;Build 4
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;PRC*5.1*191 Modify Prompt Pay % handling during Amendment to
+5 ; insure ONLY one PP entry is allowed and only able
+6 ; to allow/edit one entry in what is defined as a
+7 ; multiple field.
+8 ;
EN10 ;EST. SHIPPING Edit
+1 NEW X,I,PRCHO,PRCHN,PRCHOO,PRCH0,PRCHSBOC,PRCH12,PRCHGNP,PRCHGPO,PRCHGSHP
+2 NEW PRCHSHP
+3 SET (I,ER)=0
SET X=""
+4 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
+5 DO CAN^PRCHMA3
+6 IF $GET(NOCAN)=1
WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE ESTIMATED SHIPPING!",$CHAR(7)
QUIT
+7 SET PRCH0=$GET(^PRC(443.6,PRCHPO,0))
+8 SET PRCHO=$PIECE(PRCH0,U,13)
SET PRCHOO=$PIECE(^PRC(443.6,PRCHPO,23),U)
+9 SET PRCH12=$GET(^PRC(443.6,PRCHPO,12))
IF PRCH12]""
Begin DoDot:1
+10 SET PRCHGNO=$PIECE(PRCH12,U,7)
SET PRCHGPO=$PIECE(PRCH12,U,8)
SET PRCHGSHP=$PIECE(PRCH12,U,9)
End DoDot:1
+11 SET DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
+12 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
+13 IF $PIECE(^PRC(442,PRCHPO,0),U,19)=2
Begin DoDot:1
+14 SET PRCHSBOC=$PIECE($GET(^PRCD(420.2,2299,0)),U)
+15 SET DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
End DoDot:1
+16 DO ^DIE
+17 SET PRCHN("FOB")=$PIECE($GET(^PRC(443.6,PRCHPO,1)),U,6)
SET PRCHSHP=$PIECE(^(0),U,13)
+18 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)]""
Begin DoDot:1
+19 IF (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0)))
SET DR="13.2;13.4;13.3"
DO ^DIE
KILL DIE
End DoDot:1
+20 IF PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0))
DO GBL
+21 SET PRCHX=X
+22 IF PRCHO'=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)
SET X=$SELECT(PRCHO]"":PRCHO,1:0)
DO EN4^PRCHAMXC
+23 IF PRCHOO'=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
SET X=$SELECT(PRCHOO]"":PRCHOO,1:0)
DO EN11^PRCHAMXC
+24 IF PRCHGNO'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,7)
SET X=$SELECT(PRCHGNO]"":PRCHGNO,1:0)
DO EN12^PRCHAMXC
+25 IF PRCHGPO'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,8)
SET X=$SELECT(PRCHGPO]"":PRCHGPO,1:0)
DO EN14^PRCHAMXC
+26 IF PRCHGSHP'=$PIECE($GET(^PRC(443.6,PRCHPO,12)),U,9)
SET X=$SELECT(PRCHGSHP]"":PRCHGSHP,1:0)
DO EN13^PRCHAMXC
+27 SET X=PRCHX
SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,0),U,13)
KILL PRCHX,PRCHOO
+28 IF PRCHO=""&(PRCHN]"")
Begin DoDot:1
+29 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=$PIECE(PRCH0,U,14)+1
+30 SET $PIECE(^PRC(443.6,PRCHPO,0),U,18)=$PIECE(PRCH0,U,14)+1
End DoDot:1
+31 IF PRCHO]""&(PRCHN="")
Begin DoDot:1
+32 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=$PIECE(PRCH0,U,14)-1
SET $PIECE(^(0),U,18)=""
+33 SET $PIECE(^PRC(443.6,PRCHPO,23),U)=""
End DoDot:1
+34 SET DELIVER=1
WRITE !
+35 QUIT
EN11 ;F.C.P. Edit
+1 NEW X,I
+2 SET (I,ER)=0
SET X=""
+3 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
+4 DO CAN^PRCHMA3
+5 IF $GET(NOCAN)=1
WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE FUND CONTROL POINT!",$CHAR(7)
QUIT
+6 IF $PIECE(^PRC(442,PRCHPO,0),U,12)>0
WRITE !!,?5,"This purchase order has a 2237 attached to it.",!,?5,"To change F.C.P. you must do the following: "
Begin DoDot:1
+7 WRITE !!,?7,"1. Cancel the purchase order."
if $GET(PRCHAUTH)
QUIT
+8 WRITE !,?7,"2. Copy the 2237 to another 2237 with new FCP."
+9 WRITE !,?7,"3. Have it signed by CP Official and Accountable Officer."
+10 WRITE !,?7,"4. Attach the 2237 to a new purchase order."
End DoDot:1
QUIT
+11 SET DR="1;2;5.2"
SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
KILL DIE
+12 QUIT
EN12 ;Change Vendor
+1 NEW X,I,DLAYGO,N,NN
+2 SET (I,ER)=0
SET X=""
+3 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
+4 DO CAN^PRCHMA3
+5 IF $GET(NOCAN)=1
WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE VENDOR!",$CHAR(7)
QUIT
+6 SET DIC="^PRC(440,"
SET DIC(0)="AEQ"
+7 if $DATA(PRCHREQ)
SET DIC("S")="I $P($G(^(2)),U,2)'="""""
+8 if '$DATA(PRCHREQ)
SET DIC("S")="I $P($G(^(2)),U,2)="""""
+9 if $PIECE($GET(^PRC(443.6,PRCHPO,1)),U)
SET DIC("B")=$PIECE(^PRC(440,$PIECE(^(1),U),0),U)
+10 DO ^DIC
KILL DIC
if Y<0
QUIT
SET PRCHN=+Y
+11 SET DR="5///"_+Y
SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
KILL DIE
+12 SET N=""
+13 FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
if 'N
QUIT
SET NN=$PIECE(^(N,0),U,5)
IF '$DATA(^PRC(441,NN,2,PRCHN))
Begin DoDot:1
+14 WRITE !,"For item, ",$PIECE(^PRC(441,NN,0),U,2)
+15 WRITE !?5,"Enter the following information: "
+16 SET DA(1)=NN
SET DIC="^PRC(441,"_DA(1)_",2,"
SET DIC(0)="LZ"
SET DIC("DR")="1;1.5;2;3;4"
+17 SET DIE("NO^")=""
SET DLAYGO=441
SET (DA,DA(1))=NN
SET X=PRCHN
DO ^DIC
KILL DIC,DIE("NO^")
+18 SET DIE="^PRC(441,"_DA(1)_",2,"
SET DA=1
SET DR=6
DO ^DIE
End DoDot:1
+19 SET N=0
FOR
SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
if 'N
QUIT
IF $PIECE($GET(^PRC(443.6,PRCHPO,2,N,2)),U,2)]'""
Begin DoDot:1
+20 WRITE !,"For line item: ",+^PRC(443.6,PRCHPO,2,N,0)
+21 WRITE !?5,"Enter the following information: "
+22 SET DA(1)=PRCHPO
SET DA=N
SET DIE="^PRC(443.6,"_DA(1)_",2,"
SET DR=4
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+23 SET DELIVER=1
WRITE !
+24 QUIT
+25 ;
EN14 ;Prompt payment edit
+1 NEW DIC,DIE,DA,DR,Y,PRCHX,PRCHXX,PRCHVAL,PRCHDA,%X,%Y,PRCHPP
+2 IF '$DATA(^PRC(443.6,PRCHPO,5))
Begin DoDot:1
+3 SET %X="^PRC(442,PRCHPO,5,"
SET %Y="^PRC(443.6,PRCHPO,5,"
DO %XY^%RCR
End DoDot:1
+4 ;PRC*5.1*191 Code below insures only a single Prompt Pay entry
+5 ; allowed and only that single entry can be edited,
+6 ; if one defined in multiple field.
+7 ;Begin PRC*191
+8 SET PRCHPP=$ORDER(^PRC(443.6,PRCHPO,5,0))
if PRCHPP
Begin DoDot:1
+9 SET (PRCHDA,DA)=PRCHPP
+10 SET PRCHVAL=$GET(^PRC(443.6,PRCHPO,5,DA,0))
SET Y(0)=PRCHVAL
+11 SET PRCHP0=Y(0)
SET PRCHO=$PIECE(Y(0),U)_"/"_$PIECE(Y(0),U,2)
SET PRCHXX=$PIECE(Y(0),U,3)
+12 SET DR=".01//^S X=""NET"";1//^S X=30"
+13 SET DA(1)=PRCHPO
SET DIE="^PRC(443.6,"_DA(1)_",5,"
DO ^DIE
End DoDot:1
+14 IF 'PRCHPP
SET DA(1)=PRCHPO
SET DIC="^PRC(443.6,"_DA(1)_",5,"
SET DIC(0)="AELQZ"
DO ^DIC
if Y<0
QUIT
SET (PRCHDA,DA)=+Y
SET PRCHXX=$PIECE(Y,U,3)
Begin DoDot:1
+15 SET PRCHVAL=$GET(^PRC(443.6,PRCHPO,5,DA,0))
+16 SET PRCHP0=Y(0)
SET PRCHO=$PIECE(Y(0),U)_"/"_$PIECE(Y(0),U,2)
+17 SET $PIECE(^PRC(443.6,PRCHPO,5,0),U,2)=$PIECE(^DD(443.6,9.2,0),U,2)
+18 SET DA(1)=PRCHPO
SET DIE="^PRC(443.6,"_DA(1)_",5,"
+19 SET DR=".01//^S X=""NET"";1//^S X=30"
+20 DO ^DIE
End DoDot:1
+21 ;End PRC*191
+22 SET DA(1)=PRCHPO
SET DA=PRCHDA
SET PRCHX=X
+23 SET X=$SELECT(PRCHXX=1:0,1:$PIECE(PRCHVAL,U))
DO EN0^PRCHAMXB
+24 SET X=$SELECT(PRCHXX=1:0,1:$PIECE(PRCHVAL,U,2))
DO EN1^PRCHAMXB
+25 ;S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U,5)) D EN11^PRCHAMXB
+26 SET X=PRCHX
+27 WRITE !
+28 QUIT
GBL ;Delete GBL information
+1 NEW DIE,DA,DR
+2 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
SET DR="13.2///@;13.4///@;13.3///@"
+3 DO ^DIE
