Released PRC*5.1*156 SEQ #140 Extracted from mail message **KIDS**:PRC*5.1*156^ **INSTALL NAME** PRC*5.1*156 "BLD",6613,0) PRC*5.1*156^IFCAP^0^3110503^y "BLD",6613,1,0) ^^5^5^3110405^^ "BLD",6613,1,1,0) 1. Option 'Convert a Temporary 2237 request to a Purchase Order' results "BLD",6613,1,2,0) in duplicate entries reported in Running Balance report "BLD",6613,1,3,0) "BLD",6613,1,4,0) 2. Entering Purchase Order for succeeding fiscal year results in "BLD",6613,1,5,0) requisition with current fiscal year "BLD",6613,4,0) ^9.64PA^^ "BLD",6613,6.3) 5 "BLD",6613,"ABPKG") n "BLD",6613,"INID") ^y "BLD",6613,"INIT") FIX410^PRCS156P "BLD",6613,"KRN",0) ^9.67PA^779.2^20 "BLD",6613,"KRN",.4,0) .4 "BLD",6613,"KRN",.401,0) .401 "BLD",6613,"KRN",.402,0) .402 "BLD",6613,"KRN",.403,0) .403 "BLD",6613,"KRN",.5,0) .5 "BLD",6613,"KRN",.84,0) .84 "BLD",6613,"KRN",3.6,0) 3.6 "BLD",6613,"KRN",3.8,0) 3.8 "BLD",6613,"KRN",9.2,0) 9.2 "BLD",6613,"KRN",9.8,0) 9.8 "BLD",6613,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",6613,"KRN",9.8,"NM",1,0) PRCHCON1^^0^B24300474 "BLD",6613,"KRN",9.8,"NM",2,0) PRCOEDC^^0^B2323134 "BLD",6613,"KRN",9.8,"NM",3,0) PRCS156P^^0^B2880057 "BLD",6613,"KRN",9.8,"NM","B","PRCHCON1",1) "BLD",6613,"KRN",9.8,"NM","B","PRCOEDC",2) "BLD",6613,"KRN",9.8,"NM","B","PRCS156P",3) "BLD",6613,"KRN",19,0) 19 "BLD",6613,"KRN",19.1,0) 19.1 "BLD",6613,"KRN",101,0) 101 "BLD",6613,"KRN",409.61,0) 409.61 "BLD",6613,"KRN",771,0) 771 "BLD",6613,"KRN",779.2,0) 779.2 "BLD",6613,"KRN",870,0) 870 "BLD",6613,"KRN",8989.51,0) 8989.51 "BLD",6613,"KRN",8989.52,0) 8989.52 "BLD",6613,"KRN",8994,0) 8994 "BLD",6613,"KRN","B",.4,.4) "BLD",6613,"KRN","B",.401,.401) "BLD",6613,"KRN","B",.402,.402) "BLD",6613,"KRN","B",.403,.403) "BLD",6613,"KRN","B",.5,.5) "BLD",6613,"KRN","B",.84,.84) "BLD",6613,"KRN","B",3.6,3.6) "BLD",6613,"KRN","B",3.8,3.8) "BLD",6613,"KRN","B",9.2,9.2) "BLD",6613,"KRN","B",9.8,9.8) "BLD",6613,"KRN","B",19,19) "BLD",6613,"KRN","B",19.1,19.1) "BLD",6613,"KRN","B",101,101) "BLD",6613,"KRN","B",409.61,409.61) "BLD",6613,"KRN","B",771,771) "BLD",6613,"KRN","B",779.2,779.2) "BLD",6613,"KRN","B",870,870) "BLD",6613,"KRN","B",8989.51,8989.51) "BLD",6613,"KRN","B",8989.52,8989.52) "BLD",6613,"KRN","B",8994,8994) "BLD",6613,"QDEF") ^^^^^^^^^^YES "BLD",6613,"QUES",0) ^9.62^^ "BLD",6613,"REQB",0) ^9.611^1^1 "BLD",6613,"REQB",1,0) PRC*5.1*108^2 "BLD",6613,"REQB","B","PRC*5.1*108",1) "INIT") FIX410^PRCS156P "MBREQ") 0 "PKG",455,-1) 1^1 "PKG",455,0) IFCAP^PRC^IFCAP System Files "PKG",455,20,0) ^9.402P^^ "PKG",455,22,0) ^9.49I^1^1 "PKG",455,22,1,0) 5.1^3001012^3001019^68 "PKG",455,22,1,"PAH",1,0) 156^3110503 "PKG",455,22,1,"PAH",1,1,0) ^^5^5^3110503 "PKG",455,22,1,"PAH",1,1,1,0) 1. Option 'Convert a Temporary 2237 request to a Purchase Order' results "PKG",455,22,1,"PAH",1,1,2,0) in duplicate entries reported in Running Balance report "PKG",455,22,1,"PAH",1,1,3,0) "PKG",455,22,1,"PAH",1,1,4,0) 2. Entering Purchase Order for succeeding fiscal year results in "PKG",455,22,1,"PAH",1,1,5,0) requisition with current fiscal year "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","PRCHCON1") 0^1^B24300474^B22950686 "RTN","PRCHCON1",1,0) PRCHCON1 ;WISC/KMB/DL/DXH - CONV. TEMP 2237 TO PC ORDER ;7.29.99 "RTN","PRCHCON1",2,0) V ;;5.1;IFCAP;**108,156**;Oct 20, 2000;Build 5 "RTN","PRCHCON1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHCON1",4,0) I '$D(^PRC(440.5,"C",DUZ)) W !!,"You are not authorized to use this option." Q "RTN","PRCHCON1",5,0) START ; get transaction number, convert to regular 2237 "RTN","PRCHCON1",6,0) N PRC,Y,PRCSIP,PRCSQ,ODA,PNW,TRY,TX1,T1,T2,T3,T4,PRCSY,PRCSDIC,PRCSAPP "RTN","PRCHCON1",7,0) N PRCHCV,PRCHCPD,PRCHQTDT "RTN","PRCHCON1",8,0) I $G(QUIT)'="" K QUIT Q "RTN","PRCHCON1",9,0) K PRC("SITE") W @IOF D EN3F^PRCSUT(1) G W5:'$D(PRC("SITE")) S:Y<0 QUIT=1 Q:Y<0 "RTN","PRCHCON1",10,0) D START1 G START "RTN","PRCHCON1",11,0) START1 ; "RTN","PRCHCON1",12,0) W !!,"Select the existing transaction number to be converted",! "RTN","PRCHCON1",13,0) ; don't select an order which is signed, or attached to PC already "RTN","PRCHCON1",14,0) S DIC="^PRCS(410,",DIC(0)="AEFMQ" "RTN","PRCHCON1",15,0) S DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,12)'=""A"",$D(^(3)),+$P(^(3),U)=+PRC(""CP""),$P($G(^(4)),U,5)=""""" "RTN","PRCHCON1",16,0) D ^DIC S:Y<0 QUIT=1 Q:Y<0 S (ODA,DA)=+Y,PRCSDIC=DIC "RTN","PRCHCON1",17,0) S PRCHQTDT=$P($G(^PRCS(410,ODA,0)),U,11) "RTN","PRCHCON1",18,0) I $P($G(^PRCS(410,DA,3)),U,4)="" W !,"This transaction has no entry in the Vendor File.",!,"Please edit this transaction's vendor before converting this order." H 4 Q "RTN","PRCHCON1",19,0) I $P($G(^PRCS(410,DA,4)),U)>3000 W !,"The dollar amount for this transaction exceeds the $3000 purchase card cutoff." H 4 Q "RTN","PRCHCON1",20,0) D W1^PRCSEB0 Q:%<0 S DIC=PRCSDIC "RTN","PRCHCON1",21,0) L +^PRCS(410,DA):15 G:$T=0 START S T1=ODA,T2=^PRCS(410,DA,0),T4=$P(T2,"^",2),T2=$P(T2,"^"),T3=$P(^(3),"^") "RTN","PRCHCON1",22,0) N REM,REM1 S REM=DA,REM1=+$P(PRC("CP")," ") "RTN","PRCHCON1",23,0) L -^PRCS(410,DA) K DA,DIC,Y "RTN","PRCHCON1",24,0) W !!,"Enter the information for the new transaction number",! "RTN","PRCHCON1",25,0) D EN^PRCSUT3 Q:'$D(PRC("QTR")) Q:'$D(PRC("CP")) "RTN","PRCHCON1",26,0) S TX1=X,PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3) I PRC("CP")'=T3,PRCSAPP["_" D PRCFY Q:PRCSAPP["_" "RTN","PRCHCON1",27,0) S X=TX1 D EN1^PRCSUT3 Q:'X S TX1=X,(DIC,DIE)="^PRCS(410," "RTN","PRCHCON1",28,0) CK G:'+T2 CK1 K DA S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO Q:Y'>0 S DA=+Y "RTN","PRCHCON1",29,0) K ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$P(TX1,"-",5),DA),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA),^PRCS(410,"AE",$P(TX1,"-",1,4),DA) "RTN","PRCHCON1",30,0) K ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$P(T2,"-",5),T1),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),T1),^PRCS(410,"AE",$P(T2,"-",1,4),T1) "RTN","PRCHCON1",31,0) ;Patch PRC*5.1*156 insures the running balance ('RB') index is killed for temp 2237 "RTN","PRCHCON1",32,0) I +PRCHQTDT>0 K ^PRCS(410,"RB",PRCHQTDT_"-"_$P(T2,"-")_"-"_$P(T2,"-",4)_"-"_$P(T2,"-",2)_"-"_$P(T2,"-",5),ODA) "RTN","PRCHCON1",33,0) K PRCHQTDT "RTN","PRCHCON1",34,0) S $P(^PRCS(410,DA,0),U)=T2 S (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$P(T2,"-",5),DA),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),DA),^PRCS(410,"AE",$P(T2,"-",1,4),DA))="" "RTN","PRCHCON1",35,0) CK1 S $P(^PRCS(410,T1,0),U)=TX1 S (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$P(TX1,"-",5),T1),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),T1),^PRCS(410,"AE",$P(TX1,"-",1,4),T1))="" "RTN","PRCHCON1",36,0) S $P(^PRCS(410,T1,6),"^",4)="" K ^PRCS(410,"K",REM1,REM) "RTN","PRCHCON1",37,0) I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE G EN "RTN","PRCHCON1",38,0) S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3_";60///Transaction "_T2_" replaced by trans. "_TX1 "RTN","PRCHCON1",39,0) D ^DIE S $P(^PRCS(410,DA,0),U,2)="CA" D ERS410^PRC0G(DA_"^C"),W5^PRCSEB W !,"Old transaction "_T2_" is now cancelled.",! "RTN","PRCHCON1",40,0) I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK "RTN","PRCHCON1",41,0) EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,! S PNW=ODA,PNW(1)=TX1 "RTN","PRCHCON1",42,0) S TRY=0 "RTN","PRCHCON1",43,0) RETRY ; "RTN","PRCHCON1",44,0) S TRY=TRY+1 Q:TRY>3 "RTN","PRCHCON1",45,0) N A,B S DA=PNW L +^PRCS(410,DA):15 G:$T=0 RETRY "RTN","PRCHCON1",46,0) S DA=PNW "RTN","PRCHCON1",47,0) S A=TX1 D RBQTR "RTN","PRCHCON1",48,0) S DA=PNW,DR=B_$S(+T2:"1///"_T4,1:"")_$S(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"") "RTN","PRCHCON1",49,0) D ^DIE S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")) "RTN","PRCHCON1",50,0) S PRCSAPP=$P(PRC("ACC"),"^",11),$P(^PRCS(410,DA,3),U)=PRC("CP"),$P(^(3),"^",2)=PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3) "RTN","PRCHCON1",51,0) S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7) "RTN","PRCHCON1",52,0) N MYY S MYY="" D EN2B^PRCSUT3 "RTN","PRCHCON1",53,0) D K^PRCSUT1 K T1(1) "RTN","PRCHCON1",54,0) L -^PRCS(410,DA) "RTN","PRCHCON1",55,0) D ^PRCHCON2 QUIT "RTN","PRCHCON1",56,0) ;;;;;;;;;;;;;;;; "RTN","PRCHCON1",57,0) PRCFY I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(X,2,3) S:$E(X,4,5)>9 PRC("FY")=$E(100+PRC("FY")+1,2,3) "RTN","PRCHCON1",58,0) S A=PRCSAPP I A["_/_" D FY2 G KILL "RTN","PRCHCON1",59,0) I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2) "RTN","PRCHCON1",60,0) KILL K %DT,A,B,RES,X Q "RTN","PRCHCON1",61,0) FY2 ; two year appropriation "RTN","PRCHCON1",62,0) W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21 I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2 "RTN","PRCHCON1",63,0) FY21 S:'RES RES=PRC("FY") S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3) Q "RTN","PRCHCON1",64,0) W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 "RTN","PRCHCON1",65,0) Q "RTN","PRCHCON1",66,0) RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I")),C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B) "RTN","PRCHCON1",67,0) S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7) "RTN","PRCHCON1",68,0) S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)0 S RECORD=$G(^PRC(442,VAR1,13,SERVICE,0)) I RECORD]"" S REQUEST=$P(RECORD,U,9) Q:REQUEST=3 "RTN","PRCOEDC",7,0) S PRC("SITE")=$P($P(A,U),"-"),YR=$E(DT,2,3),MO=$E(DT,4,5) "RTN","PRCOEDC",8,0) ;Patch PRC*5.1*156, ONLY calculate PRC("FY") if not numeric "RTN","PRCOEDC",9,0) I +PRC("FY")=0 D "RTN","PRCOEDC",10,0) . S PRC("FY")=$E(100+$S(+MO>9:YR+1,1:YR),2,3) "RTN","PRCOEDC",11,0) S A1=$G(^PRC(442,VAR1,1)) S:A1="" VAR2="ERROR" W:A1="" !,"NPO1 Node 1 missing in record." Q:A1="" Q:$P(A1,U,7)=1 "RTN","PRCOEDC",12,0) D HE^PRCOEC3(VAR1,.VAR2) "RTN","PRCOEDC",13,0) D BI^PRCOEC1(A,VAR1,.VAR2) "RTN","PRCOEDC",14,0) D VE^PRCOEC1(A1,.VAR2) "RTN","PRCOEDC",15,0) D ST^PRCOEC1(A,A1,VAR1,.VAR2) "RTN","PRCOEDC",16,0) D MI^PRCOEC3(VAR1,.VAR2) "RTN","PRCOEDC",17,0) D AC^PRCOEC1(A1,VAR1,.VAR2) "RTN","PRCOEDC",18,0) D IT^PRCOEC2(VAR1,.VAR2) "RTN","PRCOEDC",19,0) Q "RTN","PRCS156P") 0^3^B2880057^n/a "RTN","PRCS156P",1,0) PRCS156P ;VMP/RB - FIX XREF 'RB' FOR DUPLCATE ENTRIES #410 ;12/09/10 "RTN","PRCS156P",2,0) ;;5.1;IFCAP;**156**;Dec 9, 2010;Build 5 "RTN","PRCS156P",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCS156P",4,0) ;; "RTN","PRCS156P",5,0) Q "RTN","PRCS156P",6,0) FIX410 ; "RTN","PRCS156P",7,0) ;1. Post install to delete duplicate entries in x-rec 'RB' caused when "RTN","PRCS156P",8,0) ; using option [PRCH CONV TEMP]. "RTN","PRCS156P",9,0) ; "RTN","PRCS156P",10,0) Q:$D(^XTMP("PRCS156P")) "RTN","PRCS156P",11,0) BUILD K ^XTMP("PRCS156P") D NOW^%DTC S RMSTART=%,TT=0 "RTN","PRCS156P",12,0) S ^XTMP("PRCS156P","START COMPILE")=RMSTART "RTN","PRCS156P",13,0) S ^XTMP("PRCS156P","END COMPILE")="RUNNING" "RTN","PRCS156P",14,0) S ^XTMP("PRCS156P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART "RTN","PRCS156P",15,0) 0 ;FIND DUPLICATE ENTRIES IN ^PRC(410,"RB") INDEX "RTN","PRCS156P",16,0) S REQNO="",IEN=0,U="^",DSH="-" "RTN","PRCS156P",17,0) 1 S REQNO=$O(^PRCS(410,"RB",REQNO)) G EXIT:REQNO=""!(REQNO]"@") "RTN","PRCS156P",18,0) 2 S IEN=$O(^PRCS(410,"RB",REQNO,IEN)) G 1:IEN="" "RTN","PRCS156P",19,0) ;AUDIT 'RB' X-REF "RTN","PRCS156P",20,0) S R0=$G(^PRCS(410,IEN,0)) I R0="" S WDS="MISSING 0 NODE" G 3 "RTN","PRCS156P",21,0) S R0REQ=$P(R0,U),QTRDT=$P(R0,U,11) G 2:QTRDT'>0 "RTN","PRCS156P",22,0) S BREQ=QTRDT_DSH_$P(R0REQ,DSH)_DSH_$P(R0REQ,DSH,4)_DSH_$P(R0REQ,DSH,2)_DSH_$P(R0REQ,DSH,5) "RTN","PRCS156P",23,0) I REQNO=BREQ G 2 "RTN","PRCS156P",24,0) S WDS="DUPLICATE RB" "RTN","PRCS156P",25,0) 3 S ^XTMP("PRCS156P",410,REQNO,IEN,0)=R0_";"_WDS,TT=TT+1 "RTN","PRCS156P",26,0) K ^PRCS(410,"RB",REQNO,IEN) "RTN","PRCS156P",27,0) G 2 "RTN","PRCS156P",28,0) EXIT ; "RTN","PRCS156P",29,0) D NOW^%DTC S RMEND=% "RTN","PRCS156P",30,0) S ^XTMP("PRCS156P","END COMPILE")=RMEND_U_TT "RTN","PRCS156P",31,0) W !!,"NUMBER IEN 'RB' MISMATCHES: ",TT "RTN","PRCS156P",32,0) K RMEND,RMSTART,%,IEN,R0,REQNO,RBXREF,QTRDT,BREQ,DSH,R0REQ,WDS,TT "RTN","PRCS156P",33,0) Q "VER") 8.0^22.0 "BLD",6613,6) ^140 **END** **END**