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

PRCHNPOA.m

Go to the documentation of this file.
  1. PRCHNPOA ;WISC/RL/DXH - CHANGE TRANS. NUMBER FOR PCO INITIATED 2237 ;8.2.99
  1. V ;;5.1;IFCAP;**135**;Oct 20, 2000;Build 7
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ; This code is called after a user electronically signs a purchase
  1. ; card order. If the FCP on the 2237 does not match the one in the
  1. ; the transaction number for the 2237 entry, this code will change
  1. ; the existing transaction number for the 2237. To do this, a new
  1. ; ien is created and populated with info from the existing transaction,
  1. ; then canceled. The original transaction is updated with the new
  1. ; transaction number.
  1. ; (This code is a simplified of ANTN^PRCSUT2, which is called by the
  1. ; IFCAP option "Change Existing Transaction Number"
  1. ;
  1. ;Inputs: param PCODA is the IEN of the Purchase Card Order in 442 file.
  1. ;Return Values: none
  1. ;Globals modified: ^PRCS(410 (if necessary)
  1. ;
  1. CHECKFCP(PCODA) ;Check FCP in 2237 entry of the 410 file to see if it matches Trans #
  1. ;
  1. N CURFCP,ODA,OTNUM,OCP,OLDFYQ,CURFYQ,TDATE,SDATE
  1. S ODA=+$P($G(^PRC(442,PCODA,23)),U,23) ; ODA is the IEN for the old 410 entry
  1. S OTNUM=$P($G(^PRCS(410,ODA,0)),U,1) ; OTNUM is transaction # for old 410 entry
  1. S OCP=$P(OTNUM,"-",4) ; OCP is the original FCP for trans.
  1. S CURFCP=$P($G(^PRCS(410,ODA,3)),U,1) ; CURFCP is the current (valid) FCP for trans.
  1. ;Patch prc*5.1*135 now checks order date change, besides FCP
  1. S OLDFYQ=$P(OTNUM,"-",2,3),CURFYQ=PRC("FY")_"-"_PRC("QTR")
  1. Q:CURFCP=""&(OCP="")
  1. I (+CURFCP'=+OCP)!(CURFYQ'=OLDFYQ) D MODTXN
  1. Q
  1. ;
  1. MODTXN ;Modify the transaction number for the 2237 entry in the 410 file
  1. N %,%Y,D,DA,DIC,DIE,DR,I,J,L,ONODE0,N,PNW,PRCS,PRCSAPP,PRCSDIC,PRCSIP
  1. N PRCSL,PRCSY,T,T0,T1,T2,T4,T5,TX1,X,X1,Y,Z0
  1. L +^PRCS(410,ODA):1
  1. I $T=0 W !,"File being accessed...please change the transaction number later" G EXIT
  1. S ONODE0=^PRCS(410,ODA,0) ; node 0 string of txn to be replaced
  1. S T2=OTNUM ;T2 is needed in PRCSUT call later
  1. S T5=$P(ONODE0,"^",10) ; substation
  1. S T4=$P(ONODE0,"^",2) ; txn type of transaction to be replaced
  1. S PRC("SITE")=$P(OTNUM,"-"),PRC("CP")=CURFCP
  1. S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+PRC("CP"),1)
  1. S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(CURFCP," ")
  1. S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(CURFCP," ")
  1. D EN1^PRCSUT3 ; generate new name for txn and put in X
  1. G:'$G(X) EXIT
  1. S TX1=X
  1. S (DIC,DIE)="^PRCS(410,"
  1. CK K DA
  1. S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ"
  1. D ^DIC
  1. K DLAYGO
  1. G:Y'>0 EXIT
  1. S DA=+Y
  1. L +^PRCS(410,DA):1 ; Lock new ien
  1. I '$T W !," Cannot create new number...please try again later." G EXIT
  1. ;
  1. ; swap transaction xrefs between iens (kill old, then set reversed)
  1. ; (nodes 'B','B2','B3','AE')
  1. K ^PRCS(410,"B",TX1,DA)
  1. K ^PRCS(410,"B2",$P(TX1,"-",5),DA)
  1. K ^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA)
  1. K ^PRCS(410,"AE",$P(TX1,"-",1,4),DA)
  1. K ^PRCS(410,"B",OTNUM,ODA)
  1. K ^PRCS(410,"B2",$P(OTNUM,"-",5),ODA)
  1. K ^PRCS(410,"B3",$P(OTNUM,"-",2)_"-"_$P(OTNUM,"-",5),ODA)
  1. K ^PRCS(410,"AE",$P(OTNUM,"-",1,4),ODA)
  1. K ^PRCS(410,"RB",$P(ONODE0,U,11)_"-"_$P(OTNUM,"-")_"-"_$P(OTNUM,"-",4)_"-"_$P(OTNUM,"-",2)_"-"_$P(OTNUM,"-",5),ODA)
  1. S ^PRCS(410,"B",OTNUM,DA)=""
  1. S ^PRCS(410,"B2",$P(OTNUM,"-",5),DA)=""
  1. S ^PRCS(410,"B3",$P(OTNUM,"-",2)_"-"_$P(OTNUM,"-",5),DA)=""
  1. S ^PRCS(410,"AE",$P(OTNUM,"-",1,4),DA)=""
  1. S ^PRCS(410,"B",TX1,ODA)=""
  1. S ^PRCS(410,"B2",$P(TX1,"-",5),ODA)=""
  1. S ^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),ODA)=""
  1. S ^PRCS(410,"AE",$P(TX1,"-",1,4),ODA)=""
  1. ;
  1. CK1 ; set old txn name into new ien, new txn nam into old (original) ien
  1. ;
  1. S $P(^PRCS(410,DA,0),"^")=OTNUM
  1. S $P(^PRCS(410,ODA,0),"^")=TX1
  1. S PRC("OCP")=$P(^PRCS(410,ODA,3),U)
  1. ; cancel txn at new ien; force old site & CP info into new ien
  1. S DIE="^PRCS(410,",DR=".5///"_+OTNUM_";S X=X;15///"_$$EXPANDCP(+OTNUM,OCP)
  1. S DR=DR_";60///Transaction "_OTNUM_" replaced by trans. "_TX1
  1. S DR=DR_";450///C" ;put cancel flag in Running Bal status
  1. D ^DIE
  1. I T5'="" S $P(^PRCS(410,DA,0),U,10)=T5 ; save substation in new ien
  1. S $P(^PRCS(410,DA,0),U,2)="CA" ; cancel txn at new ien
  1. D ERS410^PRC0G(DA_"^C")
  1. D W5^PRCSEB ; kill flags & x-refs indicating cancel txn is ready to approve
  1. L -^PRCS(410,DA) ; release new ien
  1. I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK
  1. EN S PNW=ODA,PNW(1)=TX1
  1. N A,B
  1. S A=TX1 D RBQTR ; returns B for DR string (RB Qrtr date)
  1. S DA=PNW,DR=B_$S(+OTNUM:"1///"_T4,1:"")_$S(PRC("SITE")'=+OTNUM:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=CURFCP:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"")
  1. D ^DIE
  1. S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
  1. S PRCSAPP=$P(PRC("ACC"),"^",11)
  1. S $P(^PRCS(410,DA,3),"^")=PRC("CP")
  1. S $P(^PRCS(410,DA,3),"^",2)=PRCSAPP
  1. S $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
  1. S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
  1. N MYY S MYY="" D EN2B^PRCSUT3 ; save substation & process with status of entered
  1. D K^PRCSUT1 ; kill 'F', 'F1', x-refs
  1. S (DA,PRCS,PRCSY)=PNW
  1. EN1 K PRCSQ
  1. L -^PRCS(410,ODA)
  1. G EXIT
  1. EXIT I $D(ODA) L -^PRCS(410,ODA)
  1. K PRC("ACC"),PRC("OCP")
  1. Q
  1. ;
  1. RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
  1. S C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B)
  1. S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7)
  1. S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)<D:$P(C,"^",2),1:D)
  1. S B="449////"_B_";"
  1. QUIT
  1. ;
  1. EXPANDCP(STA,CP) ;RETURN FULL CP NAME BASED ON CP NUMBER AND STATION #
  1. N Z
  1. S Z=$P($G(^PRC(420,STA,1,+CP,0)),"^",1)
  1. I (Z="") S Z=CP
  1. Q Z