source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSUT3.m@ 893

Last change on this file since 893 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 2.6 KB
RevLine 
[613]1PRCSUT3 ;WISC/SAW/PLT/BGJ-TRANSACTION UTILITY PROGRAM ; 21 Apr 93 10:18 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;CREATE NEW TRANSACTION NUMBER
5 D EN1^PRCSUT K DA,DIC G W5:'$D(PRC("SITE")) Q
6EN1 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
11T 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)
16OUT K DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z Q
17OUT1 S X="",Y=-1 D OUT Q
18EN2 ;add record in file 410
19 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4
20EN2A 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
28EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),"^",10)=PRC("SST")
29 D:$D(MYY) ERS410^PRC0G(DA_"^E") Q
30EN3 ;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
35W1 S %=2 Q:T4'="O" W !!,"Would you like to edit this request" D YN^DICN G W1:%=0 Q
36W4 W !!,"Another user is accessing this file... Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5 G EXIT
37W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
38EXIT 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
Note: See TracBrowser for help on using the repository browser.