PRCSEA1.m

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 ---PRCSEA1   3751     printed  Feb 18, 2025@23:43:50                                                                                                                                                                                                     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