PRCSEA ;WISC/SAW/DXH/BM/SC/DAP - CONTROL POINT ACTIVITY EDITS ;5/8/13 15:31
V ;;5.1;IFCAP;**81,147,150,174,196,204**;Oct 20, 2000;Build 14
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
;to update Audit file (#414.02), and send update message to
;DynaMed thru a call to rtn PRCVTCA.
;
;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.
;Also, Control the node 0 counter for file 410 kill (DIK)
;since DIK call does not handle descending file logic
;
;PRC*5.1*196 Check to move Date Required to Committed Date (MOP: 2-4)
; to insure a later date is used for FMS document. Also,
; added date check called from templates PRCSENR&NRS,
; PRCSEN2237S & PRCSENPRS to insure dates are in same
; FY/FQ defined.
;
ENRS ;ENTER REQ
S PRCSK=1,X3="H"
D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered
D W6 ; display help on transaction# format
ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="ABELQX",D="H" ;PRC*5.1*150
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 ; lookup & preliminary validity checking
K DLAYGO,DIC("A"),DIC("S")
G:Y<0 EXIT
I $P(Y,U,3)'=1 W $C(7)," Must be a new (unique) entry." G ENRS0 ;PRC*5.1*150
;*81 Check site parameter to see if issue books are allowed
D CKPRM^PRCSEB
W !!,PRCVY,!
S (PDA,T1,DA)=+Y
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0
S T(2)=$P(Y,U,2)
D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default
I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point
S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
TYPE ;
W !!,"This transaction is assigned temporary transaction number: ",T(2)
S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ"
S DIC("S")=PRCVX ; only allow selection of 2237's
D ^DIC
S DA=PDA
;if user didn't enter a form type, go ask whether to backout and act
;accordingly: go let them re-enter a form type or exit
I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT
;
I Y<2 W "??" G TYPE
K PRCVX,PRCVY
S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y,PRCSTYP=X ; form type ;PRC*5.1*196
; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes',
; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
K PRCSERR ; flag denoting item info is missing
S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
S PRCSTYP=X ; form type ;PRC*5.1*196
S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
EN1 K DTOUT,DUOUT,Y
D ^DIE
S DA=PDA
I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT
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
. S PRCOMDT=$S($P($G(^PRCS(410,DA,1)),U,4)'=DT:$P($G(^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
D RL^PRCSUT1 ; sets up 'IT' & '10' nodes
D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item')
D DOR ; populate date of request field if it is nil
L -^PRCS(410,DA)
S T="enter" D W5 G EXIT:%'=1
W !! K PRCS("SUB")
G ENRS
;
EDRS ;EDIT REQ
; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
D W6 ; format doc for txn#
S X3="H" 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 & cannot be a 1358
D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
S (PDA,DA,T1)=+Y
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS
; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
; D EN2B^PRCSUT3
S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5)
S PRC("CP")=$P(^PRCS(410,PDA,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
I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197
. N PRCSIP D IP^PRCSUT
. I $D(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP ;PRC*5.1*147 modified file set from ^PRC(410 to ^PRCS(410
S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM
S PRCSTYP=X ; form type ;PRC*5.1*196
;*81 Check site parameter to see if Issue Books are allowed
D CKPRM
I PRCVD=1 S PRCVZ=1
I PRCVD'=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." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS
;
S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
;P182--Modified next 3 lines to use new templates if supply fund FCP
S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
ED1 K DTOUT,DUOUT,Y
D ^DIE
S DA=PDA
I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
COMDT 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
. 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
D RL^PRCSUT1
D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ
L -^PRCS(410,DA)
S T="edit" D W5 G EXIT:%'=1
W !! K PRCS("SUB")
G EDRS
;
CT ;CANCEL A (PERMANENT) TRANS
D EN3^PRCSUT
G W2:'$D(PRC("SITE")),EXIT:Y<0
S DIC="^PRCS(410,",DIC(0)="AEMQ"
;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
S DIC("A")="Select TRANSACTION: "
D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1
S DA=+Y
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT
S DIE="^PRCS(410,",DR="104////^S X=DUZ" D ^DIE K DIE,DR
S T=$P(^PRCS(410,DA,0),"^")
I T?1A.E D G EXIT:%'=1 W !! G CT ;PRC*5.1*150 Will DELETE entry if temporary transaction
. S DIK="^PRCS(410,",PRCIENCT=$P(^PRCS(410,0),"^",3)+1
. D ^DIK
. S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT,DIK
. S T="cancel" D W4
S $P(^PRCS(410,DA,11),"^",3)="",$P(^PRCS(410,DA,0),"^",2)="CA",$P(^PRCS(410,DA,5),"^")=0,$P(^PRCS(410,DA,6),"^")=0
K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
K ZX
I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1)
D ERS410^PRC0G(DA_"^C")
W !,"Enter comments for this cancellation",!
S DIE=DIC,DR=60
D ^DIE
;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
D EN^PRCVTCA(DA)
L -^PRCS(410,DA)
I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
S T="cancel" D W4 G EXIT:%'=1
W !! G CT
;
DT ;DELETE A (TEMPORARY) TRANS
S X3="H"
D W6 ; format doc for txn#
S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H"
S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
D ^PRCSDIC G EXIT:Y<0
K DIC("S"),DIC("A")
S DA=+Y
L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT
DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1
;The following line was commented out in patch 182; should NOT manually
;change or reset last assigned IEN # in node zero.
;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150
S DIK=DIC
W !,"Okay....."
D ^DIK K DIK
S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150
L -^PRCS(410,DA)
;The following line was commented out in patch 182; should NOT manually
;change or reset last assigned IEN # in node zero.
;S $P(^PRCS(410,0),U,3)=PRCSDA
K PRCSDA
W "It's deleted"
S T="delete" D W4 G EXIT:%'=1
W !! G DT
;
;
DOR ; Date of Request
I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q
S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y
Q
FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
D CKPRM
I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option."
I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option."
W !,PRCVY1,!
W !,"Please enter another form type",!
S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ"
S DIC("S")=PRCVX1
D ^DIC
S:Y=-1 Y=2
S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
K DIC,PRCVX1,PRCVY1,PRCVD
Q
;
;Allow user the option of re entering a form type. If they decline,
;kill off the transaction and return 1; else return 0
BACKOUT(TRNNAME,TRNDA) ;
N DIK,Y,%,DA
W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7)
W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN
I %=0 G BACKOUT
I %=2 Q 0
S DIK="^PRCS(410,",DA=TRNDA
S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150
D ^DIK
S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150
Q 1
;
W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT
W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140
W !!,"This transaction is assigned temporary transaction number: ",X Q
W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q
W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q
W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q
;*81 Site parameter pull
CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
Q
;
EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ,PRCOMDT,PRCSTYP ;PRC*5.1*196
I $D(PRCSERR) K PRCSERR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEA 12161 printed Oct 16, 2024@18:18:11 Page 2
PRCSEA ;WISC/SAW/DXH/BM/SC/DAP - CONTROL POINT ACTIVITY EDITS ;5/8/13 15:31
V ;;5.1;IFCAP;**81,147,150,174,196,204**;Oct 20, 2000;Build 14
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
+4 ;to update Audit file (#414.02), and send update message to
+5 ;DynaMed thru a call to rtn PRCVTCA.
+6 ;
+7 ;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx
+8 ;number to be used at all. Previously, the same temp tx #
+9 ;could be used by different users, not same user.
+10 ;Also, Control the node 0 counter for file 410 kill (DIK)
+11 ;since DIK call does not handle descending file logic
+12 ;
+13 ;PRC*5.1*196 Check to move Date Required to Committed Date (MOP: 2-4)
+14 ; to insure a later date is used for FMS document. Also,
+15 ; added date check called from templates PRCSENR&NRS,
+16 ; PRCSEN2237S & PRCSENPRS to insure dates are in same
+17 ; FY/FQ defined.
+18 ;
ENRS ;ENTER REQ
+1 SET PRCSK=1
SET X3="H"
+2 ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
DO EN1F^PRCSUT(1)
+3 ; unauthorized user or '^' entered
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
+4 ; display help on transaction# format
DO W6
ENRS0 ;PRC*5.1*150
SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="ABELQX"
SET D="H"
+1 SET DIC("A")="Select TRANSACTION: "
+2 ; 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))"
+3 ; lookup & preliminary validity checking
DO ^PRCSDIC
+4 KILL DLAYGO,DIC("A"),DIC("S")
+5 if Y<0
GOTO EXIT
+6 ;PRC*5.1*150
IF $PIECE(Y,U,3)'=1
WRITE $CHAR(7)," Must be a new (unique) entry."
GOTO ENRS0
+7 ;*81 Check site parameter to see if issue books are allowed
+8 DO CKPRM^PRCSEB
+9 WRITE !!,PRCVY,!
+10 SET (PDA,T1,DA)=+Y
+11 LOCK +^PRCS(410,DA):1
IF $TEST=0
WRITE !,"File is being accessed...try a different transaction number or try later"
GOTO ENRS0
+12 SET T(2)=$PIECE(Y,U,2)
+13 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
DO EN2A^PRCSUT3
+14 ; originator (entered by)
SET $PIECE(^PRCS(410,DA,14),"^")=DUZ
+15 ; requestor default
SET $PIECE(^PRCS(410,DA,7),"^")=DUZ
SET $PIECE(^PRCS(410,DA,7),"^",2)=$PIECE($GET(^VA(200,DUZ,20)),"^",3)
+16 ; PRCSIP was set up in PRCSUT & is inventory distribution point
IF $GET(PRCSIP)
SET $PIECE(^PRCS(410,DA,0),"^",6)=PRCSIP
SET ^PRCS(410,"AO",PRCSIP,DA)=""
+17 ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
SET PRCS=""
+18 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
if $PIECE(^(0),"^",11)="Y"
SET PRCS=1
TYPE ;
+1 WRITE !!,"This transaction is assigned temporary transaction number: ",T(2)
+2 SET DIC("A")="FORM TYPE: "
SET DIC="^PRCS(410.5,"
SET DIC(0)="AEQZ"
+3 ; only allow selection of 2237's
SET DIC("S")=PRCVX
+4 DO ^DIC
+5 SET DA=PDA
+6 ;if user didn't enter a form type, go ask whether to backout and act
+7 ;accordingly: go let them re-enter a form type or exit
+8 IF Y<0
if '$$BACKOUT(T(2),DA)
GOTO TYPE
LOCK -^PRCS(420,DA)
GOTO EXIT
+9 ;
+10 IF Y<2
WRITE "??"
GOTO TYPE
+11 KILL PRCVX,PRCVY
+12 ; form type ;PRC*5.1*196
SET $PIECE(^PRCS(410,DA,0),"^",4)=+Y
SET X=+Y
SET PRCSTYP=X
+13 ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes',
+14 ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
+15 if 'PRCS&(X>2)
SET $PIECE(^PRCS(410,DA,0),"^",4)=2
SET X=2
+16 ; flag denoting item info is missing
KILL PRCSERR
+17 SET DIC(0)="AEMQ"
SET (DIC,DIE)="^PRCS(410,"
+18 ; form type ;PRC*5.1*196
SET PRCSTYP=X
+19 SET (PRCSDR,DR)="["_$SELECT(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
EN1 KILL DTOUT,DUOUT,Y
+1 DO ^DIE
+2 SET DA=PDA
+3 IF $DATA(Y)!($DATA(DTOUT))
DO DOR
LOCK -^PRCS(410,DA)
GOTO EXIT
CMDAT ;PRC*5.1*196, PRC*5.1*204 protect global with $G
IF PRCSTYP>1
IF PRCSTYP<5
IF $PIECE($GET(^PRCS(410,DA,4)),U,2)=""
Begin DoDot:1
+1 SET PRCOMDT=$SELECT($PIECE($GET(^PRCS(410,DA,1)),U,4)'=DT:$PIECE($GET(^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 ; sets up 'IT' & '10' nodes
DO RL^PRCSUT1
+5 ; missing required field ('item')
DO ^PRCSCK
IF $DATA(PRCSERR)
IF PRCSERR
GOTO EN1
+6 ; populate date of request field if it is nil
DO DOR
+7 LOCK -^PRCS(410,DA)
+8 SET T="enter"
DO W5
if %'=1
GOTO EXIT
+9 WRITE !!
KILL PRCS("SUB")
+10 GOTO ENRS
+11 ;
EDRS ;EDIT REQ
+1 ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
+2 ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
+3 ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
+4 ; format doc for txn#
DO W6
+5 SET X3="H"
SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET D="H"
+6 SET DIC("A")="Select TRANSACTION: "
+7 ; request must be authored by user or unauthored & cannot 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)="""")"
+8 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("A"),DIC("S")
+9 SET (PDA,DA,T1)=+Y
+10 LOCK +^PRCS(410,DA):1
IF $TEST=0
WRITE !,"File is being accessed...please try later"
GOTO EDRS
+11 ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
+12 ; D EN2B^PRCSUT3
+13 SET PRC("SITE")=+$PIECE(^PRCS(410,PDA,0),"^",5)
+14 SET PRC("CP")=$PIECE(^PRCS(410,PDA,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 ; prc*5*197
IF $PIECE(^PRCS(410,PDA,0),"^",6)=""
Begin DoDot:1
+20 NEW PRCSIP
DO IP^PRCSUT
+21 ;PRC*5.1*147 modified file set from ^PRC(410 to ^PRCS(410
IF $DATA(PRCSIP)
SET $PIECE(^PRCS(410,DA,0),U,6)=PRCSIP
End DoDot:1
+22 SET X=+$PIECE(^PRCS(410,DA,0),"^",4)
IF X<1
DO FORM
+23 ; form type ;PRC*5.1*196
SET PRCSTYP=X
+24 ;*81 Check site parameter to see if Issue Books are allowed
+25 DO CKPRM
+26 IF PRCVD=1
SET PRCVZ=1
+27 IF PRCVD'=1
SET PRCVZ=0
+28 WRITE !,"The form type for this transaction is ",$PIECE($GET(^PRCS(410.5,X,0)),"^"),!
+29 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."
SET T="edit"
DO W5
if %'=1
GOTO EXIT
WRITE !!
KILL PRCS("SUB")
GOTO EDRS
+30 ;
+31 SET DIC(0)="AEMQ"
SET (DIC,DIE)="^PRCS(410,"
+32 ;P182--Modified next 3 lines to use new templates if supply fund FCP
+33 SET (DR,PRCSDR)="["_$SELECT(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
ED1 KILL DTOUT,DUOUT,Y
+1 DO ^DIE
+2 SET DA=PDA
+3 IF $DATA(Y)!($DATA(DTOUT))
LOCK -^PRCS(410,DA)
GOTO EXIT
COMDT ;PRC*5.1*196, PRC*5.1*204 protect global with $G
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 DO RL^PRCSUT1
+5 DO ^PRCSCK
IF $DATA(PRCSERR)
IF PRCSERR
GOTO ED1
+6 KILL PRCSERR
SET $PIECE(^PRCS(410,DA,14),"^")=DUZ
+7 LOCK -^PRCS(410,DA)
+8 SET T="edit"
DO W5
if %'=1
GOTO EXIT
+9 WRITE !!
KILL PRCS("SUB")
+10 GOTO EDRS
+11 ;
CT ;CANCEL A (PERMANENT) TRANS
+1 DO EN3^PRCSUT
+2 if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
+3 SET DIC="^PRCS(410,"
SET DIC(0)="AEMQ"
+4 ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+5 SET DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+6 SET DIC("A")="Select TRANSACTION: "
+7 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("S"),DIC("A")
CT1 WRITE !,"Cancel this transaction"
SET %=2
DO YN^DICN
if %=0
GOTO CT1
if %'=1
GOTO EXIT
+1 SET DA=+Y
+2 LOCK +^PRCS(410,DA):1
IF $TEST=0
WRITE !,"File is being accessed...please try later"
GOTO CT
+3 SET DIE="^PRCS(410,"
SET DR="104////^S X=DUZ"
DO ^DIE
KILL DIE,DR
+4 SET T=$PIECE(^PRCS(410,DA,0),"^")
+5 ;PRC*5.1*150 Will DELETE entry if temporary transaction
IF T?1A.E
Begin DoDot:1
+6 SET DIK="^PRCS(410,"
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
+7 DO ^DIK
+8 SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
KILL PRCIENCT,DIK
+9 SET T="cancel"
DO W4
End DoDot:1
if %'=1
GOTO EXIT
WRITE !!
GOTO CT
+10 SET $PIECE(^PRCS(410,DA,11),"^",3)=""
SET $PIECE(^PRCS(410,DA,0),"^",2)="CA"
SET $PIECE(^PRCS(410,DA,5),"^")=0
SET $PIECE(^PRCS(410,DA,6),"^")=0
+11 KILL ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$PIECE(T,"-",5),DA),^PRCS(410,"F1",$PIECE(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
+12 KILL ZX
+13 IF $DATA(^PRCS(410,DA,4))
SET ZX=^(4)
SET X=$PIECE(ZX,"^",8)
FOR I=1,3,6,8
SET $PIECE(ZX,"^",I)=0
+14 IF $DATA(ZX)
SET ^PRCS(410,DA,4)=ZX
KILL ZX
+15 IF $DATA(^PRCS(410,DA,12,0))
SET N=0
FOR I=0:0
SET N=$ORDER(^PRCS(410,DA,12,N))
if N'>0
QUIT
SET X=$PIECE(^(N,0),"^",2)
IF X
SET DA(1)=DA
SET DA=N
DO TRANK^PRCSEZZ
SET DA=DA(1)
+16 DO ERS410^PRC0G(DA_"^C")
+17 WRITE !,"Enter comments for this cancellation",!
+18 SET DIE=DIC
SET DR=60
+19 DO ^DIE
+20 ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
+21 DO EN^PRCVTCA(DA)
+22 LOCK -^PRCS(410,DA)
+23 IF $DATA(^PRC(443,DA,0))
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+24 SET T="cancel"
DO W4
if %'=1
GOTO EXIT
+25 WRITE !!
GOTO CT
+26 ;
DT ;DELETE A (TEMPORARY) TRANS
+1 SET X3="H"
+2 ; format doc for txn#
DO W6
+3 SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET DIC("A")="Select TRANSACTION: "
SET D="H"
+4 SET DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
+5 DO ^PRCSDIC
if Y<0
GOTO EXIT
+6 KILL DIC("S"),DIC("A")
+7 SET DA=+Y
+8 LOCK +^PRCS(410,DA):5
IF $TEST=0
WRITE !,"File is being accessed...please try later"
GOTO DT
DT1 WRITE !,"Delete this transaction"
SET %=2
DO YN^DICN
if %=0
GOTO DT1
if %'=1
GOTO EXIT
+1 ;The following line was commented out in patch 182; should NOT manually
+2 ;change or reset last assigned IEN # in node zero.
+3 ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
+4 ;PRC*5.1*150
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
+5 SET DIK=DIC
+6 WRITE !,"Okay....."
+7 DO ^DIK
KILL DIK
+8 ;PRC*5.1*150
SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
KILL PRCIENCT
+9 LOCK -^PRCS(410,DA)
+10 ;The following line was commented out in patch 182; should NOT manually
+11 ;change or reset last assigned IEN # in node zero.
+12 ;S $P(^PRCS(410,0),U,3)=PRCSDA
+13 KILL PRCSDA
+14 WRITE "It's deleted"
+15 SET T="delete"
DO W4
if %'=1
GOTO EXIT
+16 WRITE !!
GOTO DT
+17 ;
+18 ;
DOR ; Date of Request
+1 IF $DATA(^PRCS(410,DA,1))
IF $PIECE(^PRCS(410,DA,1),"^")'=""
QUIT
+2 SET %DT="X"
SET X="T"
DO ^%DT
SET $PIECE(^PRCS(410,DA,1),"^")=Y
+3 QUIT
FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
+1 DO CKPRM
+2 IF PRCVD=1
SET PRCVX1="I Y>1&(Y<5)"
SET PRCVY1="The Issue Book and NO FORM type are not valid in this option."
+3 IF PRCVD'=1
SET PRCVX1="I Y>1"
SET PRCVY1="The NO FORM type is not valid in this option."
+4 WRITE !,PRCVY1,!
+5 WRITE !,"Please enter another form type",!
+6 SET PRCSDAA=DA
SET DIC="^PRCS(410.5,"
SET DIC("A")="FORM TYPE: "
SET DIC(0)="AEQZ"
+7 SET DIC("S")=PRCVX1
+8 DO ^DIC
+9 if Y=-1
SET Y=2
+10 SET DA=PRCSDAA
SET $PIECE(^PRCS(410,DA,0),"^",4)=+Y
SET X=+Y
+11 KILL DIC,PRCVX1,PRCVY1,PRCVD
+12 QUIT
+13 ;
+14 ;Allow user the option of re entering a form type. If they decline,
+15 ;kill off the transaction and return 1; else return 0
BACKOUT(TRNNAME,TRNDA) ;
+1 NEW DIK,Y,%,DA
+2 WRITE !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$CHAR(7)
+3 WRITE !,"Are you sure you want to delete this transaction"
SET %=2
DO YN^DICN
+4 IF %=0
GOTO BACKOUT
+5 IF %=2
QUIT 0
+6 SET DIK="^PRCS(410,"
SET DA=TRNDA
+7 ;PRC*5.1*150
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
+8 DO ^DIK
+9 ;PRC*5.1*150
SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
KILL PRCIENCT
+10 QUIT 1
+11 ;
W2 WRITE !!,"You are not an authorized control point user.",!,"Contact control point official"
READ X:5
GOTO EXIT
W3 ; can this subroutine be deleted? commented out in patch PRC*5*140
QUIT
+1 WRITE !!,"This transaction is assigned temporary transaction number: ",X
QUIT
W4 WRITE !!,"Would you like to ",T," another transaction"
SET %=2
DO YN^DICN
if %=0
GOTO W4
QUIT
W5 WRITE !!,"Would you like to ",T," another request"
SET %=1
DO YN^DICN
if %=0
GOTO W5
QUIT
W6 WRITE !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",!
QUIT
+1 ;*81 Site parameter pull
CKPRM SET PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
+1 QUIT
+2 ;
EXIT ;PRC*5.1*196
KILL %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ,PRCOMDT,PRCSTYP
+1 IF $DATA(PRCSERR)
KILL PRCSERR
+2 QUIT
