PRCHCON1 ;WISC/KMB/DL/DXH - CONV. TEMP 2237 TO PC ORDER ;7.29.99
V ;;5.1;IFCAP;**108,156,192,208**;Oct 20, 2000;Build 1
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*192 Modify $3000 limit to be $3500, per FAR 2.101 as of
; 10/1/2015 for micro purchase threshold for goods. Also,
; as of 10/1/2015 the SPL was increased to $3500 for all
; PCards for simplified orders.
;
;PRC*5.1*208 Modify $3500 limit to be $10000 for micro-purchase threshold
; for goods and services. Also, the SPL was increased to $10000
; for all PCards for simplified orders.
;
I '$D(^PRC(440.5,"C",DUZ)) W !!,"You are not authorized to use this option." Q
START ; get transaction number, convert to regular 2237
N PRC,Y,PRCSIP,PRCSQ,ODA,PNW,TRY,TX1,T1,T2,T3,T4,PRCSY,PRCSDIC,PRCSAPP
N PRCHCV,PRCHCPD,PRCHQTDT
I $G(QUIT)'="" K QUIT Q
K PRC("SITE") W @IOF D EN3F^PRCSUT(1) G W5:'$D(PRC("SITE")) S:Y<0 QUIT=1 Q:Y<0
D START1 G START
START1 ;
W !!,"Select the existing transaction number to be converted",!
; don't select an order which is signed, or attached to PC already
S DIC="^PRCS(410,",DIC(0)="AEFMQ"
S DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,12)'=""A"",$D(^(3)),+$P(^(3),U)=+PRC(""CP""),$P($G(^(4)),U,5)="""""
D ^DIC S:Y<0 QUIT=1 Q:Y<0 S (ODA,DA)=+Y,PRCSDIC=DIC
S PRCHQTDT=$P($G(^PRCS(410,ODA,0)),U,11)
I $P($G(^PRCS(410,DA,3)),U,4)="" W !,"This transaction has no entry in the Vendor File.",!,"Please edit this transaction's vendor before converting this order." H 4 Q
I $P($G(^PRCS(410,DA,4)),U)>10000 W !,"The dollar amount for this transaction exceeds the $10000 purchase card cutoff." H 4 Q ;PRC*5.1*208
D W1^PRCSEB0 Q:%<0 S DIC=PRCSDIC
L +^PRCS(410,DA):15 G:$T=0 START S T1=ODA,T2=^PRCS(410,DA,0),T4=$P(T2,"^",2),T2=$P(T2,"^"),T3=$P(^(3),"^")
N REM,REM1 S REM=DA,REM1=+$P(PRC("CP")," ")
L -^PRCS(410,DA) K DA,DIC,Y
W !!,"Enter the information for the new transaction number",!
D EN^PRCSUT3 Q:'$D(PRC("QTR")) Q:'$D(PRC("CP"))
S TX1=X,PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3) I PRC("CP")'=T3,PRCSAPP["_" D PRCFY Q:PRCSAPP["_"
S X=TX1 D EN1^PRCSUT3 Q:'X S TX1=X,(DIC,DIE)="^PRCS(410,"
CK G:'+T2 CK1 K DA S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO Q:Y'>0 S DA=+Y
K ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$P(TX1,"-",5),DA),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA),^PRCS(410,"AE",$P(TX1,"-",1,4),DA)
K ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$P(T2,"-",5),T1),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),T1),^PRCS(410,"AE",$P(T2,"-",1,4),T1)
;Patch PRC*5.1*156 insures the running balance ('RB') index is killed for temp 2237
I +PRCHQTDT>0 K ^PRCS(410,"RB",PRCHQTDT_"-"_$P(T2,"-")_"-"_$P(T2,"-",4)_"-"_$P(T2,"-",2)_"-"_$P(T2,"-",5),ODA)
K PRCHQTDT
S $P(^PRCS(410,DA,0),U)=T2 S (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$P(T2,"-",5),DA),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),DA),^PRCS(410,"AE",$P(T2,"-",1,4),DA))=""
CK1 S $P(^PRCS(410,T1,0),U)=TX1 S (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$P(TX1,"-",5),T1),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),T1),^PRCS(410,"AE",$P(TX1,"-",1,4),T1))=""
S $P(^PRCS(410,T1,6),"^",4)="" K ^PRCS(410,"K",REM1,REM)
I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE G EN
S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3_";60///Transaction "_T2_" replaced by trans. "_TX1
D ^DIE S $P(^PRCS(410,DA,0),U,2)="CA" D ERS410^PRC0G(DA_"^C"),W5^PRCSEB W !,"Old transaction "_T2_" is now cancelled.",!
I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK
EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,! S PNW=ODA,PNW(1)=TX1
S TRY=0
RETRY ;
S TRY=TRY+1 Q:TRY>3
N A,B S DA=PNW L +^PRCS(410,DA):15 G:$T=0 RETRY
S DA=PNW
S A=TX1 D RBQTR
S DA=PNW,DR=B_$S(+T2:"1///"_T4,1:"")_$S(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"")
D ^DIE S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
S PRCSAPP=$P(PRC("ACC"),"^",11),$P(^PRCS(410,DA,3),U)=PRC("CP"),$P(^(3),"^",2)=PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3)
S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
N MYY S MYY="" D EN2B^PRCSUT3
D K^PRCSUT1 K T1(1)
L -^PRCS(410,DA)
D ^PRCHCON2 QUIT
;;;;;;;;;;;;;;;;
PRCFY I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(X,2,3) S:$E(X,4,5)>9 PRC("FY")=$E(100+PRC("FY")+1,2,3)
S A=PRCSAPP I A["_/_" D FY2 G KILL
I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2)
KILL K %DT,A,B,RES,X Q
FY2 ; two year appropriation
W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21 I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2
FY21 S:'RES RES=PRC("FY") S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3) Q
W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
Q
RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I")),C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B)
S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7)
S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)<D:$P(C,"^",2),1:D)
S B="449////"_B_";"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCON1 5377 printed Apr 09, 2024@21:16:01 Page 2
PRCHCON1 ;WISC/KMB/DL/DXH - CONV. TEMP 2237 TO PC ORDER ;7.29.99
V ;;5.1;IFCAP;**108,156,192,208**;Oct 20, 2000;Build 1
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*192 Modify $3000 limit to be $3500, per FAR 2.101 as of
+4 ; 10/1/2015 for micro purchase threshold for goods. Also,
+5 ; as of 10/1/2015 the SPL was increased to $3500 for all
+6 ; PCards for simplified orders.
+7 ;
+8 ;PRC*5.1*208 Modify $3500 limit to be $10000 for micro-purchase threshold
+9 ; for goods and services. Also, the SPL was increased to $10000
+10 ; for all PCards for simplified orders.
+11 ;
+12 IF '$DATA(^PRC(440.5,"C",DUZ))
WRITE !!,"You are not authorized to use this option."
QUIT
START ; get transaction number, convert to regular 2237
+1 NEW PRC,Y,PRCSIP,PRCSQ,ODA,PNW,TRY,TX1,T1,T2,T3,T4,PRCSY,PRCSDIC,PRCSAPP
+2 NEW PRCHCV,PRCHCPD,PRCHQTDT
+3 IF $GET(QUIT)'=""
KILL QUIT
QUIT
+4 KILL PRC("SITE")
WRITE @IOF
DO EN3F^PRCSUT(1)
if '$DATA(PRC("SITE"))
GOTO W5
if Y<0
SET QUIT=1
if Y<0
QUIT
+5 DO START1
GOTO START
START1 ;
+1 WRITE !!,"Select the existing transaction number to be converted",!
+2 ; don't select an order which is signed, or attached to PC already
+3 SET DIC="^PRCS(410,"
SET DIC(0)="AEFMQ"
+4 SET DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,12)'=""A"",$D(^(3)),+$P(^(3),U)=+PRC(""CP""),$P($G(^(4)),U,5)="""""
+5 DO ^DIC
if Y<0
SET QUIT=1
if Y<0
QUIT
SET (ODA,DA)=+Y
SET PRCSDIC=DIC
+6 SET PRCHQTDT=$PIECE($GET(^PRCS(410,ODA,0)),U,11)
+7 IF $PIECE($GET(^PRCS(410,DA,3)),U,4)=""
WRITE !,"This transaction has no entry in the Vendor File.",!,"Please edit this transaction's vendor before converting this order."
HANG 4
QUIT
+8 ;PRC*5.1*208
IF $PIECE($GET(^PRCS(410,DA,4)),U)>10000
WRITE !,"The dollar amount for this transaction exceeds the $10000 purchase card cutoff."
HANG 4
QUIT
+9 DO W1^PRCSEB0
if %<0
QUIT
SET DIC=PRCSDIC
+10 LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO START
SET T1=ODA
SET T2=^PRCS(410,DA,0)
SET T4=$PIECE(T2,"^",2)
SET T2=$PIECE(T2,"^")
SET T3=$PIECE(^(3),"^")
+11 NEW REM,REM1
SET REM=DA
SET REM1=+$PIECE(PRC("CP")," ")
+12 LOCK -^PRCS(410,DA)
KILL DA,DIC,Y
+13 WRITE !!,"Enter the information for the new transaction number",!
+14 DO EN^PRCSUT3
if '$DATA(PRC("QTR"))
QUIT
if '$DATA(PRC("CP"))
QUIT
+15 SET TX1=X
SET PRCSAPP=$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)
IF PRC("CP")'=T3
IF PRCSAPP["_"
DO PRCFY
if PRCSAPP["_"
QUIT
+16 SET X=TX1
DO EN1^PRCSUT3
if 'X
QUIT
SET TX1=X
SET (DIC,DIE)="^PRCS(410,"
CK if '+T2
GOTO CK1
KILL DA
SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="LXZ"
DO ^DIC
KILL DLAYGO
if Y'>0
QUIT
SET DA=+Y
+1 KILL ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$PIECE(TX1,"-",5),DA),^PRCS(410,"B3",$PIECE(TX1,"-",2)_"-"_$PIECE(TX1,"-",5),DA),^PRCS(410,"AE",$PIECE(TX1,"-",1,4),DA)
+2 KILL ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$PIECE(T2,"-",5),T1),^PRCS(410,"B3",$PIECE(T2,"-",2)_"-"_$PIECE(T2,"-",5),T1),^PRCS(410,"AE",$PIECE(T2,"-",1,4),T1)
+3 ;Patch PRC*5.1*156 insures the running balance ('RB') index is killed for temp 2237
+4 IF +PRCHQTDT>0
KILL ^PRCS(410,"RB",PRCHQTDT_"-"_$PIECE(T2,"-")_"-"_$PIECE(T2,"-",4)_"-"_$PIECE(T2,"-",2)_"-"_$PIECE(T2,"-",5),ODA)
+5 KILL PRCHQTDT
+6 SET $PIECE(^PRCS(410,DA,0),U)=T2
SET (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$PIECE(T2,"-",5),DA),^PRCS(410,"B3",$PIECE(T2,"-",2)_"-"_$PIECE(T2,"-",5),DA),^PRCS(410,"AE",$PIECE(T2,"-",1,4),DA))=""
CK1 SET $PIECE(^PRCS(410,T1,0),U)=TX1
SET (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$PIECE(TX1,"-",5),T1),^PRCS(410,"B3",$PIECE(TX1,"-",2)_"-"_$PIECE(TX1,"-",5),T1),^PRCS(410,"AE",$PIECE(TX1,"-",1,4),T1))=""
+1 SET $PIECE(^PRCS(410,T1,6),"^",4)=""
KILL ^PRCS(410,"K",REM1,REM)
+2 IF '+T2
SET DA=ODA
SET DIE="^PRCS(410,"
SET DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP")
DO ^DIE
GOTO EN
+3 SET DIE="^PRCS(410,"
SET DR=".5///"_+T2_";S X=X;15///"_T3_";60///Transaction "_T2_" replaced by trans. "_TX1
+4 DO ^DIE
SET $PIECE(^PRCS(410,DA,0),U,2)="CA"
DO ERS410^PRC0G(DA_"^C")
DO W5^PRCSEB
WRITE !,"Old transaction "_T2_" is now cancelled.",!
+5 IF $DATA(^PRC(443,ODA,0))
SET DA=ODA
SET DIK="^PRC(443,"
DO ^DIK
KILL DA,DIK
EN WRITE !!,"Transaction '"_T2_"' has been replaced by "_TX1,!
SET PNW=ODA
SET PNW(1)=TX1
+1 SET TRY=0
RETRY ;
+1 SET TRY=TRY+1
if TRY>3
QUIT
+2 NEW A,B
SET DA=PNW
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO RETRY
+3 SET DA=PNW
+4 SET A=TX1
DO RBQTR
+5 SET DA=PNW
SET DR=B_$SELECT(+T2:"1///"_T4,1:"")_$SELECT(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$SELECT(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")
+6 DO ^DIE
SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+7 SET PRCSAPP=$PIECE(PRC("ACC"),"^",11)
SET $PIECE(^PRCS(410,DA,3),U)=PRC("CP")
SET $PIECE(^(3),"^",2)=PRCSAPP
SET $PIECE(^(3),"^",12)=$PIECE(PRC("ACC"),"^",3)
+8 SET $PIECE(^PRCS(410,DA,3),"^",11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
+9 NEW MYY
SET MYY=""
DO EN2B^PRCSUT3
+10 DO K^PRCSUT1
KILL T1(1)
+11 LOCK -^PRCS(410,DA)
+12 DO ^PRCHCON2
QUIT
+13 ;;;;;;;;;;;;;;;;
PRCFY IF '$DATA(PRC("FY"))
DO NOW^%DTC
SET PRC("FY")=$EXTRACT(X,2,3)
if $EXTRACT(X,4,5)>9
SET PRC("FY")=$EXTRACT(100+PRC("FY")+1,2,3)
+1 SET A=PRCSAPP
IF A["_/_"
DO FY2
GOTO KILL
+2 IF A["_"
SET PRCSAPP=$PIECE(A,"_",1)_$EXTRACT(PRC("FY"),$LENGTH(PRC("FY")))_$PIECE(A,"_",2)
KILL KILL %DT,A,B,RES,X
QUIT
FY2 ; two year appropriation
+1 WRITE !!,"Enter first year of this two year appropriation: ",PRC("FY")," // "
READ RES:DTIME
if RES["^"
GOTO FY21
IF RES["?"!(RES'?.4N)
WRITE !,"Enter fiscal year in format '1' '81' or '1981'",!!
GOTO FY2
FY21 if 'RES
SET RES=PRC("FY")
SET RES=$EXTRACT(RES,$LENGTH(RES))
SET PRCSAPP=$PIECE(A,"_",1)_RES_"/"_(RES+1#10)_$PIECE(A,"_",3)
QUIT
W5 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
+1 QUIT
RBQTR NEW C,D
SET B=""
SET B=$SELECT(B="":$PIECE(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
SET C=$$QTRDT^PRC0G($PIECE(A,"-",1)_"^"_$PIECE(A,"-",4)_"^"_B)
+1 SET D=$$QTRDATE^PRC0D($PIECE(A,"-",2),$PIECE(A,"-",3))
SET D=$PIECE(D,"^",7)
+2 SET B=$SELECT(D<$PIECE(C,"^",3):$PIECE(C,"^",3),$PIECE(C,"^",2)<D:$PIECE(C,"^",2),1:D)
+3 SET B="449////"_B_";"
+4 QUIT
