source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSEA1.m@ 623

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCSEA1 ;WISC/KMB/DXH - REQUESTOR ENTER 1358 ;7.26.99
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;
5 N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
6 S PRCSK=1,X3="H"
7 D EN1F^PRCSUT(1) Q:Y<0
8 D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
9 D EN^DDIOL(" ") ; blank line
10EN1 ;
11 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H"
12 S DIC("A")="Select TRANSACTION: "
13 S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored
14 D ^PRCSDIC
15 K DLAYGO,DIC("A"),DIC("S")
16 Q:Y<0
17 I $P(Y,U,3)'=1 D EN^DDIOL("Must be a new entry. ") G EN1
18 L +^PRCS(410,+Y):1 ;CHANGED DA TO +Y IN P182
19 I $T=0 D EN^DDIOL("File being accessed, please try another entry") G EN1
20 S T(2)=$P(Y,U,2)
21 D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data, etc. in new ien (nodes 0,3,6,11 of file 410)
22 S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
23 S $P(^PRCS(410,DA,7),"^",1)=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3)
24 ; commented out by PRC*5*140 - automated flag not implemeted in option, if commented lines are removed, remember to stop newing the PRCS variable
25 ; S PRCS="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
26 S X=T(2)
27 D EN^DDIOL("This transaction is assigned temporary transaction number: "_X,"","!!")
28 K PRCSERR
29 S DIC(0)="AEMQ",DIE=DIC,DIE("NO^")=1
30 S DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1
31 D ^DIE
32 S PRCAED=1 ; cannot find where or how PRCAED is used
33 S DR="[PRCE NEW 1358S]"
34 D ^DIE
35 D W1^PRCSEB ; ask 'review?'
36 L -^PRCS(410,DA)
37 S DIR("B")="NO",DIR(0)="Y"
38 S DIR("A")="Do you want to enter another new request"
39 D ^DIR Q:'Y!($D(DIRUT))
40 W !!
41 ; removed by PRC*5*140 - PRCS2 never set up
42 ; K PRCS2
43 G EN1
44ED ;edit 1358 for requestor
45 N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
46ED1 ;
47 S PRCAED=1,X3=1 ; PRC*5*140 comment - PRCAED used?, X3="H" for all other temp txn options. X3 determines xrefs to search in finding txn name.
48 D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
49 D EN^DDIOL(" ")
50 S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
51 S DIC("A")="Select TRANSACTION: "
52 S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & must be a 1358
53 D ^PRCSDIC ; lookup & prelimiary validity checking
54 K DIC("A"),DIC("S")
55 Q:Y<0
56 S DA=+Y
57 L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...try later") Q
58 S DIC=(0)="AEMQ",DIE="^PRCS(410,"
59 S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5)
60 S PRC("CP")=$P(^PRCS(410,DA,3),"^")
61 S (PRCSDR,DR)="[PRCE NEW 1358S]"
62 K DTOUT,DUOUT,Y
63 S PDA=DA
64 D ^DIE
65 S DA=PDA
66 I $D(Y)!($D(DTOUT)) S PRCAED=-1
67 D W1^PRCSEB
68 L -^PRCS(410,DA)
69 S DIR("B")="NO",DIR(0)="Y"
70 S DIR("A")="Would you like to edit another request"
71 D ^DIR
72 Q:'Y!($D(DIRUT))
73 G ED1
74W6 D EN^DDIOL("For the transaction number,use an uppercase alpha as the first character,")
75 D EN^DDIOL(" and then 2-15 alphanumerics, as in 'ADP1'.")
76 D EN^DDIOL(" ")
77 Q
Note: See TracBrowser for help on using the repository browser.