Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSUT2

PRCSUT2.m

Go to the documentation of this file.
  1. PRCSUT2 ;WISC/SAW/CTB/DXH - TRANSACTION UTILITY ;5/20/13 16:22
  1. V ;;5.1;IFCAP;**13,135,148,150,174**;Oct 20, 2000;Build 23
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ; assigns a permanent transaction number to an existing transaction
  1. ; if the existing transaction is temporary, it is converted to
  1. ; permanent.
  1. ; if the existing transaction is permanent, a new ien is created and
  1. ; populated with info from the existing transaction, then canceled.
  1. ; The original transaction is updated with the new transaction number.
  1. ANTN ;
  1. N ODA,PNW,TX1,T1,T2,T3,T4,T5,PRCSY,PRCSDIC,PRCSAPP,PRCECMS,PRCOLDI
  1. ANTN1 D EN3^PRCSUT ; ask site, CP
  1. G W5:'$D(PRC("SITE"))
  1. G EXIT:Y<0
  1. W !!,"Select the existing transaction number to be replaced",!
  1. S DIC="^PRCS(410,",DIC(0)="AEFMQ"
  1. S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
  1. D ^PRCSDIC G:Y<0 EXIT
  1. S (ODA,DA,T1)=+Y,PRCSDIC=DIC
  1. L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3)
  1. I $T=0 W !,"File being accessed...please try later" G ANTN1
  1. D REVIEW
  1. S T2=^PRCS(410,DA,0) ; node 0 string of txn to be replaced
  1. S T5=$P(T2,"^",10) ; substation
  1. S T4=$P(T2,"^",2) ; txn type of transaction to be replaced
  1. S T2=$P(T2,"^") ; txn number to be replaced
  1. S T3=$P(^PRCS(410,DA,3),"^") ; control point of txn to be replaced
  1. S PRCECMS=$P($G(^PRCS(410,DA,1)),U,8),PRCOLDI=DA
  1. K DA,DIC,Y
  1. W !!,"Enter the information for the new transaction number",!
  1. D EN^PRCSUT3 ; ask SITE, FY, QRTR, CP for new txn
  1. G:'$D(PRC("QTR"))!('$D(PRC("CP"))) EXIT
  1. S TX1=X
  1. I $P($G(^PRCS(410,T1,0)),"^",4)=1,$$Q1358^PRCEN(PRC("SITE"),PRC("CP"),T4,T1) G EXIT
  1. D IP^PRCSUT ; set up prcsip
  1. S PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)
  1. I PRC("CP")'=T3,PRCSAPP["_" D PRCFY G EXIT:PRCSAPP["_"
  1. S X=TX1
  1. D EN1^PRCSUT3 ; generate new name for txn and put in X
  1. G:'X EXIT
  1. S TX1=X,(DIC,DIE)="^PRCS(410,"
  1. CK G:'+T2 CK1 ; don't set up new ien for temp txns (txns with non-numeric names)
  1. K DA
  1. S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ"
  1. D ^DIC
  1. K DLAYGO
  1. G:Y'>0 EXIT
  1. S DA=+Y
  1. L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) ; Lock new ien
  1. I $T=0 W !," Cannot create new number now...please try again later" G EXIT
  1. ; clean up txn x-refs for old & new ien's (nodes 'B','B2','B3','AE')
  1. 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)
  1. ; kill x-refs to old ien
  1. N RBQTDT,DSH,RBOLD
  1. S RBQTDT=$P($G(^PRCS(410,T1,0)),"^",11),DSH="-" D:RBQTDT>0
  1. . S RBOLD=RBQTDT_DSH_$P(T2,"-")_DSH_$P(T2,"-",4)_DSH_$P(T2,"-",2)_DSH_$P(T2,"-",5)
  1. . K ^PRCS(410,"RB",RBOLD,T1)
  1. K RBQTDT,DSH,RBOLD
  1. 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)
  1. ; set old txn name into new ien
  1. S $P(^PRCS(410,DA,0),"^")=T2
  1. ; set x-refs of old txn values to new ien
  1. 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))=""
  1. CK1 ; set new txn name into old (original) ien
  1. S $P(^PRCS(410,T1,0),"^")=TX1
  1. ; set x-refs of new txn values to old ien
  1. 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))=""
  1. ; delete old txn from temp txn x-ref & remove temp txn flag
  1. K ^PRCS(410,"K",+T3,ODA) S $P(^PRCS(410,ODA,6),"^",4)=""
  1. S PRC("OCP")=$P(^PRCS(410,ODA,3),U)
  1. ; If the old transaction had eCMS identifiers, remove them from the old
  1. ; entry which has been assigned the new transaction number.
  1. I PRCECMS>0 D
  1. . N PRCX S PRCX=$$XECMSIDS^PRCHJR03(PRCOLDI)
  1. ; if old txn name is non-numeric (temp txn), force new site & CP into record at old ien
  1. ;PRC*5.1*150 add x-ref kill for old txn non-numeric name
  1. I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE D G EN
  1. . K ^PRCS(410,"B",T2,ODA)
  1. ; else: cancel txn at old ien; force old site & CP info into new ien
  1. ;(Shortened comment and added cancel flag with patch 182
  1. S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3
  1. S DR=DR_";60///Transaction "_T2_" replaced by trans. "_TX1
  1. S DR=DR_";450///C" ;put cancel flag in Running Bal status
  1. D ^DIE
  1. S DR="104////^S X=DUZ" D ^DIE K DR
  1. I T5'="" S $P(^PRCS(410,DA,0),U,10)=T5 ; save substation in new ien
  1. S $P(^PRCS(410,DA,0),U,2)="CA" ; cancel txn at new ien
  1. D ERS410^PRC0G(DA_"^C")
  1. D W5^PRCSEB ; kill flags & x-refs indicating cancel txn is ready to approve
  1. L -^PRCS(410,DA) ; release new ien
  1. W !,"Old transaction "_T2_" is now cancelled.",!
  1. I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK
  1. EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,!
  1. S PNW=ODA,PNW(1)=TX1
  1. N A,B
  1. S A=TX1 D RBQTR ; returns B for DR string (RB Qrtr date)
  1. I $E(B,$L(B))=";" S B=$E(B,1,$L(B)-1) ; remove trailing semi-colon
  1. 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:"")
  1. S DR=DR_$S($P($G(^PRCS(410,DA,0)),"^",4)=1:";40////^S X=DUZ",1:"")
  1. D ^DIE
  1. S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
  1. S PRCSAPP=$P(PRC("ACC"),"^",11)
  1. S $P(^PRCS(410,DA,3),"^")=PRC("CP")
  1. S $P(^PRCS(410,DA,3),"^",2)=PRCSAPP
  1. S $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
  1. S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
  1. N MYY S MYY="" D EN2B^PRCSUT3 ; save substation & process with status of entered
  1. D K^PRCSUT1 ; kill 'F', 'F1', x-refs
  1. K T1(1)
  1. S (DA,PRCS,PRCSY)=PNW
  1. I $P(^PRCS(410,DA,0),"^",4)=1 D G ANTN:%=1,EXIT
  1. . S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
  1. . W !,"Use the 1358 edit option ",$S(AA<0:"",1:"if you wish "),"to edit this request.",!! D EXIT,W3
  1. ; restore values associated with new txn (use new name)
  1. S PRC("SITE")=$P(PNW(1),"-"),PRC("FY")=$P(PNW(1),"-",2),PRC("QTR")=$P(PNW(1),"-",3),PRC("CP")=$P(PNW(1),"-",4),PRCSQ=1
  1. S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
  1. I AA<0 W !,"Use the Edit a 2237 option to edit this request.",!! D EXIT,W3 G ANTN:%=1,EXIT
  1. E D W1 ; ask 'edit this request?'
  1. I %=2 D W6^PRCSEB G EN1 ; if no, may ask if ready for authorization
  1. D:%=1 EDTD1^PRCSEB0 D:'$D(PRCSQ)&(T4="O") W6^PRCSEB
  1. EN1 K PRCSQ
  1. L -^PRCS(410,ODA)
  1. D W3 I %=1 D EXIT W !! G ANTN1
  1. G EXIT
  1. ;
  1. PRCFY S A=PRCSAPP I A["_/_" D FY2 G KILL
  1. I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2)
  1. KILL K %DT,A,B,RES,X
  1. Q
  1. ;
  1. FY2 ;TWO YR APP
  1. I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(100+$E(X,4)+$E(X,2,3),2,3)
  1. W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21
  1. I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2
  1. FY21 S:'RES RES=PRC("FY")
  1. S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3)
  1. Q
  1. ;
  1. REVIEW W !!,"Would you like to review this request"
  1. S %=2 D YN^DICN G REVIEW:%=0
  1. Q:%'=1
  1. S (N,PRCSZ)=DA,PRCSF=1
  1. D PRF1^PRCSP1 ; print 2237
  1. S DA=PRCSZ
  1. K X,PRCSF,PRCSZ
  1. Q
  1. ;
  1. W1 S %=2 Q:T4'="O"
  1. ;*****PRC*5.1*174 start*****
  1. N PRCFTYPE,PRCFAIL
  1. S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I")
  1. ;if a 2237 transaction (Form Type IEN 2,3, or 4)
  1. I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D
  1. . ;if 2237 required field check fails, output warning
  1. . ;and force user to edit (S %=1)
  1. . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S (PRCFAIL,%)=1
  1. ;if 2237 required field checks fail, force edit and don't prompt user
  1. Q:$G(PRCFAIL)
  1. ;*****PRC*5.1*174 end*****
  1. W !!,"Would you like to edit this request"
  1. D YN^DICN G W1:%=0
  1. Q
  1. ;
  1. W3 W !!,"Would you like to replace another transaction number"
  1. S %=2 D YN^DICN G W3:%=0
  1. Q
  1. ;
  1. W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
  1. EXIT I $D(ODA) L -^PRCS(410,ODA)
  1. D EXIT^PRCSUT31
  1. Q
  1. ;
  1. MO ;MO QRTR
  1. I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
  1. I PRCSQT=1 W !?3,"10 OCT",!?3,"11 NOV",!?3,"12 DEC" Q
  1. I PRCSQT=2 W !?3," 1 JAN",!?3," 2 FEB",!?3," 3 MAR" Q
  1. I PRCSQT=3 W !?3," 4 APR",!?3," 5 MAY",!?3," 6 JUN" Q
  1. I PRCSQT=4 W !?3," 7 JUL",!?3," 8 AUG",!?3," 9 SEP" Q
  1. Q
  1. ;
  1. MO1 I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
  1. S PRCSMO=$S(X<4:2,X>9:1,X>3&(X<7):3,X>6&(X<10):4,1:"")
  1. I PRCSMO="" K PRCSMO
  1. Q
  1. ;
  1. RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
  1. S C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B)
  1. S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7)
  1. S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)<D:$P(C,"^",2),1:D)
  1. S B="449////"_B_";"
  1. QUIT