PRCSUT3 ;WISC/SAW/PLT/BGJ-TRANSACTION UTILITY PROGRAM ; 21 Apr 93  10:18 AM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;CREATE NEW TRANSACTION NUMBER
 D EN1^PRCSUT K DA,DIC G W5:'$D(PRC("SITE")) Q
EN1 G:'$D(X) OUT1 S NODE=0,PIECE=2 I $D(PRCS("TYPE")) G:'X OUT1 S T(1)=$O(^DD(410.1,"B",PRCS("TYPE"),0)) G:'T(1)!('$D(^DD(410.1,+T(1),0))) OUT1
 S DIC="^PRCS(410.1,"
 ;I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N L +^PRCS410.1,N):15 G:$T=0 OUT1 S T=$P(^PRCS(410.1,N,NODE),"^",PIECE)+1 S:T<1 T=1 L -^PRCS(410.1,N))
 I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N S T=$P(^PRCS(410.1,N,NODE),"^",PIECE)+1 S:T<1 T=1
 I '$D(^PRCS(410.1,"B",X)) S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ" D ^DIC K DLAYGO G:Y<0 W4 S DA=+Y
T S T="000"_T,T=$E(T,$L(T)-3,$L(T))
 I $D(REP) S X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1,X=$P(X,"-",1,4) G T
 I '$D(REP),'$D(PRCS("TYPE")) S X=Z,X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1 G T
 I '$D(REP),$D(PRCS("TYPE")) S Z=X,X=X_"-"_T I $D(^PRC(424,"B",X)) S T=+T+1,X=Z G T
 L +^PRCS(410.1,DA):15 S $P(^PRCS(410.1,DA,NODE),U,PIECE)=+T,$P(^(0),U,3)=DT L -^PRCS(410.1,DA)
OUT K DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z Q
OUT1 S X="",Y=-1 D OUT Q
EN2 ;add record in file 410
 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4
EN2A S DA=+Y S:'$D(T(2)) T(2)=""
 S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
 S PRCSAPP=$P(PRC("ACC"),"^",11)
 S ^PRCS(410,DA,0)=$P(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE"),^PRCS(410,DA,3)=PRC("CP")_"^"_PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3)
 S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
 S ^PRCS(410,"AN",$E(PRC("CP"),1,30),DA)=""
 D ERS410^PRC0G(DA_"^E")
 S:T(2)'="" ^PRCS(410,"H",$E(T(2),1,30),DA)=DUZ,$P(^PRCS(410,DA,11),"^",2)=DUZ,^PRCS(410,"K",+$P(PRC("CP")," "),DA)="",$P(^PRCS(410,DA,6),"^",4)=+$P(PRC("CP")," ") K PRCSAPP
EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),"^",10)=PRC("SST")
 D:$D(MYY) ERS410^PRC0G(DA_"^E") Q
EN3 ;INPUT TRANSFORM FOR REORDERING 410 FILE ENTRIES
 Q:'$D(X)  I $D(^PRCS(410,"B",X)) Q
 S DINUM=$O(^PRCS(410,500000))-1 S:DINUM<500000 DINUM=99999999
 F DINUM=DINUM:-1:500000 I '$D(^PRCS(410,DINUM)) L +^PRCS(410,DINUM):0 Q:$T
 L -^PRCS(410,DINUM) Q
W1 S %=2 Q:T4'="O"  W !!,"Would you like to edit this request" D YN^DICN G W1:%=0 Q
W4 W !!,"Another user is accessing this file...  Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5 G EXIT
W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
EXIT K %,DA,DIC,DIE,DR,I,L,N,PRCS,PRCSAPP,PRCSDIC,PRC("FY"),PRCSL,PRCSY,PRC("QTR"),T,T1,T2,T3,T4,X,X1,Z Q