PRCSEA1 ;WISC/KMB/DXH - REQUESTOR ENTER 1358 ;7.26.99
V ;;5.1;IFCAP;**150,204**;Oct 20, 2000;Build 14
;Per VA Directive 6402, this routine should not be modified.
;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx
;number to be used at all. Previously, the same temp tx #
;could be used by different users, not same user.
;
EN ;
N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
K PRCBBMY
S PRCSK=1,X3="H"
D EN1F^PRCSUT(1) Q:Y<0
D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
D EN^DDIOL(" ") ; blank line
EN1 ;
S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="ABELQX",D="H"
S DIC("A")="Select TRANSACTION: "
S DIC("S")="I '^(0),$P(^(0),U)'="""",$D(^PRCS(410,""B"",$P(^(0),U),+Y))" ; only temp tx number not defined will be allowed ;PRC*5.1*150
D ^PRCSDIC
K DLAYGO,DIC("A"),DIC("S")
Q:Y<0
I $P(Y,U,3)'=1 D EN^DDIOL("Must be a new entry. ") G EN1
L +^PRCS(410,+Y):1 ;CHANGED DA TO +Y IN P182
I $T=0 D EN^DDIOL("File being accessed, please try another entry") G EN1
S T(2)=$P(Y,U,2)
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)
S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
S $P(^PRCS(410,DA,7),"^",1)=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3)
; commented out by PRC*5*140 - automated flag not implemeted in option, if commented lines are removed, remember to stop newing the PRCS variable
; S PRCS="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
S X=T(2)
D EN^DDIOL("This transaction is assigned temporary transaction number: "_X,"","!!")
K PRCSERR
S DIC(0)="AEMQ",DIE=DIC,DIE("NO^")=1
S DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1
D ^DIE
S PRCAED=1 ; cannot find where or how PRCAED is used
S DR="[PRCE NEW 1358S]"
D ^DIE
D W1^PRCSEB ; ask 'review?'
L -^PRCS(410,DA)
S DIR("B")="NO",DIR(0)="Y"
S DIR("A")="Do you want to enter another new request"
D ^DIR Q:'Y!($D(DIRUT))
W !!
; removed by PRC*5*140 - PRCS2 never set up
; K PRCS2
G EN1
ED ;edit 1358 for requestor
N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
K PRCBBMY
ED1 ;
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.
D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
D EN^DDIOL(" ")
S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
S DIC("A")="Select TRANSACTION: "
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
D ^PRCSDIC ; lookup & prelimiary validity checking
K DIC("A"),DIC("S")
Q:Y<0
S DA=+Y
L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...try later") Q
S DIC=(0)="AEMQ",DIE="^PRCS(410,"
S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5)
S PRC("CP")=$P(^PRCS(410,DA,3),"^")
;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed
I '$D(PRC("FY")) D FY^PRCSUT G EX^PRCSUT:PRC("FY")="^"
I '$D(PRC("QTR")) D QT^PRCSUT G EX^PRCSUT:PRC("QTR")="^"
I '$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")) G EX^PRCSUT
S (PRCSDR,DR)="[PRCE NEW 1358S]"
K DTOUT,DUOUT,Y
S PDA=DA
D ^DIE
S DA=PDA
I $D(Y)!($D(DTOUT)) S PRCAED=-1
D W1^PRCSEB
L -^PRCS(410,DA)
S DIR("B")="NO",DIR(0)="Y"
S DIR("A")="Would you like to edit another request"
D ^DIR
Q:'Y!($D(DIRUT))
G ED1
W6 D EN^DDIOL("For the transaction number,use an uppercase alpha as the first character,")
D EN^DDIOL(" and then 2-15 alphanumerics, as in 'ADP1'.")
D EN^DDIOL(" ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEA1 3751 printed Oct 16, 2024@18:18:12 Page 2
PRCSEA1 ;WISC/KMB/DXH - REQUESTOR ENTER 1358 ;7.26.99
V ;;5.1;IFCAP;**150,204**;Oct 20, 2000;Build 14
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx
+3 ;number to be used at all. Previously, the same temp tx #
+4 ;could be used by different users, not same user.
+5 ;
EN ;
+1 NEW PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
+2 KILL PRCBBMY
+3 SET PRCSK=1
SET X3="H"
+4 DO EN1F^PRCSUT(1)
if Y<0
QUIT
+5 DO EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
+6 ; blank line
DO EN^DDIOL(" ")
EN1 ;
+1 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="ABELQX"
SET D="H"
+2 SET DIC("A")="Select TRANSACTION: "
+3 ; only temp tx number not defined will be allowed ;PRC*5.1*150
SET DIC("S")="I '^(0),$P(^(0),U)'="""",$D(^PRCS(410,""B"",$P(^(0),U),+Y))"
+4 DO ^PRCSDIC
+5 KILL DLAYGO,DIC("A"),DIC("S")
+6 if Y<0
QUIT
+7 IF $PIECE(Y,U,3)'=1
DO EN^DDIOL("Must be a new entry. ")
GOTO EN1
+8 ;CHANGED DA TO +Y IN P182
LOCK +^PRCS(410,+Y):1
+9 IF $TEST=0
DO EN^DDIOL("File being accessed, please try another entry")
GOTO EN1
+10 SET T(2)=$PIECE(Y,U,2)
+11 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data, etc. in new ien (nodes 0,3,6,11 of file 410)
DO EN2A^PRCSUT3
+12 ; originator (entered by)
SET $PIECE(^PRCS(410,DA,14),"^")=DUZ
+13 SET $PIECE(^PRCS(410,DA,7),"^",1)=DUZ
SET $PIECE(^PRCS(410,DA,7),"^",2)=$PIECE($GET(^VA(200,DUZ,20)),"^",3)
+14 ; commented out by PRC*5*140 - automated flag not implemeted in option, if commented lines are removed, remember to stop newing the PRCS variable
+15 ; S PRCS="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
+16 SET X=T(2)
+17 DO EN^DDIOL("This transaction is assigned temporary transaction number: "_X,"","!!")
+18 KILL PRCSERR
+19 SET DIC(0)="AEMQ"
SET DIE=DIC
SET DIE("NO^")=1
+20 SET DR="3///1"_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")
SET X4=1
+21 DO ^DIE
+22 ; cannot find where or how PRCAED is used
SET PRCAED=1
+23 SET DR="[PRCE NEW 1358S]"
+24 DO ^DIE
+25 ; ask 'review?'
DO W1^PRCSEB
+26 LOCK -^PRCS(410,DA)
+27 SET DIR("B")="NO"
SET DIR(0)="Y"
+28 SET DIR("A")="Do you want to enter another new request"
+29 DO ^DIR
if 'Y!($DATA(DIRUT))
QUIT
+30 WRITE !!
+31 ; removed by PRC*5*140 - PRCS2 never set up
+32 ; K PRCS2
+33 GOTO EN1
ED ;edit 1358 for requestor
+1 NEW PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3
+2 KILL PRCBBMY
ED1 ;
+1 ; PRC*5*140 comment - PRCAED used?, X3="H" for all other temp txn options. X3 determines xrefs to search in finding txn name.
SET PRCAED=1
SET X3=1
+2 DO EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!")
+3 DO EN^DDIOL(" ")
+4 SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET D="H"
+5 SET DIC("A")="Select TRANSACTION: "
+6 ; request must be authored by user or unauthored & must be a 1358
SET DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")"
+7 ; lookup & prelimiary validity checking
DO ^PRCSDIC
+8 KILL DIC("A"),DIC("S")
+9 if Y<0
QUIT
+10 SET DA=+Y
+11 LOCK +^PRCS(410,DA):1
IF $TEST=0
DO EN^DDIOL("File being accessed...try later")
QUIT
+12 SET DIC=(0)="AEMQ"
SET DIE="^PRCS(410,"
+13 SET PRC("SITE")=+$PIECE(^PRCS(410,DA,0),"^",5)
+14 SET PRC("CP")=$PIECE(^PRCS(410,DA,3),"^")
+15 ;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed
+16 IF '$DATA(PRC("FY"))
DO FY^PRCSUT
if PRC("FY")="^"
GOTO EX^PRCSUT
+17 IF '$DATA(PRC("QTR"))
DO QT^PRCSUT
if PRC("QTR")="^"
GOTO EX^PRCSUT
+18 IF '$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"))
GOTO EX^PRCSUT
+19 SET (PRCSDR,DR)="[PRCE NEW 1358S]"
+20 KILL DTOUT,DUOUT,Y
+21 SET PDA=DA
+22 DO ^DIE
+23 SET DA=PDA
+24 IF $DATA(Y)!($DATA(DTOUT))
SET PRCAED=-1
+25 DO W1^PRCSEB
+26 LOCK -^PRCS(410,DA)
+27 SET DIR("B")="NO"
SET DIR(0)="Y"
+28 SET DIR("A")="Would you like to edit another request"
+29 DO ^DIR
+30 if 'Y!($DATA(DIRUT))
QUIT
+31 GOTO ED1
W6 DO EN^DDIOL("For the transaction number,use an uppercase alpha as the first character,")
+1 DO EN^DDIOL(" and then 2-15 alphanumerics, as in 'ADP1'.")
+2 DO EN^DDIOL(" ")
+3 QUIT
