- 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 Feb 18, 2025@23:35:02 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