| 1 | PRCSUT3 ;WISC/SAW/PLT/BGJ-TRANSACTION UTILITY PROGRAM ; 21 Apr 93 10:18 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | EN ;CREATE NEW TRANSACTION NUMBER
|
|---|
| 5 | D EN1^PRCSUT K DA,DIC G W5:'$D(PRC("SITE")) Q
|
|---|
| 6 | 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
|
|---|
| 7 | S DIC="^PRCS(410.1,"
|
|---|
| 8 | ;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))
|
|---|
| 9 | 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
|
|---|
| 10 | 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
|
|---|
| 11 | T S T="000"_T,T=$E(T,$L(T)-3,$L(T))
|
|---|
| 12 | I $D(REP) S X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1,X=$P(X,"-",1,4) G T
|
|---|
| 13 | I '$D(REP),'$D(PRCS("TYPE")) S X=Z,X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1 G T
|
|---|
| 14 | 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
|
|---|
| 15 | 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)
|
|---|
| 16 | OUT K DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z Q
|
|---|
| 17 | OUT1 S X="",Y=-1 D OUT Q
|
|---|
| 18 | EN2 ;add record in file 410
|
|---|
| 19 | S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4
|
|---|
| 20 | EN2A S DA=+Y S:'$D(T(2)) T(2)=""
|
|---|
| 21 | S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
|
|---|
| 22 | S PRCSAPP=$P(PRC("ACC"),"^",11)
|
|---|
| 23 | 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)
|
|---|
| 24 | S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
|
|---|
| 25 | S ^PRCS(410,"AN",$E(PRC("CP"),1,30),DA)=""
|
|---|
| 26 | D ERS410^PRC0G(DA_"^E")
|
|---|
| 27 | 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
|
|---|
| 28 | EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),"^",10)=PRC("SST")
|
|---|
| 29 | D:$D(MYY) ERS410^PRC0G(DA_"^E") Q
|
|---|
| 30 | EN3 ;INPUT TRANSFORM FOR REORDERING 410 FILE ENTRIES
|
|---|
| 31 | Q:'$D(X) I $D(^PRCS(410,"B",X)) Q
|
|---|
| 32 | S DINUM=$O(^PRCS(410,500000))-1 S:DINUM<500000 DINUM=99999999
|
|---|
| 33 | F DINUM=DINUM:-1:500000 I '$D(^PRCS(410,DINUM)) L +^PRCS(410,DINUM):0 Q:$T
|
|---|
| 34 | L -^PRCS(410,DINUM) Q
|
|---|
| 35 | W1 S %=2 Q:T4'="O" W !!,"Would you like to edit this request" D YN^DICN G W1:%=0 Q
|
|---|
| 36 | W4 W !!,"Another user is accessing this file... Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5 G EXIT
|
|---|
| 37 | W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
|
|---|
| 38 | 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
|
|---|
