PRCSEB0 ;SF-ISC/LJP/SAW/DGL/DAP - CPA EDITS CON'T ;7/9/13 16:01
V ;;5.1;IFCAP;**81,174,196,204**;Oct 20, 2000;Build 14
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*196 Check to move Date Required to Committed Date to
; insure a later date is used for FMS document.
;
EDTD ;EDIT TRANSACTION DATA
N TYPE,TYPE1,CHECK,JUMP S JUMP=1 K PRCBBMY
D EN3F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0
S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM" S DIC("S")="I $P(^(0),U,4)'=1" S:$D(PRCSFT) DIC("S")="I $P(^(0),U,4)=1"
S DIC("S")=DIC("S")_",$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
D ^PRCSDIC G EXIT:Y<0 K DIC("S") S (DA,PRCSDAA,PRCSY,T1)=+Y L +^PRCS(410,DA):15 G EDTD:$T=0
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 ;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed
S TYPE=$P(^PRCS(410,DA,0),"^",4)
EDTD1 S X=^PRCS(410,DA,0) S:+X PRC("FY")=$P(X,"-",2),PRC("QTR")=+$P(X,"-",3) S PRCSX3=$P(X,"^",2) G ASK:PRCSX3="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",11)="Y" S PRCS2=1
EDTD3 I $D(^PRCS(410,DA,7)),$P(^(7),U,6)]"" G EDTD4
I $D(PRCSEM) S DIE=DIC,DR="[PRCSENMDR]" D ^DIE S DA=T1 L -^PRCS(410,DA) G EXIT
I PRCSX3'="O" S DR=$S(PRCSX3="C"&('$D(PRCS2)):"[PRCSENC]",PRCSX3="C"&($D(PRCS2)):"[PRCSENCI]",PRCSX3="A":"[PRCSENA]",1:"[PRCSENCT]") S:PRCSX3="A"&($P(^PRCS(410,PRCSY,0),U,4)=1) DR="[PRCSENA 1358]" S DIE=DIC D ^DIE S DA=PRCSY
D:PRCSX3="A"&($O(^PRCS(410,PRCSY,12,0))) SCPC0^PRCSED
I PRCSX3="A",$P(^PRCS(410,DA,0),U,4)=1 S X=$P(^(4),U,6),X1=$P(^(3),U,7) I $J(X,0,2)'=$J(X1,0,2)!('X)!('X1) W $C(7),!,"Adj $ Amt does not equal the total of BOC $ Amts.",!,"Please correct the error.",! K DR G EDTD3
I PRCSX3="A",$P(^PRCS(410,DA,0),"^",4)=1 D W6^PRCSEB
I PRCSX3'="O" G EDTD2
EDTD4 I $D(^PRCS(410,DA,7)),$P(^(7),"^",6)'="" S DR="[PRCSEDS]" D ^DIE D W1 G EDTD2
EDTD5 ;*81 Loop now checks site parameter to see if Issue Books should be allowed
S X=+$P(^PRCS(410,DA,0),"^",4) I X<2 D
.I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The 1358, Issue Book, and NO FORM types are not valid for use in this option."
.I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The 1358 and NO FORM types are not valid for use in this option."
.W !,PRCVY,!
.W !,"Please enter another form type.",!
.S PRCDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ",DIC("S")=PRCVX,DIC("B")=4 D ^DIC S:Y=-1 Y=4 S DA=PRCDAA K DIC
.K PRCVX,PRCVY
.S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0
W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),!
I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order." D W3 G:%'=1 EXIT W !! K PRCS,PRCS2 G EDTD
;P182--Removed reference to TEMPREQ in following line: no longer used.
;Q:$D(TEMPREQ) S (DIC,DIE)="^PRCS(410,"
K PRCVZ
S (DIC,DIE)="^PRCS(410,"
G EDTD2:X=""
S PRCSTYP=X ;PRC*5.1*196
S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]"
ED1 K DTOUT,DUOUT,Y S PRCSDAA=DA D ^DIE I $D(Y)!$D(DTOUT) S DA=PRCSDAA L -^PRCS(410,DA) G EXIT ;PRC*5.1*196
CMDAT I PRCSTYP>1,PRCSTYP<5,$P($G(^PRCS(410,DA,4)),U,2)="" D ;PRC*5.1*196, PRC*5.1*204 protect global with $G and checks for timeout
. S PRCOMDT=$S($P(^PRCS(410,DA,1),U,4)'=DT:$P(^PRCS(410,DA,1),U,4),1:DT)
. S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE
. S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204
S DA=PRCSDAA D RL^PRCSUT1
D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
K PRCSERR
I PRCSDR="[PRCSENCOD]" D W7 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB
S:$P($G(^PRCS(410,DA,7)),U)="" $P(^PRCS(410,DA,7),U)=DUZ,$P(^PRCS(410,DA,7),U,2)=$P($G(^VA(200,DUZ,20)),U,3)
;
;if 2237 required field checks fail, warn user (PRC*5.1*174)
I PRCSDR'="[PRCSENCOD]",'$$REQCHECK^PRCHJUTL($G(DA),,1)
;
D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
EDTD2 S DA=PRCSDAA L -^PRCS(410,DA) G EXIT:$D(PRCSQ) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 G EDTD
ASK W !!,"This transaction does not have a valid transaction type (e.g.,O for Obligation, A for Adjustment, C for Ceiling). Please enter one now.",! S DR="1" D ^DIE K DR G EDTD1
W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
W3 W !!,"Would you like to edit another request" S %=1 D YN^DICN G W3:%=0 Q
W7 W !,"Do you wish to enter obligation data" S %=1 D YN^DICN Q:%=-1!(%=2) G W7:%=0 S:%=1 PRCSOB=1 Q
EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,Z7,PRCVZ,PRCSTYP,PRCOMDT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEB0 5224 printed Apr 09, 2024@21:15:36 Page 2
PRCSEB0 ;SF-ISC/LJP/SAW/DGL/DAP - CPA EDITS CON'T ;7/9/13 16:01
V ;;5.1;IFCAP;**81,174,196,204**;Oct 20, 2000;Build 14
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*196 Check to move Date Required to Committed Date to
+4 ; insure a later date is used for FMS document.
+5 ;
EDTD ;EDIT TRANSACTION DATA
+1 NEW TYPE,TYPE1,CHECK,JUMP
SET JUMP=1
KILL PRCBBMY
+2 DO EN3F^PRCSUT(1)
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
+3 SET DIC="^PRCS(410,"
SET DIE=DIC
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)'=1"
if $DATA(PRCSFT)
SET DIC("S")="I $P(^(0),U,4)=1"
+4 SET DIC("S")=DIC("S")_",$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+5 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("S")
SET (DA,PRCSDAA,PRCSY,T1)=+Y
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO EDTD
+6 IF '$DATA(PRC("FY"))
DO FY^PRCSUT
if PRC("FY")="^"
GOTO EX^PRCSUT
+7 IF '$DATA(PRC("QTR"))
DO QT^PRCSUT
if PRC("QTR")="^"
GOTO EX^PRCSUT
+8 ;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed
IF '$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"))
GOTO EX^PRCSUT
+9 SET TYPE=$PIECE(^PRCS(410,DA,0),"^",4)
EDTD1 SET X=^PRCS(410,DA,0)
if +X
SET PRC("FY")=$PIECE(X,"-",2)
SET PRC("QTR")=+$PIECE(X,"-",3)
SET PRCSX3=$PIECE(X,"^",2)
if PRCSX3=""
GOTO ASK
IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
IF $PIECE(^(0),"^",11)="Y"
SET PRCS2=1
EDTD3 IF $DATA(^PRCS(410,DA,7))
IF $PIECE(^(7),U,6)]""
GOTO EDTD4
+1 IF $DATA(PRCSEM)
SET DIE=DIC
SET DR="[PRCSENMDR]"
DO ^DIE
SET DA=T1
LOCK -^PRCS(410,DA)
GOTO EXIT
+2 IF PRCSX3'="O"
SET DR=$SELECT(PRCSX3="C"&('$DATA(PRCS2)):"[PRCSENC]",PRCSX3="C"&($DATA(PRCS2)):"[PRCSENCI]",PRCSX3="A":"[PRCSENA]",1:"[PRCSENCT]")
if PRCSX3="A"&($PIECE(^PRCS(410,PRCSY,0),U,4)=1)
SET DR="[PRCSENA 1358]"
SET DIE=DIC
DO ^DIE
SET DA=PRCSY
+3 if PRCSX3="A"&($ORDER(^PRCS(410,PRCSY,12,0)))
DO SCPC0^PRCSED
+4 IF PRCSX3="A"
IF $PIECE(^PRCS(410,DA,0),U,4)=1
SET X=$PIECE(^(4),U,6)
SET X1=$PIECE(^(3),U,7)
IF $JUSTIFY(X,0,2)'=$JUSTIFY(X1,0,2)!('X)!('X1)
WRITE $CHAR(7),!,"Adj $ Amt does not equal the total of BOC $ Amts.",!,"Please correct the error.",!
KILL DR
GOTO EDTD3
+5 IF PRCSX3="A"
IF $PIECE(^PRCS(410,DA,0),"^",4)=1
DO W6^PRCSEB
+6 IF PRCSX3'="O"
GOTO EDTD2
EDTD4 IF $DATA(^PRCS(410,DA,7))
IF $PIECE(^(7),"^",6)'=""
SET DR="[PRCSEDS]"
DO ^DIE
DO W1
GOTO EDTD2
EDTD5 ;*81 Loop now checks site parameter to see if Issue Books should be allowed
+1 SET X=+$PIECE(^PRCS(410,DA,0),"^",4)
IF X<2
Begin DoDot:1
+2 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
SET PRCVX="I Y>1&(Y<5)"
SET PRCVY="The 1358, Issue Book, and NO FORM types are not valid for use in this option."
+3 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVX="I Y>1"
SET PRCVY="The 1358 and NO FORM types are not valid for use in this option."
+4 WRITE !,PRCVY,!
+5 WRITE !,"Please enter another form type.",!
+6 SET PRCDAA=DA
SET DIC="^PRCS(410.5,"
SET DIC("A")="FORM TYPE: "
SET DIC(0)="AEQZ"
SET DIC("S")=PRCVX
SET DIC("B")=4
DO ^DIC
if Y=-1
SET Y=4
SET DA=PRCDAA
KILL DIC
+7 KILL PRCVX,PRCVY
+8 SET $PIECE(^PRCS(410,DA,0),"^",4)=+Y
SET X=+Y
End DoDot:1
+9 IF $GET(PRCSIP)
SET $PIECE(^PRCS(410,DA,0),"^",6)=PRCSIP
+10 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
SET PRCVZ=1
+11 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVZ=0
+12 WRITE !,"The form type for this transaction is ",$PIECE($GET(^PRCS(410.5,X,0)),"^"),!
+13 IF PRCVZ=1
IF X=5
WRITE !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order."
DO W3
if %'=1
GOTO EXIT
WRITE !!
KILL PRCS,PRCS2
GOTO EDTD
+14 ;P182--Removed reference to TEMPREQ in following line: no longer used.
+15 ;Q:$D(TEMPREQ) S (DIC,DIE)="^PRCS(410,"
+16 KILL PRCVZ
+17 SET (DIC,DIE)="^PRCS(410,"
+18 if X=""
GOTO EDTD2
+19 ;PRC*5.1*196
SET PRCSTYP=X
+20 SET (PRCSDR,DR)="["_$SELECT(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]"
ED1 ;PRC*5.1*196
KILL DTOUT,DUOUT,Y
SET PRCSDAA=DA
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
SET DA=PRCSDAA
LOCK -^PRCS(410,DA)
GOTO EXIT
CMDAT ;PRC*5.1*196, PRC*5.1*204 protect global with $G and checks for timeout
IF PRCSTYP>1
IF PRCSTYP<5
IF $PIECE($GET(^PRCS(410,DA,4)),U,2)=""
Begin DoDot:1
+1 SET PRCOMDT=$SELECT($PIECE(^PRCS(410,DA,1),U,4)'=DT:$PIECE(^PRCS(410,DA,1),U,4),1:DT)
+2 SET DR="21///^S X=PRCOMDT"
SET DIE="^PRCS(410,"
DO ^DIE
+3 ;reset DR to template value, PRC*5.1*204
SET DR=$GET(PRCSDR)
End DoDot:1
+4 SET DA=PRCSDAA
DO RL^PRCSUT1
+5 DO ^PRCSCK
IF $DATA(PRCSERR)
IF PRCSERR
GOTO ED1
+6 KILL PRCSERR
+7 IF PRCSDR="[PRCSENCOD]"
DO W7
if $DATA(PRCSOB)
DO ENOD1^PRCSEB1
KILL PRCSOB
+8 if $PIECE($GET(^PRCS(410,DA,7)),U)=""
SET $PIECE(^PRCS(410,DA,7),U)=DUZ
SET $PIECE(^PRCS(410,DA,7),U,2)=$PIECE($GET(^VA(200,DUZ,20)),U,3)
+9 ;
+10 ;if 2237 required field checks fail, warn user (PRC*5.1*174)
+11 IF PRCSDR'="[PRCSENCOD]"
IF '$$REQCHECK^PRCHJUTL($GET(DA),,1)
+12 ;
+13 if PRCSDR'="[PRCSENCOD]"
DO W1
IF $DATA(PRCS2)
IF +^PRCS(410,DA,0)
DO W6^PRCSEB
EDTD2 SET DA=PRCSDAA
LOCK -^PRCS(410,DA)
if $DATA(PRCSQ)
GOTO EXIT
DO W3
if %'=1
GOTO EXIT
WRITE !!
KILL PRCS,PRCS2
GOTO EDTD
ASK WRITE !!,"This transaction does not have a valid transaction type (e.g.,O for Obligation, A for Adjustment, C for Ceiling). Please enter one now.",!
SET DR="1"
DO ^DIE
KILL DR
GOTO EDTD1
W1 WRITE !!,"Would you like to review this request"
SET %=2
DO YN^DICN
if %=0
GOTO W1
if %'=1
QUIT
SET (N,PRCSZ)=DA
SET PRCSF=1
DO PRF1^PRCSP1
SET DA=PRCSZ
KILL X,PRCSF,PRCSZ
QUIT
W2 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
GOTO EXIT
W3 WRITE !!,"Would you like to edit another request"
SET %=1
DO YN^DICN
if %=0
GOTO W3
QUIT
W7 WRITE !,"Do you wish to enter obligation data"
SET %=1
DO YN^DICN
if %=-1!(%=2)
QUIT
if %=0
GOTO W7
if %=1
SET PRCSOB=1
QUIT
EXIT KILL %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,Z7,PRCVZ,PRCSTYP,PRCOMDT
QUIT
