Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSCPY

PRCSCPY.m

Go to the documentation of this file.
  1. PRCSCPY ;WISC/KMB/DXH/DAP - COPY OLD TEMP. REQUEST TO NEW ; 7.23.99
  1. V ;;5.1;IFCAP;**81**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. N X3,T,T1,PRCSDR,OLDA,NEWDA,PRCDAA,PRCSAPP,PRCSK,NEWTEMP,OLD0NODE,OLD3NODE,I,J,PRCK,PRCHFLG
  1. ;
  1. START ;
  1. W !!
  1. ; S PRCSK=1 ; flag to allow any user to select any site
  1. ; next line commented out in PRC*5*140 - user responses not used
  1. ; D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:Y<0
  1. S X3="H",DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select transaction to be copied: "
  1. S DIC("S")="I $P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or be unauthored
  1. D ^PRCSDIC K DIC("A"),DIC("S")
  1. G EXIT:Y<0 ; user entered '^'
  1. S (OLDA,DA)=+Y ; subscript/internal# to file 410
  1. L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...please try later") Q
  1. D REVIEW
  1. S PRCVFT=$P(^PRCS(410,DA,0),"^",4)
  1. ;*81 Check site parameter to see if Issue Books are allowed
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0
  1. I PRCVZ=1,PRCVFT=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order." D CLEAN G START
  1. K DA,DIC,PRCVFT,PRCVZ
  1. I $D(%) G EXIT:%=-1
  1. ENTRY ;
  1. D EN^DDIOL("Please enter information for the transaction being created.")
  1. W !
  1. S PRCSK=1 ; allow user to select any station on system
  1. D EN1F^PRCSUT(1) ;ask site, FY, QRTR, CP & store in PRC array, set up PRCSIP
  1. G W2:'$D(PRC("SITE")) ; only happens if there are no stations on system?
  1. G EXIT:Y<0
  1. EN1 D EN^DDIOL("Please enter a new transaction in the format 'A1234'")
  1. W !
  1. S DIC("A")="Enter new temporary transaction number: "
  1. S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="L",D="H"
  1. S DIC("S")="I '^(0),$P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match, display doesn't filter for station,CP,FY,or QRTR
  1. D ^PRCSDIC S NEWTEMP=X K DLAYGO,DIC("A"),DIC("S") G:Y<0 EXIT
  1. I $D(^PRCS(410,"H",$P(Y,U,2)))
  1. I D EN^DDIOL("Must be a new and different temporary number.","","!!") G EN1
  1. S (NEWDA,T1,DA)=+Y ; subscript/internal# to file 410 for new txn
  1. ;
  1. PROCESS ;ERC-10/96 Revised copy of fields into new transaction
  1. L +^PRCS(410,NEWDA):1 ; lock file being created
  1. I $T=0 D EN^DDIOL("File being accessed...please try a different number or try later") G EN1
  1. D EN^DDIOL("Transaction data is being copied.","","!?10") W !
  1. S T(2)=NEWTEMP
  1. D EN2A^PRCSUT3 ; sets up sta,substa,BBFY,author,CP,ACC,rb code,etc
  1. S OLD0NODE=^PRCS(410,OLDA,0),OLD3NODE=^PRCS(410,OLDA,3)
  1. F I=2,4 S $P(^PRCS(410,NEWDA,0),U,I)=$P(OLD0NODE,U,I) ; txn type,format
  1. ; note that for any FCP that is not automated,the form type is not forced to be non repetitive. This may be because full implementation of IFCAP is mandatory.
  1. I $D(PRCSIP) S $P(^PRCS(410,NEWDA,0),U,6)=PRCSIP ; inventory distrib point, 'AO' xref will be set by XREF subroutine
  1. S %DT="X",X="T" D ^%DT ; get today in internal date format
  1. S $P(^PRCS(410,NEWDA,1),U)=Y ; & store as date of request
  1. I $D(^PRCS(410,OLDA,2)) S ^PRCS(410,NEWDA,2)=^PRCS(410,OLDA,2) ; vendor info may not be on 1358's
  1. F I=4:1:10 S $P(^PRCS(410,NEWDA,3),U,I)=$P(OLD3NODE,U,I)
  1. I $P(OLD3NODE,U)'=PRC("CP") S PRCHFLG=1 ; different CP
  1. E S $P(^PRCS(410,NEWDA,3),U,3)=$P(OLD3NODE,U,3)
  1. F I=4,10 I $D(^PRCS(410,OLDA,I)) S $P(^PRCS(410,NEWDA,I),U)=$P(^PRCS(410,OLDA,I),U)
  1. I $P(^PRCS(410,NEWDA,0),U,4)=1 ;1358 needs Date Committed
  1. I S $P(^PRCS(410,NEWDA,4),U,2)=$E($P(^PRCS(410,NEWDA,1),U),1,5)_"01"
  1. S $P(^PRCS(410,DA,7),U)=DUZ ; PRC140 - this line moved from FINAL
  1. S $P(^PRCS(410,DA,14),U)=DUZ
  1. I $D(^PRCS(410,OLDA,"RM",0)) S ^PRCS(410,NEWDA,"RM",0)=$P(^PRCS(410,OLDA,"RM",0),U,1,4)_"^"_DT,PRCK=0 D
  1. . F J=0:0 S PRCK=$O(^PRCS(410,OLDA,"RM",PRCK)) Q:'PRCK S:$D(^PRCS(410,OLDA,"RM",PRCK,0)) ^PRCS(410,NEWDA,"RM",PRCK,0)=$P(^PRCS(410,OLDA,"RM",PRCK,0),U)
  1. S T1=OLDA,DA=NEWDA
  1. D S7^PRCSECP1 ; copy 'IT' subnode from the old transaction
  1. ;new transaction has different FCP from old txn
  1. I +$G(PRCHFLG) S PRCHFLG=$$CHGCCBOC^PRCSCK($P($G(^PRCS(410,T1,0)),U),$P($G(^PRCS(410,NEWDA,0)),U),$P($G(^PRCS(410,OLDA,3)),U,3),0)
  1. ;I '$G(PRCHFLG) G P2 ; new transaction has same CP as original
  1. ;D SRCH I X'="" S:X'=1 $P(^PRCS(410,NEWDA,3),U,3)=X G P1
  1. ;S DA=NEWDA,DR=15.5,DIE="^PRCS(410," D ^DIE ; ask cost center
  1. ;I $D(Y)'=0 D XREF G EXIT ; user entered '^'
  1. I ($G(PRCHFLG)<-1) D XREF G EXIT ; user entered '^'
  1. P1 K PRCHFLG
  1. P2 S DIC(0)="AEMQ",DIE=DIC,DR=7 D ^DIE ; ask Date required
  1. I $D(Y)'=0 D XREF G EXIT ; user entered '^'
  1. D XREF G EDIT
  1. XREF S DA=NEWDA,DIK="^PRCS(410," D IX^DIK ; set up X-refs for new transaction
  1. Q
  1. EDIT ;
  1. S %=2 D EN^DDIOL("Would you like to edit this entry")
  1. D YN^DICN G EDIT:%=0 G EXIT:%=-1 G:%=2 FINAL
  1. EDIT1 ;
  1. S X=+$P($G(^PRCS(410,DA,0)),"^",4) ; X is form type
  1. ;*81 Check site parameter to see if issue books should be allowed
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The Issue Book and NO FORM types are not valid in this option."
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The NO FORM type is not valid in this option."
  1. I X<1 D
  1. . S DA=NEWDA
  1. . D EN^DDIOL(PRCVY)
  1. . D EN^DDIOL("Please enter another form type.","","!!")
  1. . W !
  1. . S DIC="^PRCS(410.5,"
  1. . S DIC("A")="FORM TYPE: "
  1. . S DIC(0)="AEQZ"
  1. . S DIC("S")=PRCVX
  1. . D ^DIC
  1. . S:Y=-1 Y=2
  1. . S $P(^PRCS(410,NEWDA,0),"^",4)=+Y,X=+Y
  1. . K DIC,PRCVX,PRCVY
  1. D EN^DDIOL("The form type of this request is "_$P($G(^PRCS(410.5,X,0)),"^"))
  1. ; PRC140 - 2237 form types now use temporary transaction templates
  1. S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",X=5:"PRCSENIBS",1:"PRCSENCOD")_"]"
  1. K DTOUT,DUOUT,Y
  1. S (DIE,DIC)="^PRCS(410,"
  1. D ^DIE I $D(Y)!($D(DTOUT)) G EXIT
  1. I +$P($G(^PRCS(410,DA,0)),"^",4)=1 G FINAL ; skip line item processing if this is a 1358
  1. S DA=NEWDA D RL^PRCSUT1
  1. D ^PRCSCK I $D(PRCSERR),PRCSERR G EDIT1
  1. ;
  1. FINAL ;
  1. W !! D CLEAN G START
  1. ;
  1. REVIEW W !!,"Would you like to review this request" S %=2
  1. D YN^DICN G REVIEW:%=0 I %'=1 Q
  1. S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5)
  1. S PRC("CP")=$P(^PRCS(410,DA,3),"^")
  1. S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=OLDA K X,PRCSF,PRCSZ Q
  1. ;
  1. W2 D EN^DDIOL("You are not an authorized control point user.","","!!")
  1. D EN^DDIOL("Contact your control point official")
  1. R X:5 G EXIT
  1. W3 Q ;can this be deleted? - commented out in patch PRC*5*140
  1. D EN^DDIOL("Would you like to copy another request","","!!")
  1. S %=1 D YN^DICN G W3:%=0 G START:%=1 Q
  1. ;
  1. SRCH ;FIND COST CENTER
  1. ; returns x="" if there are multiple cc's, x=1 if no cc, x=cc if only 1
  1. S X=0
  1. SRCH1 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
  1. I X=""!(+X'=X) D EN^DDIOL("Transaction will be created but this control point has no active cost center","","!!") S X=1 Q
  1. I '$D(^PRCD(420.1,X,0)) G SRCH1
  1. I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH1
  1. S Y=X ; found 1 cost center
  1. SRCH2 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
  1. I X=""!(+X'=X) S X=$P(^PRCD(420.1,Y,0),U) Q ; save cost center
  1. I '$D(^PRCD(420.1,X,0)) G SRCH2
  1. I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH2
  1. S X="" ; system can't select cost center - there is more than 1
  1. Q
  1. CLEAN I $D(OLDA) L -^PRCS(410,OLDA)
  1. I $D(NEWDA)=1 L -^PRCS(410,NEWDA)
  1. K %,DA,DIC,X,Y,PRCSERR
  1. Q
  1. ;
  1. EXIT D CLEAN
  1. Q