source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCON1.m@ 1688

PRCHCON1 ;WISC/KMB/DL/DXH - CONV. TEMP 2237 TO PC ORDER ;7.29.99
V ;;5.1;IFCAP;**108**;Oct 20, 2000;Build 10
 ;Per VHA Directive 2004-038, this routine should not be modified.
 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
 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
 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)>3000 W !,"The dollar amount for this transaction exceeds the $3000 purchase card cutoff." H 4 Q
 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)
 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