EMERGENCY Released PRC*5.1*204 SEQ #179 Extracted from mail message **KIDS**:PRC*5.1*204^ **INSTALL NAME** PRC*5.1*204 "BLD",10924,0) PRC*5.1*204^IFCAP^0^3180305^y "BLD",10924,1,0) ^^15^15^3180226^ "BLD",10924,1,1,0) Resolves four issues: "BLD",10924,1,2,0) "BLD",10924,1,3,0) 1) When a user enters a temporary transaction, exits out of the session "BLD",10924,1,4,0) and then tries to edit that request there will be an undefined error. "BLD",10924,1,5,0) "BLD",10924,1,6,0) 2) If a user exits while creating a 2237, then edits that same 2237, but "BLD",10924,1,7,0) times out at the field "DATE OF REQUEST" an error will occur. "BLD",10924,1,8,0) "BLD",10924,1,9,0) 3) An error will occur if a temporary transaction is edited in the 2237. "BLD",10924,1,10,0) "BLD",10924,1,11,0) 4) When entering a new 2237 if the user "jumps" at the "PRIORITY OF "BLD",10924,1,12,0) REQUEST" field to the "COMMENTS" field then exits an error occurs. "BLD",10924,1,13,0) "BLD",10924,1,14,0) 5) If a fund has a multi-approriation the beginning budget fiscal year "BLD",10924,1,15,0) may not match the fiscal year. "BLD",10924,4,0) ^9.64PA^^ "BLD",10924,6.3) 14 "BLD",10924,"ABPKG") n "BLD",10924,"KRN",0) ^9.67PA^779.2^20 "BLD",10924,"KRN",.4,0) .4 "BLD",10924,"KRN",.401,0) .401 "BLD",10924,"KRN",.402,0) .402 "BLD",10924,"KRN",.403,0) .403 "BLD",10924,"KRN",.5,0) .5 "BLD",10924,"KRN",.84,0) .84 "BLD",10924,"KRN",3.6,0) 3.6 "BLD",10924,"KRN",3.8,0) 3.8 "BLD",10924,"KRN",9.2,0) 9.2 "BLD",10924,"KRN",9.8,0) 9.8 "BLD",10924,"KRN",9.8,"NM",0) ^9.68A^7^6 "BLD",10924,"KRN",9.8,"NM",2,0) PRCSEA^^0^B93389276 "BLD",10924,"KRN",9.8,"NM",3,0) PRCSEB0^^0^B29218782 "BLD",10924,"KRN",9.8,"NM",4,0) PRCSEB^^0^B30999928 "BLD",10924,"KRN",9.8,"NM",5,0) PRCSEA1^^0^B16584277 "BLD",10924,"KRN",9.8,"NM",6,0) PRCEN^^0^B58083507 "BLD",10924,"KRN",9.8,"NM",7,0) PRCSUT^^0^B55616855 "BLD",10924,"KRN",9.8,"NM","B","PRCEN",6) "BLD",10924,"KRN",9.8,"NM","B","PRCSEA",2) "BLD",10924,"KRN",9.8,"NM","B","PRCSEA1",5) "BLD",10924,"KRN",9.8,"NM","B","PRCSEB",4) "BLD",10924,"KRN",9.8,"NM","B","PRCSEB0",3) "BLD",10924,"KRN",9.8,"NM","B","PRCSUT",7) "BLD",10924,"KRN",19,0) 19 "BLD",10924,"KRN",19,"NM",0) ^9.68A^^0 "BLD",10924,"KRN",19.1,0) 19.1 "BLD",10924,"KRN",101,0) 101 "BLD",10924,"KRN",409.61,0) 409.61 "BLD",10924,"KRN",771,0) 771 "BLD",10924,"KRN",779.2,0) 779.2 "BLD",10924,"KRN",870,0) 870 "BLD",10924,"KRN",8989.51,0) 8989.51 "BLD",10924,"KRN",8989.52,0) 8989.52 "BLD",10924,"KRN",8994,0) 8994 "BLD",10924,"KRN","B",.4,.4) "BLD",10924,"KRN","B",.401,.401) "BLD",10924,"KRN","B",.402,.402) "BLD",10924,"KRN","B",.403,.403) "BLD",10924,"KRN","B",.5,.5) "BLD",10924,"KRN","B",.84,.84) "BLD",10924,"KRN","B",3.6,3.6) "BLD",10924,"KRN","B",3.8,3.8) "BLD",10924,"KRN","B",9.2,9.2) "BLD",10924,"KRN","B",9.8,9.8) "BLD",10924,"KRN","B",19,19) "BLD",10924,"KRN","B",19.1,19.1) "BLD",10924,"KRN","B",101,101) "BLD",10924,"KRN","B",409.61,409.61) "BLD",10924,"KRN","B",771,771) "BLD",10924,"KRN","B",779.2,779.2) "BLD",10924,"KRN","B",870,870) "BLD",10924,"KRN","B",8989.51,8989.51) "BLD",10924,"KRN","B",8989.52,8989.52) "BLD",10924,"KRN","B",8994,8994) "BLD",10924,"QDEF") ^^^^^^^^^^YES "BLD",10924,"QUES",0) ^9.62^^ "BLD",10924,"REQB",0) ^9.611^2^2 "BLD",10924,"REQB",1,0) PRC*5.1*196^2 "BLD",10924,"REQB",2,0) PRC*5.1*93^2 "BLD",10924,"REQB","B","PRC*5.1*196",1) "BLD",10924,"REQB","B","PRC*5.1*93",2) "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 "PKG",455,22,1,"PAH",1,0) 204^3180305 "PKG",455,22,1,"PAH",1,1,0) ^^15^15^3180305 "PKG",455,22,1,"PAH",1,1,1,0) Resolves four issues: "PKG",455,22,1,"PAH",1,1,2,0) "PKG",455,22,1,"PAH",1,1,3,0) 1) When a user enters a temporary transaction, exits out of the session "PKG",455,22,1,"PAH",1,1,4,0) and then tries to edit that request there will be an undefined error. "PKG",455,22,1,"PAH",1,1,5,0) "PKG",455,22,1,"PAH",1,1,6,0) 2) If a user exits while creating a 2237, then edits that same 2237, but "PKG",455,22,1,"PAH",1,1,7,0) times out at the field "DATE OF REQUEST" an error will occur. "PKG",455,22,1,"PAH",1,1,8,0) "PKG",455,22,1,"PAH",1,1,9,0) 3) An error will occur if a temporary transaction is edited in the 2237. "PKG",455,22,1,"PAH",1,1,10,0) "PKG",455,22,1,"PAH",1,1,11,0) 4) When entering a new 2237 if the user "jumps" at the "PRIORITY OF "PKG",455,22,1,"PAH",1,1,12,0) REQUEST" field to the "COMMENTS" field then exits an error occurs. "PKG",455,22,1,"PAH",1,1,13,0) "PKG",455,22,1,"PAH",1,1,14,0) 5) If a fund has a multi-approriation the beginning budget fiscal year "PKG",455,22,1,"PAH",1,1,15,0) may not match the 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") 6 "RTN","PRCEN") 0^6^B58083507^B57712163 "RTN","PRCEN",1,0) PRCEN ;WISC/CLH - ENTER/EDIT 1358 ;9/2/2010 "RTN","PRCEN",2,0) V ;;5.1;IFCAP;**23,148,150,196,204**;Oct 20, 2000;Build 14 "RTN","PRCEN",3,0) ;Per VA Directive 6402, this routine should not be modified. "RTN","PRCEN",4,0) ; "RTN","PRCEN",5,0) ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410 "RTN","PRCEN",6,0) ;kill call since DIK call does not handle descending file logic "RTN","PRCEN",7,0) ; "RTN","PRCEN",8,0) ;PRC*5.1*196 Check Committed Date for 1358 against FY requested "RTN","PRCEN",9,0) ; to insure date is within the FY range. "RTN","PRCEN",10,0) ; "RTN","PRCEN",11,0) EN ;new 1358 request "RTN","PRCEN",12,0) N PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN "RTN","PRCEN",13,0) N PRCST,PRCST1,PRCSTT,PRC410,PRCUA,PRCAUTH,PRCAUTHS,PRCQ,PRCVEN,PRCONT "RTN","PRCEN",14,0) EN0 K PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN "RTN","PRCEN",15,0) K PRCST,PRCST1,PRCSTT,PRCAED,PRC410,PRCUA,PRCAUTHS "RTN","PRCEN",16,0) D EN^PRCSUT I '$D(PRC("SITE")) W !!,"You are not an authorized control point user.",!,"Contact your control point official." H 3 Q "RTN","PRCEN",17,0) Q:'$D(PRC("QTR"))!(Y<0) "RTN","PRCEN",18,0) ; "RTN","PRCEN",19,0) ; warn CP official, allow to quit "RTN","PRCEN",20,0) Q:$$Q1358(PRC("SITE"),PRC("CP")) "RTN","PRCEN",21,0) ; "RTN","PRCEN",22,0) ; ask for 1358 Authority (need to preserve variables) "RTN","PRCEN",23,0) S PRCQ=0 D "RTN","PRCEN",24,0) . N X,Y,DTOUT,DUOUT,DIC "RTN","PRCEN",25,0) . S DIC="^PRCS(410.9,",DIC(0)="AEMQ",DIC("S")="I Y<100,('$P(^(0),U,4)!($P(^(0),U,4)>DT))",DIC("A")="Select AUTHORITY OF REQUEST: " D ^DIC S PRCAUTH=+Y I Y<1 S PRCQ=1 Q "RTN","PRCEN",26,0) . I $D(^PRCS(410.9,"AC",PRCAUTH)) S DIC("S")="I $P(^(0),U,3)=PRCAUTH,('$P(^(0),U,4)!($P(^(0),U,4)>DT))",DIC("A")="Select SUB-AUTHORITY OF REQUEST: " D ^DIC S PRCAUTHS=+Y I Y<1 S PRCQ=1 "RTN","PRCEN",27,0) Q:PRCQ "RTN","PRCEN",28,0) D EN1^PRCSUT3 Q:'X "RTN","PRCEN",29,0) S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 W !!,"This transaction is assigned Transaction number: ",X "RTN","PRCEN",30,0) S PRC410=DA "RTN","PRCEN",31,0) D G:'$D(DA) EN0 "RTN","PRCEN",32,0) . L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) "RTN","PRCEN",33,0) . E D EN^DDIOL("Transaction is being accessed by another user!") K DA "RTN","PRCEN",34,0) . Q "RTN","PRCEN",35,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1 "RTN","PRCEN",36,0) S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:"")_";19////^S X=PRCAUTH"_$S($G(PRCAUTHS):";19.1////^S X=PRCAUTHS",1:""),X4=1 D ^DIE "RTN","PRCEN",37,0) S PRCAED=1,PRCUA="" "RTN","PRCEN",38,0) ; define if fields need to be required or not "RTN","PRCEN",39,0) S PRCVEN=^PRCS(410.9,$S($G(PRCAUTHS):PRCAUTHS,1:PRCAUTH),0),PRCONT=$P(PRCVEN,"^",6),PRCVEN=$P(PRCVEN,"^",5) "RTN","PRCEN",40,0) S DR="[PRCE NEW 1358]" D ^DIE "RTN","PRCEN",41,0) I $D(Y)#10 S PRCUA=1 D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No") I Y=1 D "RTN","PRCEN",42,0) . S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150 "RTN","PRCEN",43,0) . D DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA) S:X=1 PRCAED=-1 "RTN","PRCEN",44,0) . I X=1 S $P(^PRCS(410,0),"^",3)=PRCIENCT ;PRC*5.1*150 "RTN","PRCEN",45,0) . K PRCIENCT ;PRC*5.1*150 "RTN","PRCEN",46,0) . D EN^DDIOL(" **** NEW ENTRY IS "_$S(X=1:"",1:"NOT ")_"DELETED ****") "RTN","PRCEN",47,0) . QUIT "RTN","PRCEN",48,0) I PRCAED'=-1 D "RTN","PRCEN",49,0) . D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED "RTN","PRCEN",50,0) . K PRCSF "RTN","PRCEN",51,0) . D W1^PRCSEB "RTN","PRCEN",52,0) . I $D(PRCS2),+^PRCS(410,DA,0),'PRCUA,$$CHECK(PRC410) D "RTN","PRCEN",53,0) .. D W6^PRCSEB "RTN","PRCEN",54,0) .. Q "RTN","PRCEN",55,0) . Q "RTN","PRCEN",56,0) L -^PRCS(410,PRC410) "RTN","PRCEN",57,0) S DIR("B")="NO",DIR(0)="Y",DIR("A")="Do you want to enter another NEW request" D ^DIR Q:'Y!($D(DIRUT)) "RTN","PRCEN",58,0) W !! K PRCS2 G EN0 "RTN","PRCEN",59,0) Q "RTN","PRCEN",60,0) ED ;edit 1358 "RTN","PRCEN",61,0) N PRC410,PRC442,PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC "RTN","PRCEN",62,0) N DR,DIR,PRCSY,PRCSL,X,X1,T,T1,Z,PRCSDA,DTOUT,PRCVEN,PRCONT "RTN","PRCEN",63,0) ED0 K PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC,DR,DIR,PRCSY "RTN","PRCEN",64,0) K PRCSL,X,X1,T,T1,Z,PRCSDA "RTN","PRCEN",65,0) D EN3^PRCSUT I '$D(PRC("SITE")) W !!,"You are not an authorized control point user.",!,"Contact your control point official." H 3 Q "RTN","PRCEN",66,0) Q:Y<0 "RTN","PRCEN",67,0) S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=1,+$P(^(0),U)'=0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCEN",68,0) D ^PRCSDIC Q:Y<0 K DIC("S") S (DA,PRCSY,PRCSDA)=+Y ;D LOCK^PRCSUT G ED0:PRCSL=0 "RTN","PRCEN",69,0) D G:'$D(DA) ED0 "RTN","PRCEN",70,0) . L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) "RTN","PRCEN",71,0) . E D EN^DDIOL("Another user is editing this transaction! Try Later") K DA "RTN","PRCEN",72,0) . Q "RTN","PRCEN",73,0) D NODE^PRCS58OB(DA,.TRNODE) S PRC410=DA "RTN","PRCEN",74,0) S X=^PRCS(410,DA,0) S:+X PRC("FY")=$P(X,"-",2),PRC("QTR")=+$P(X,"-",3),TT=$P(X,"^",2) "RTN","PRCEN",75,0) D EN2B^PRCSUT3 "RTN","PRCEN",76,0) I $D(^PRCS(410,DA,7)),$P(^(7),U,6)]"" D SCPE G OUT ;if obligated "RTN","PRCEN",77,0) ED1 I TT="CA" S DR="[PRCSENCT]",DIE=DIC D ^DIE S DA=PRCSY L -^PRCS(410,PRCSY) G ED0 "RTN","PRCEN",78,0) ; warn CP offical and allow to quit "RTN","PRCEN",79,0) I $$Q1358(PRC("SITE"),PRC("CP"),$G(TT),$G(DA)) L -^PRCS(410,PRCSY) G ED0 "RTN","PRCEN",80,0) ; "RTN","PRCEN",81,0) ; patch 23, fix problem of not able to exit with "^" "RTN","PRCEN",82,0) I TT'="O" S DR="[PRCSENA 1358]" S DIE=DIC D ^DIE L:$D(Y)>9 -^PRCS(410,PRCSY) G:$D(Y)>9 ED0 S DA=PRCSY "RTN","PRCEN",83,0) I TT="A" S PRC442=$P($G(^PRCS(410,PRC410,10)),U,3) I PRC442 G:$$EN1^PRCE0A(PRC410,PRC442,1) ED1 "RTN","PRCEN",84,0) I TT="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 ED1 "RTN","PRCEN",85,0) D:TT="A"&($O(^PRCS(410,PRCSY,12,0))) SCPC0^PRCSED "RTN","PRCEN",86,0) I TT="A" D REV D:$$CHECK(PRC410) W6^PRCSEB G OUT "RTN","PRCEN",87,0) ; "RTN","PRCEN",88,0) S DR="[PRCE NEW 1358]" D ^DIE,REV D:$$CHECK(PRC410) W6^PRCSEB "RTN","PRCEN",89,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to edit another request" D ^DIR G OUT:'Y!($D(DIRUT)) "RTN","PRCEN",90,0) L -^PRCS(410,PRCSDA) "RTN","PRCEN",91,0) G ED0 "RTN","PRCEN",92,0) SCPE ;sub control point edit "RTN","PRCEN",93,0) S DR="[PRCSEDS]" D ^DIE "RTN","PRCEN",94,0) REV W !!,"Would you like to review this request" S %=2 D YN^DICN G REV:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q "RTN","PRCEN",95,0) OUT L -^PRCS(410,PRCSDA) Q "RTN","PRCEN",96,0) ; "RTN","PRCEN",97,0) CHECK(PRC410) ; - Check out a 1358 410 entry for required fields "RTN","PRCEN",98,0) N PRCX,PRC0,PRC11,PRCER,PRC3,PRC1 "RTN","PRCEN",99,0) Q:'$G(PRC410) -1 "RTN","PRCEN",100,0) ; "RTN","PRCEN",101,0) ; get data "RTN","PRCEN",102,0) F PRCX=0,1,3,11 S @("PRC"_PRCX)=$G(^PRCS(410,PRC410,PRCX)) "RTN","PRCEN",103,0) S PRCX=$G(^PRCS(410.9,$S(+$P(PRC11,"^",5):+$P(PRC11,"^",5),1:+$P(PRC11,"^",4)),0)) "RTN","PRCEN",104,0) S PRCER=0 "RTN","PRCEN",105,0) ; "RTN","PRCEN",106,0) ; make sure I have a 1358 "RTN","PRCEN",107,0) I $P(PRC0,"^",4)'=1 Q 1 "RTN","PRCEN",108,0) ; "RTN","PRCEN",109,0) ; start checking out data "RTN","PRCEN",110,0) I '$D(^PRCS(410,PRC410,8,1,0)) D CKER("PURPOSE is Missing") "RTN","PRCEN",111,0) ; "RTN","PRCEN",112,0) ; done checking if not an obligation "RTN","PRCEN",113,0) I $P(PRC0,"^",2)'="O" G CKEX "RTN","PRCEN",114,0) ; "RTN","PRCEN",115,0) ; continue checking "RTN","PRCEN",116,0) I '$P(PRC11,"^",4) D CKER("AUTHORITY is Missing") "RTN","PRCEN",117,0) I $P(PRC11,"^",5),'$D(^PRCS(410.9,"AC",$P(PRC11,"^",4),$P(PRC11,"^",5))) D CKER("SUB-AUTHORITY does not correspond to AUTHORITY") "RTN","PRCEN",118,0) I '$P(PRC11,"^",5),$O(^PRCS(410.9,"AC",+$P(PRC11,"^",4),0)) D CKER("SUB-AUTHORITY is Missing") "RTN","PRCEN",119,0) I $P(PRCX,"^",5),'$P(PRC3,"^",4) D CKER("VENDOR is Missing") "RTN","PRCEN",120,0) I $P(PRCX,"^",6),'$L($P(PRC3,"^",10)) D CKER("CONTRACT is Missing") "RTN","PRCEN",121,0) I '$P(PRC1,"^",6) D CKER("Service Start Date is Missing") "RTN","PRCEN",122,0) I '$P(PRC1,"^",7) D CKER("Service End Date is Missing") "RTN","PRCEN",123,0) ; "RTN","PRCEN",124,0) CKEX I PRCER S PRCER=0 F S PRCER=$O(PRCER(PRCER)) Q:'PRCER W !?5,PRCER(PRCER),"!!!" "RTN","PRCEN",125,0) Q $S($O(PRCER(0)):0,1:1) "RTN","PRCEN",126,0) ; "RTN","PRCEN",127,0) CKER(X) ; "RTN","PRCEN",128,0) S PRCER=PRCER+1 "RTN","PRCEN",129,0) S PRCER(PRCER)=X "RTN","PRCEN",130,0) Q "RTN","PRCEN",131,0) ; "RTN","PRCEN",132,0) Q1358(PRCSTA,PRCFCP,PRCTT,PRCDA) ; Quit 1358 Process "RTN","PRCEN",133,0) ; This API warns a control point offical that they will be set as "RTN","PRCEN",134,0) ; the requestor on the 1358 and thus cannot also approve it. "RTN","PRCEN",135,0) ; The API will return 1 (true) if the user decided to quit the "RTN","PRCEN",136,0) ; current process before being set as the requestor. "RTN","PRCEN",137,0) ; "RTN","PRCEN",138,0) ; inputs "RTN","PRCEN",139,0) ; PRCSTA - station number "RTN","PRCEN",140,0) ; PRCFCP - fund control point "RTN","PRCEN",141,0) ; PRCTT - (optional) transaction type, pass "A" for adjustment "RTN","PRCEN",142,0) ; PRCDA - (optional) file 410 ien of 1358 when editing 1358 "RTN","PRCEN",143,0) ; returns boolean value (0 or 1) "RTN","PRCEN",144,0) ; = 0 to proceed with process "RTN","PRCEN",145,0) ; = 1 to quit process "RTN","PRCEN",146,0) ; "RTN","PRCEN",147,0) N RET "RTN","PRCEN",148,0) S RET=0 ; init value to return "RTN","PRCEN",149,0) ; "RTN","PRCEN",150,0) ; if user is control point official for input station and FCP "RTN","PRCEN",151,0) I $G(PRCSTA)]"",$G(PRCFCP)]"",$D(^PRC(420,"A",DUZ,PRCSTA,+PRCFCP,1)) D "RTN","PRCEN",152,0) . N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y "RTN","PRCEN",153,0) . ; "RTN","PRCEN",154,0) . ; don't warn when editing a 1358 if user is already the requestor "RTN","PRCEN",155,0) . I $G(PRCDA),$P($G(^PRCS(410,PRCDA,7)),"^")=DUZ Q "RTN","PRCEN",156,0) . ; "RTN","PRCEN",157,0) . I $G(PRCTT)'="A" D "RTN","PRCEN",158,0) . . W !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358." "RTN","PRCEN",159,0) . . W !,"You will be unable to approve a 1358 on which you are the REQUESTOR due to" "RTN","PRCEN",160,0) . . W !,"segregation of duties." "RTN","PRCEN",161,0) . I $G(PRCTT)="A" D "RTN","PRCEN",162,0) . . W !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358" "RTN","PRCEN",163,0) . . W !,"Adjustment. You will be unable to approve a 1358 Adjustment on which you" "RTN","PRCEN",164,0) . . W !,"are the REQUESTOR due to segregation of duties." "RTN","PRCEN",165,0) . ; "RTN","PRCEN",166,0) . S DIR(0)="Y",DIR("A")="Do you want to proceed (Y/N)",DIR("B")="NO" "RTN","PRCEN",167,0) . D ^DIR K DIR I $D(DIRUT)!'Y S RET=1 "RTN","PRCEN",168,0) . W ! "RTN","PRCEN",169,0) ; "RTN","PRCEN",170,0) Q RET "RTN","PRCEN",171,0) COMCHK ;Check Committed Date to insure it is within the FY/FQ range during option entry for 'NEW 1358' ;PRC*5.1*196 "RTN","PRCEN",172,0) N PRCDT,PRCDT1 "RTN","PRCEN",173,0) I $G(PRCBBMY) S PRCCKERR=0 Q "RTN","PRCEN",174,0) I '$D(PRC("BBFY"))!(+$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!($P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)["X") S PRC("BBFY")=PRC("FY")+2000 "RTN","PRCEN",175,0) S PRCCKERR=0,PRCDT=(PRC("BBFY")-1701)_$P("10:01:04:07",":",PRC("QTR"))_"01",PRCDT1=(PRC("BBFY")-1700)_"0930" "RTN","PRCEN",176,0) I PRCCOMDTPRCDT1) D "RTN","PRCEN",177,0) . S PRCCKERR=1 "RTN","PRCEN",178,0) . W !!," ** Date Committed must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",! "RTN","PRCEN",179,0) Q "RTN","PRCSEA") 0^2^B93389276^B87690038 "RTN","PRCSEA",1,0) PRCSEA ;WISC/SAW/DXH/BM/SC/DAP - CONTROL POINT ACTIVITY EDITS ;5/8/13 15:31 "RTN","PRCSEA",2,0) V ;;5.1;IFCAP;**81,147,150,174,196,204**;Oct 20, 2000;Build 14 "RTN","PRCSEA",3,0) ;Per VA Directive 6402, this routine should not be modified. "RTN","PRCSEA",4,0) ; "RTN","PRCSEA",5,0) ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code "RTN","PRCSEA",6,0) ;to update Audit file (#414.02), and send update message to "RTN","PRCSEA",7,0) ;DynaMed thru a call to rtn PRCVTCA. "RTN","PRCSEA",8,0) ; "RTN","PRCSEA",9,0) ;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx "RTN","PRCSEA",10,0) ;number to be used at all. Previously, the same temp tx # "RTN","PRCSEA",11,0) ;could be used by different users, not same user. "RTN","PRCSEA",12,0) ;Also, Control the node 0 counter for file 410 kill (DIK) "RTN","PRCSEA",13,0) ;since DIK call does not handle descending file logic "RTN","PRCSEA",14,0) ; "RTN","PRCSEA",15,0) ;PRC*5.1*196 Check to move Date Required to Committed Date (MOP: 2-4) "RTN","PRCSEA",16,0) ; to insure a later date is used for FMS document. Also, "RTN","PRCSEA",17,0) ; added date check called from templates PRCSENR&NRS, "RTN","PRCSEA",18,0) ; PRCSEN2237S & PRCSENPRS to insure dates are in same "RTN","PRCSEA",19,0) ; FY/FQ defined. "RTN","PRCSEA",20,0) ; "RTN","PRCSEA",21,0) ENRS ;ENTER REQ "RTN","PRCSEA",22,0) S PRCSK=1,X3="H" "RTN","PRCSEA",23,0) D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197 "RTN","PRCSEA",24,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered "RTN","PRCSEA",25,0) D W6 ; display help on transaction# format "RTN","PRCSEA",26,0) ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="ABELQX",D="H" ;PRC*5.1*150 "RTN","PRCSEA",27,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",28,0) 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 "RTN","PRCSEA",29,0) D ^PRCSDIC ; lookup & preliminary validity checking "RTN","PRCSEA",30,0) K DLAYGO,DIC("A"),DIC("S") "RTN","PRCSEA",31,0) G:Y<0 EXIT "RTN","PRCSEA",32,0) I $P(Y,U,3)'=1 W $C(7)," Must be a new (unique) entry." G ENRS0 ;PRC*5.1*150 "RTN","PRCSEA",33,0) ;*81 Check site parameter to see if issue books are allowed "RTN","PRCSEA",34,0) D CKPRM^PRCSEB "RTN","PRCSEA",35,0) W !!,PRCVY,! "RTN","PRCSEA",36,0) S (PDA,T1,DA)=+Y "RTN","PRCSEA",37,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0 "RTN","PRCSEA",38,0) S T(2)=$P(Y,U,2) "RTN","PRCSEA",39,0) 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) "RTN","PRCSEA",40,0) S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by) "RTN","PRCSEA",41,0) S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default "RTN","PRCSEA",42,0) 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 "RTN","PRCSEA",43,0) S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM "RTN","PRCSEA",44,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1 "RTN","PRCSEA",45,0) TYPE ; "RTN","PRCSEA",46,0) W !!,"This transaction is assigned temporary transaction number: ",T(2) "RTN","PRCSEA",47,0) S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ" "RTN","PRCSEA",48,0) S DIC("S")=PRCVX ; only allow selection of 2237's "RTN","PRCSEA",49,0) D ^DIC "RTN","PRCSEA",50,0) S DA=PDA "RTN","PRCSEA",51,0) ;if user didn't enter a form type, go ask whether to backout and act "RTN","PRCSEA",52,0) ;accordingly: go let them re-enter a form type or exit "RTN","PRCSEA",53,0) I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT "RTN","PRCSEA",54,0) ; "RTN","PRCSEA",55,0) I Y<2 W "??" G TYPE "RTN","PRCSEA",56,0) K PRCVX,PRCVY "RTN","PRCSEA",57,0) S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y,PRCSTYP=X ; form type ;PRC*5.1*196 "RTN","PRCSEA",58,0) ; 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', "RTN","PRCSEA",59,0) ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated. "RTN","PRCSEA",60,0) S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEA",61,0) K PRCSERR ; flag denoting item info is missing "RTN","PRCSEA",62,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",63,0) S PRCSTYP=X ; form type ;PRC*5.1*196 "RTN","PRCSEA",64,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",65,0) EN1 K DTOUT,DUOUT,Y "RTN","PRCSEA",66,0) D ^DIE "RTN","PRCSEA",67,0) S DA=PDA "RTN","PRCSEA",68,0) I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",69,0) 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 "RTN","PRCSEA",70,0) . S PRCOMDT=$S($P($G(^PRCS(410,DA,1)),U,4)'=DT:$P($G(^PRCS(410,DA,1)),U,4),1:DT) "RTN","PRCSEA",71,0) . S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE "RTN","PRCSEA",72,0) . S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204 "RTN","PRCSEA",73,0) D RL^PRCSUT1 ; sets up 'IT' & '10' nodes "RTN","PRCSEA",74,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item') "RTN","PRCSEA",75,0) D DOR ; populate date of request field if it is nil "RTN","PRCSEA",76,0) L -^PRCS(410,DA) "RTN","PRCSEA",77,0) S T="enter" D W5 G EXIT:%'=1 "RTN","PRCSEA",78,0) W !! K PRCS("SUB") "RTN","PRCSEA",79,0) G ENRS "RTN","PRCSEA",80,0) ; "RTN","PRCSEA",81,0) EDRS ;EDIT REQ "RTN","PRCSEA",82,0) ; 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 "RTN","PRCSEA",83,0) ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197 "RTN","PRCSEA",84,0) ; 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 "RTN","PRCSEA",85,0) D W6 ; format doc for txn# "RTN","PRCSEA",86,0) S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H" "RTN","PRCSEA",87,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",88,0) 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 "RTN","PRCSEA",89,0) D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S") "RTN","PRCSEA",90,0) S (PDA,DA,T1)=+Y "RTN","PRCSEA",91,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS "RTN","PRCSEA",92,0) ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option "RTN","PRCSEA",93,0) ; D EN2B^PRCSUT3 "RTN","PRCSEA",94,0) S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5) "RTN","PRCSEA",95,0) S PRC("CP")=$P(^PRCS(410,PDA,3),"^") "RTN","PRCSEA",96,0) ;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed "RTN","PRCSEA",97,0) I '$D(PRC("FY")) D FY^PRCSUT G EX^PRCSUT:PRC("FY")="^" "RTN","PRCSEA",98,0) I '$D(PRC("QTR")) D QT^PRCSUT G EX^PRCSUT:PRC("QTR")="^" "RTN","PRCSEA",99,0) I '$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")) G EX^PRCSUT "RTN","PRCSEA",100,0) I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197 "RTN","PRCSEA",101,0) . N PRCSIP D IP^PRCSUT "RTN","PRCSEA",102,0) . 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 "RTN","PRCSEA",103,0) S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM "RTN","PRCSEA",104,0) S PRCSTYP=X ; form type ;PRC*5.1*196 "RTN","PRCSEA",105,0) ;*81 Check site parameter to see if Issue Books are allowed "RTN","PRCSEA",106,0) D CKPRM "RTN","PRCSEA",107,0) I PRCVD=1 S PRCVZ=1 "RTN","PRCSEA",108,0) I PRCVD'=1 S PRCVZ=0 "RTN","PRCSEA",109,0) W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),! "RTN","PRCSEA",110,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 "RTN","PRCSEA",111,0) ; "RTN","PRCSEA",112,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",113,0) ;P182--Modified next 3 lines to use new templates if supply fund FCP "RTN","PRCSEA",114,0) S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",115,0) ED1 K DTOUT,DUOUT,Y "RTN","PRCSEA",116,0) D ^DIE "RTN","PRCSEA",117,0) S DA=PDA "RTN","PRCSEA",118,0) I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",119,0) 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 "RTN","PRCSEA",120,0) . S PRCOMDT=$S($P(^PRCS(410,DA,1),U,4)'=DT:$P(^PRCS(410,DA,1),U,4),1:DT) "RTN","PRCSEA",121,0) . S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE "RTN","PRCSEA",122,0) . S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204 "RTN","PRCSEA",123,0) D RL^PRCSUT1 "RTN","PRCSEA",124,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1 "RTN","PRCSEA",125,0) K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ "RTN","PRCSEA",126,0) L -^PRCS(410,DA) "RTN","PRCSEA",127,0) S T="edit" D W5 G EXIT:%'=1 "RTN","PRCSEA",128,0) W !! K PRCS("SUB") "RTN","PRCSEA",129,0) G EDRS "RTN","PRCSEA",130,0) ; "RTN","PRCSEA",131,0) CT ;CANCEL A (PERMANENT) TRANS "RTN","PRCSEA",132,0) D EN3^PRCSUT "RTN","PRCSEA",133,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 "RTN","PRCSEA",134,0) S DIC="^PRCS(410,",DIC(0)="AEMQ" "RTN","PRCSEA",135,0) ;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)))" "RTN","PRCSEA",136,0) 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)))" "RTN","PRCSEA",137,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",138,0) D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A") "RTN","PRCSEA",139,0) CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1 "RTN","PRCSEA",140,0) S DA=+Y "RTN","PRCSEA",141,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT "RTN","PRCSEA",142,0) S DIE="^PRCS(410,",DR="104////^S X=DUZ" D ^DIE K DIE,DR "RTN","PRCSEA",143,0) S T=$P(^PRCS(410,DA,0),"^") "RTN","PRCSEA",144,0) I T?1A.E D G EXIT:%'=1 W !! G CT ;PRC*5.1*150 Will DELETE entry if temporary transaction "RTN","PRCSEA",145,0) . S DIK="^PRCS(410,",PRCIENCT=$P(^PRCS(410,0),"^",3)+1 "RTN","PRCSEA",146,0) . D ^DIK "RTN","PRCSEA",147,0) . S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT,DIK "RTN","PRCSEA",148,0) . S T="cancel" D W4 "RTN","PRCSEA",149,0) 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 "RTN","PRCSEA",150,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) "RTN","PRCSEA",151,0) K ZX "RTN","PRCSEA",152,0) I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0 "RTN","PRCSEA",153,0) I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX "RTN","PRCSEA",154,0) 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) "RTN","PRCSEA",155,0) D ERS410^PRC0G(DA_"^C") "RTN","PRCSEA",156,0) W !,"Enter comments for this cancellation",! "RTN","PRCSEA",157,0) S DIE=DIC,DR=60 "RTN","PRCSEA",158,0) D ^DIE "RTN","PRCSEA",159,0) ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM "RTN","PRCSEA",160,0) D EN^PRCVTCA(DA) "RTN","PRCSEA",161,0) L -^PRCS(410,DA) "RTN","PRCSEA",162,0) I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK "RTN","PRCSEA",163,0) S T="cancel" D W4 G EXIT:%'=1 "RTN","PRCSEA",164,0) W !! G CT "RTN","PRCSEA",165,0) ; "RTN","PRCSEA",166,0) DT ;DELETE A (TEMPORARY) TRANS "RTN","PRCSEA",167,0) S X3="H" "RTN","PRCSEA",168,0) D W6 ; format doc for txn# "RTN","PRCSEA",169,0) S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H" "RTN","PRCSEA",170,0) 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)))" "RTN","PRCSEA",171,0) D ^PRCSDIC G EXIT:Y<0 "RTN","PRCSEA",172,0) K DIC("S"),DIC("A") "RTN","PRCSEA",173,0) S DA=+Y "RTN","PRCSEA",174,0) L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT "RTN","PRCSEA",175,0) DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1 "RTN","PRCSEA",176,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",177,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",178,0) ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC "RTN","PRCSEA",179,0) S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150 "RTN","PRCSEA",180,0) S DIK=DIC "RTN","PRCSEA",181,0) W !,"Okay....." "RTN","PRCSEA",182,0) D ^DIK K DIK "RTN","PRCSEA",183,0) S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150 "RTN","PRCSEA",184,0) L -^PRCS(410,DA) "RTN","PRCSEA",185,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",186,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",187,0) ;S $P(^PRCS(410,0),U,3)=PRCSDA "RTN","PRCSEA",188,0) K PRCSDA "RTN","PRCSEA",189,0) W "It's deleted" "RTN","PRCSEA",190,0) S T="delete" D W4 G EXIT:%'=1 "RTN","PRCSEA",191,0) W !! G DT "RTN","PRCSEA",192,0) ; "RTN","PRCSEA",193,0) ; "RTN","PRCSEA",194,0) DOR ; Date of Request "RTN","PRCSEA",195,0) I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q "RTN","PRCSEA",196,0) S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y "RTN","PRCSEA",197,0) Q "RTN","PRCSEA",198,0) FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed "RTN","PRCSEA",199,0) D CKPRM "RTN","PRCSEA",200,0) I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option." "RTN","PRCSEA",201,0) I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option." "RTN","PRCSEA",202,0) W !,PRCVY1,! "RTN","PRCSEA",203,0) W !,"Please enter another form type",! "RTN","PRCSEA",204,0) S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" "RTN","PRCSEA",205,0) S DIC("S")=PRCVX1 "RTN","PRCSEA",206,0) D ^DIC "RTN","PRCSEA",207,0) S:Y=-1 Y=2 "RTN","PRCSEA",208,0) S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y "RTN","PRCSEA",209,0) K DIC,PRCVX1,PRCVY1,PRCVD "RTN","PRCSEA",210,0) Q "RTN","PRCSEA",211,0) ; "RTN","PRCSEA",212,0) ;Allow user the option of re entering a form type. If they decline, "RTN","PRCSEA",213,0) ;kill off the transaction and return 1; else return 0 "RTN","PRCSEA",214,0) BACKOUT(TRNNAME,TRNDA) ; "RTN","PRCSEA",215,0) N DIK,Y,%,DA "RTN","PRCSEA",216,0) W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7) "RTN","PRCSEA",217,0) W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN "RTN","PRCSEA",218,0) I %=0 G BACKOUT "RTN","PRCSEA",219,0) I %=2 Q 0 "RTN","PRCSEA",220,0) S DIK="^PRCS(410,",DA=TRNDA "RTN","PRCSEA",221,0) S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150 "RTN","PRCSEA",222,0) D ^DIK "RTN","PRCSEA",223,0) S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150 "RTN","PRCSEA",224,0) Q 1 "RTN","PRCSEA",225,0) ; "RTN","PRCSEA",226,0) W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT "RTN","PRCSEA",227,0) W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140 "RTN","PRCSEA",228,0) W !!,"This transaction is assigned temporary transaction number: ",X Q "RTN","PRCSEA",229,0) W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q "RTN","PRCSEA",230,0) W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q "RTN","PRCSEA",231,0) W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q "RTN","PRCSEA",232,0) ;*81 Site parameter pull "RTN","PRCSEA",233,0) CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") "RTN","PRCSEA",234,0) Q "RTN","PRCSEA",235,0) ; "RTN","PRCSEA",236,0) 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 "RTN","PRCSEA",237,0) I $D(PRCSERR) K PRCSERR "RTN","PRCSEA",238,0) Q "RTN","PRCSEA1") 0^5^B16584277^B15066543 "RTN","PRCSEA1",1,0) PRCSEA1 ;WISC/KMB/DXH - REQUESTOR ENTER 1358 ;7.26.99 "RTN","PRCSEA1",2,0) V ;;5.1;IFCAP;**150,204**;Oct 20, 2000;Build 14 "RTN","PRCSEA1",3,0) ;Per VA Directive 6402, this routine should not be modified. "RTN","PRCSEA1",4,0) ;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx "RTN","PRCSEA1",5,0) ;number to be used at all. Previously, the same temp tx # "RTN","PRCSEA1",6,0) ;could be used by different users, not same user. "RTN","PRCSEA1",7,0) ; "RTN","PRCSEA1",8,0) EN ; "RTN","PRCSEA1",9,0) N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3 "RTN","PRCSEA1",10,0) K PRCBBMY "RTN","PRCSEA1",11,0) S PRCSK=1,X3="H" "RTN","PRCSEA1",12,0) D EN1F^PRCSUT(1) Q:Y<0 "RTN","PRCSEA1",13,0) D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!") "RTN","PRCSEA1",14,0) D EN^DDIOL(" ") ; blank line "RTN","PRCSEA1",15,0) EN1 ; "RTN","PRCSEA1",16,0) S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="ABELQX",D="H" "RTN","PRCSEA1",17,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA1",18,0) 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 "RTN","PRCSEA1",19,0) D ^PRCSDIC "RTN","PRCSEA1",20,0) K DLAYGO,DIC("A"),DIC("S") "RTN","PRCSEA1",21,0) Q:Y<0 "RTN","PRCSEA1",22,0) I $P(Y,U,3)'=1 D EN^DDIOL("Must be a new entry. ") G EN1 "RTN","PRCSEA1",23,0) L +^PRCS(410,+Y):1 ;CHANGED DA TO +Y IN P182 "RTN","PRCSEA1",24,0) I $T=0 D EN^DDIOL("File being accessed, please try another entry") G EN1 "RTN","PRCSEA1",25,0) S T(2)=$P(Y,U,2) "RTN","PRCSEA1",26,0) D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data, etc. in new ien (nodes 0,3,6,11 of file 410) "RTN","PRCSEA1",27,0) S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by) "RTN","PRCSEA1",28,0) S $P(^PRCS(410,DA,7),"^",1)=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) "RTN","PRCSEA1",29,0) ; commented out by PRC*5*140 - automated flag not implemeted in option, if commented lines are removed, remember to stop newing the PRCS variable "RTN","PRCSEA1",30,0) ; S PRCS="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1 "RTN","PRCSEA1",31,0) S X=T(2) "RTN","PRCSEA1",32,0) D EN^DDIOL("This transaction is assigned temporary transaction number: "_X,"","!!") "RTN","PRCSEA1",33,0) K PRCSERR "RTN","PRCSEA1",34,0) S DIC(0)="AEMQ",DIE=DIC,DIE("NO^")=1 "RTN","PRCSEA1",35,0) S DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1 "RTN","PRCSEA1",36,0) D ^DIE "RTN","PRCSEA1",37,0) S PRCAED=1 ; cannot find where or how PRCAED is used "RTN","PRCSEA1",38,0) S DR="[PRCE NEW 1358S]" "RTN","PRCSEA1",39,0) D ^DIE "RTN","PRCSEA1",40,0) D W1^PRCSEB ; ask 'review?' "RTN","PRCSEA1",41,0) L -^PRCS(410,DA) "RTN","PRCSEA1",42,0) S DIR("B")="NO",DIR(0)="Y" "RTN","PRCSEA1",43,0) S DIR("A")="Do you want to enter another new request" "RTN","PRCSEA1",44,0) D ^DIR Q:'Y!($D(DIRUT)) "RTN","PRCSEA1",45,0) W !! "RTN","PRCSEA1",46,0) ; removed by PRC*5*140 - PRCS2 never set up "RTN","PRCSEA1",47,0) ; K PRCS2 "RTN","PRCSEA1",48,0) G EN1 "RTN","PRCSEA1",49,0) ED ;edit 1358 for requestor "RTN","PRCSEA1",50,0) N PRCAED,DIR,DIRUT,PRCS,PRCSCP,PRCSN,PRCSTT,PRC,X,X1,DIC,DIE,DR,PRCSL,PRCSIP,X3 "RTN","PRCSEA1",51,0) K PRCBBMY "RTN","PRCSEA1",52,0) ED1 ; "RTN","PRCSEA1",53,0) S PRCAED=1,X3=1 ; PRC*5*140 comment - PRCAED used?, X3="H" for all other temp txn options. X3 determines xrefs to search in finding txn name. "RTN","PRCSEA1",54,0) D EN^DDIOL("Enter a 2-16 digit number with a leading alpha, as in 'ABC123'","","!!") "RTN","PRCSEA1",55,0) D EN^DDIOL(" ") "RTN","PRCSEA1",56,0) S DIC="^PRCS(410,",DIC(0)="AEQ",D="H" "RTN","PRCSEA1",57,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA1",58,0) 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 & must be a 1358 "RTN","PRCSEA1",59,0) D ^PRCSDIC ; lookup & prelimiary validity checking "RTN","PRCSEA1",60,0) K DIC("A"),DIC("S") "RTN","PRCSEA1",61,0) Q:Y<0 "RTN","PRCSEA1",62,0) S DA=+Y "RTN","PRCSEA1",63,0) L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...try later") Q "RTN","PRCSEA1",64,0) S DIC=(0)="AEMQ",DIE="^PRCS(410," "RTN","PRCSEA1",65,0) S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5) "RTN","PRCSEA1",66,0) S PRC("CP")=$P(^PRCS(410,DA,3),"^") "RTN","PRCSEA1",67,0) ;PRC*5.1*204 Creates arrays PRC("FY"),PRC("QTR), and PRC("BBFY") if needed "RTN","PRCSEA1",68,0) I '$D(PRC("FY")) D FY^PRCSUT G EX^PRCSUT:PRC("FY")="^" "RTN","PRCSEA1",69,0) I '$D(PRC("QTR")) D QT^PRCSUT G EX^PRCSUT:PRC("QTR")="^" "RTN","PRCSEA1",70,0) I '$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")) G EX^PRCSUT "RTN","PRCSEA1",71,0) S (PRCSDR,DR)="[PRCE NEW 1358S]" "RTN","PRCSEA1",72,0) K DTOUT,DUOUT,Y "RTN","PRCSEA1",73,0) S PDA=DA "RTN","PRCSEA1",74,0) D ^DIE "RTN","PRCSEA1",75,0) S DA=PDA "RTN","PRCSEA1",76,0) I $D(Y)!($D(DTOUT)) S PRCAED=-1 "RTN","PRCSEA1",77,0) D W1^PRCSEB "RTN","PRCSEA1",78,0) L -^PRCS(410,DA) "RTN","PRCSEA1",79,0) S DIR("B")="NO",DIR(0)="Y" "RTN","PRCSEA1",80,0) S DIR("A")="Would you like to edit another request" "RTN","PRCSEA1",81,0) D ^DIR "RTN","PRCSEA1",82,0) Q:'Y!($D(DIRUT)) "RTN","PRCSEA1",83,0) G ED1 "RTN","PRCSEA1",84,0) W6 D EN^DDIOL("For the transaction number,use an uppercase alpha as the first character,") "RTN","PRCSEA1",85,0) D EN^DDIOL(" and then 2-15 alphanumerics, as in 'ADP1'.") "RTN","PRCSEA1",86,0) D EN^DDIOL(" ") "RTN","PRCSEA1",87,0) Q "RTN","PRCSEB") 0^4^B30999928^B29593062 "RTN","PRCSEB",1,0) PRCSEB ;SF-ISC/LJP/SAW/DXH/DAP - CPA EDITS CON'T ;7.26.99 "RTN","PRCSEB",2,0) V ;;5.1;IFCAP;**81,174,184,196,204**;Oct 20, 2000;Build 14 "RTN","PRCSEB",3,0) ;Per VA Directive 6402, this routine should not be modified. "RTN","PRCSEB",4,0) ; "RTN","PRCSEB",5,0) ;PRC*5.1*184 Check for error message indicating no 2237 seq nos. "RTN","PRCSEB",6,0) ; remaining to be used out of the max 9999 available "RTN","PRCSEB",7,0) ; for FCP FY-FQ. "RTN","PRCSEB",8,0) ; "RTN","PRCSEB",9,0) ;PRC*5.1*196 Check to move Date Required to Committed Date (MOP= 2,3 or 4) "RTN","PRCSEB",10,0) ; to insure a later date is used for FMS document. Also, "RTN","PRCSEB",11,0) ; added date check called from templates PRCSENR&NR1, "RTN","PRCSEB",12,0) ; PRCSEN2237B & PRCSENPR to insure dates are in same "RTN","PRCSEB",13,0) ; FY/FQ defined. "RTN","PRCSEB",14,0) ; "RTN","PRCSEB",15,0) ENRB ;ENTER CP CLERK REQUEST FROM OPTION PRCSENRB "RTN","PRCSEB",16,0) K PRCBBMY "RTN","PRCSEB",17,0) D ENF^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0) "RTN","PRCSEB",18,0) S MSG="" D EN1^PRCSUT3 Q:'X I MSG'="" W !!,MSG,! S DIR(0)="EAO",DIR("A")="Press to exit processing..." D ^DIR K DIR,MSG Q ;PRC*5.1*184 "RTN","PRCSEB",19,0) K MSG ;PRC*5.1*184 "RTN","PRCSEB",20,0) S PRCSX1=X D EN2^PRCSUT3 Q:'$D(PRCSX1) S X=PRCSX1,T1=DA D W L +^PRCS(410,DA):15 G ENRB:$T=0 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1 "RTN","PRCSEB",21,0) ; "RTN","PRCSEB",22,0) ;*81 Check site parameter to see if issue books should be allowed "RTN","PRCSEB",23,0) D CKPRM "RTN","PRCSEB",24,0) W !!,PRCVY,!! "RTN","PRCSEB",25,0) TYPE ; "RTN","PRCSEB",26,0) S PRCDAA=DA,DIC="^PRCS(410.5,",DIC(0)="AEQZ",DIC("A")="FORM TYPE: ",DIC("S")=PRCVX D ^DIC S TYPE=+Y,DA=PRCDAA "RTN","PRCSEB",27,0) I TYPE<2 W "?? EXIT NOT ALLOWED" G TYPE "RTN","PRCSEB",28,0) K PRCVX,PRCVY "RTN","PRCSEB",29,0) S $P(^PRCS(410,DA,0),"^",4)=TYPE S:$G(PRCSIP) $P(^PRCS(410,DA,0),"^",6)=PRCSIP S (DIE,DIC)="^PRCS(410,",X=TYPE "RTN","PRCSEB",30,0) ;NOTE THAT THE FOLLOWING LINE OVERWRITES THE USER'S SELECTION OF FORM "RTN","PRCSEB",31,0) ;TYPE IF THE FUND CONTROL POINT IS NOT 'AUTOMATED' "RTN","PRCSEB",32,0) S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEB",33,0) S PRCSTYP=X ;PRC*5.1*196 "RTN","PRCSEB",34,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]" "RTN","PRCSEB",35,0) EN1 K DTOUT,DUOUT,Y S PRCSDAA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=PRCSDAA L -^PRCS(410,DA) G EXIT "RTN","PRCSEB",36,0) S DA=PRCSDAA D RL^PRCSUT1 "RTN","PRCSEB",37,0) 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 "RTN","PRCSEB",38,0) . S PRCOMDT=$S($P(^PRCS(410,DA,1),U,4)'=DT:$P(^PRCS(410,DA,1),U,4),1:DT) "RTN","PRCSEB",39,0) . S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE "RTN","PRCSEB",40,0) . S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204 "RTN","PRCSEB",41,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 "RTN","PRCSEB",42,0) K PRCSERR "RTN","PRCSEB",43,0) I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSEB",44,0) S:$P($G(^PRCS(410,DA,7)),"^")="" $P(^PRCS(410,DA,7),"^")=DUZ "RTN","PRCSEB",45,0) D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6 "RTN","PRCSEB",46,0) S DA=PRCSDAA L -^PRCS(410,DA) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 "RTN","PRCSEB",47,0) G ENRB "RTN","PRCSEB",48,0) W W !!,"This transaction is assigned transaction number: ",X Q "RTN","PRCSEB",49,0) 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 "RTN","PRCSEB",50,0) W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCSEB",51,0) W3 W !!,"Would you like to enter another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSEB",52,0) W5 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)="" K ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) Q "RTN","PRCSEB",53,0) W51 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=1,(^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA))="" Q "RTN","PRCSEB",54,0) W6 N JUMP,SKIPRNT,OK,TEST,TEST1,CURQTR,CURQTR1 "RTN","PRCSEB",55,0) W61 ; "RTN","PRCSEB",56,0) N REPORT2 I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 S REPORT2=1 D T1^PRCSAPP1 "RTN","PRCSEB",57,0) ;*****PRC*5.1*174 start***** "RTN","PRCSEB",58,0) ;if Level of Access is not Control Point Official DO block "RTN","PRCSEB",59,0) I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 D Q "RTN","PRCSEB",60,0) . N PRCFTYPE S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I") ;Form Type "RTN","PRCSEB",61,0) . S %=1 "RTN","PRCSEB",62,0) . ;if request is a 2237 (Form Type IEN 2,3, or 4) "RTN","PRCSEB",63,0) . I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D "RTN","PRCSEB",64,0) . . ;don't allow approval of 2237 if Requesting Service OR any line item description is missing "RTN","PRCSEB",65,0) . . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S %=2 "RTN","PRCSEB",66,0) . I $G(%)'=2 S %=1 W !,"Is this request ready for approval" D YN^DICN "RTN","PRCSEB",67,0) . D:%=1 W51 "RTN","PRCSEB",68,0) . D:%=0 W61 "RTN","PRCSEB",69,0) . D:%=2 W5 "RTN","PRCSEB",70,0) ;*****PRC*5.1*174 end****** "RTN","PRCSEB",71,0) S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3) "RTN","PRCSEB",72,0) S (CURQTR,CURQTR1)=PRC("QTR"),(JUMP,TEST,TEST1,OK)=0 "RTN","PRCSEB",73,0) D T1^PRCSAPP1 I OK=1 S SKIPRNT=1 D FINAL^PRCSAPP2 "RTN","PRCSEB",74,0) Q "RTN","PRCSEB",75,0) ;*81 Site Parameter Check "RTN","PRCSEB",76,0) CKPRM I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The form types 1358, Issue Book, and NO FORM are no longer used within this option." "RTN","PRCSEB",77,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The form types 1358 and NO FORM are no longer used within this option" "RTN","PRCSEB",78,0) Q "RTN","PRCSEB",79,0) ; "RTN","PRCSEB",80,0) CHKREQ ;Check Date to insure it is within the FY/FQ range during option entry for 'NEW 2237' ;PRC*5.1*196 "RTN","PRCSEB",81,0) N PRCDT,PRCDT1 "RTN","PRCSEB",82,0) I $D(PRCBBMY) S PRCCKERR=0 Q "RTN","PRCSEB",83,0) S PRCDTT=1700+$E(DT,1,3) "RTN","PRCSEB",84,0) I '$D(PRC("BBFY"))!(+$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!($P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)["X") S PRC("BBFY")=PRC("FY")+2000 "RTN","PRCSEB",85,0) S PRCCKERR=0,PRCDT=(PRC("BBFY")-$S(PRC("QTR")=1:1701,1:1700))_$P("10:01:04:07",":",PRC("QTR"))_"01",PRCDT1=(PRC("BBFY")-1700)_"0930" "RTN","PRCSEB",86,0) I PRCSTDTPRCDT1) D "RTN","PRCSEB",87,0) . S PRCCKERR=1 "RTN","PRCSEB",88,0) . W !!," ** Date must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",! "RTN","PRCSEB",89,0) Q "RTN","PRCSEB",90,0) EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSERR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,PRCOMDT,PRCCKERR,PRCSTYP Q ;PRC*5.1*196 "RTN","PRCSEB0") 0^3^B29218782^B25973826 "RTN","PRCSEB0",1,0) PRCSEB0 ;SF-ISC/LJP/SAW/DGL/DAP - CPA EDITS CON'T ;7/9/13 16:01 "RTN","PRCSEB0",2,0) V ;;5.1;IFCAP;**81,174,196,204**;Oct 20, 2000;Build 14 "RTN","PRCSEB0",3,0) ;Per VA Directive 6402, this routine should not be modified. "RTN","PRCSEB0",4,0) ; "RTN","PRCSEB0",5,0) ;PRC*5.1*196 Check to move Date Required to Committed Date to "RTN","PRCSEB0",6,0) ; insure a later date is used for FMS document. "RTN","PRCSEB0",7,0) ; "RTN","PRCSEB0",8,0) EDTD ;EDIT TRANSACTION DATA "RTN","PRCSEB0",9,0) N TYPE,TYPE1,CHECK,JUMP S JUMP=1 K PRCBBMY "RTN","PRCSEB0",10,0) D EN3F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 "RTN","PRCSEB0",11,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" "RTN","PRCSEB0",12,0) 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)))" "RTN","PRCSEB0",13,0) D ^PRCSDIC G EXIT:Y<0 K DIC("S") S (DA,PRCSDAA,PRCSY,T1)=+Y L +^PRCS(410,DA):15 G EDTD:$T=0 "RTN","PRCSEB0",14,0) I '$D(PRC("FY")) D FY^PRCSUT G EX^PRCSUT:PRC("FY")="^" "RTN","PRCSEB0",15,0) I '$D(PRC("QTR")) D QT^PRCSUT G EX^PRCSUT:PRC("QTR")="^" "RTN","PRCSEB0",16,0) 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 "RTN","PRCSEB0",17,0) S TYPE=$P(^PRCS(410,DA,0),"^",4) "RTN","PRCSEB0",18,0) 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 "RTN","PRCSEB0",19,0) EDTD3 I $D(^PRCS(410,DA,7)),$P(^(7),U,6)]"" G EDTD4 "RTN","PRCSEB0",20,0) I $D(PRCSEM) S DIE=DIC,DR="[PRCSENMDR]" D ^DIE S DA=T1 L -^PRCS(410,DA) G EXIT "RTN","PRCSEB0",21,0) 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 "RTN","PRCSEB0",22,0) D:PRCSX3="A"&($O(^PRCS(410,PRCSY,12,0))) SCPC0^PRCSED "RTN","PRCSEB0",23,0) 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 "RTN","PRCSEB0",24,0) I PRCSX3="A",$P(^PRCS(410,DA,0),"^",4)=1 D W6^PRCSEB "RTN","PRCSEB0",25,0) I PRCSX3'="O" G EDTD2 "RTN","PRCSEB0",26,0) EDTD4 I $D(^PRCS(410,DA,7)),$P(^(7),"^",6)'="" S DR="[PRCSEDS]" D ^DIE D W1 G EDTD2 "RTN","PRCSEB0",27,0) EDTD5 ;*81 Loop now checks site parameter to see if Issue Books should be allowed "RTN","PRCSEB0",28,0) S X=+$P(^PRCS(410,DA,0),"^",4) I X<2 D "RTN","PRCSEB0",29,0) .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." "RTN","PRCSEB0",30,0) .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." "RTN","PRCSEB0",31,0) .W !,PRCVY,! "RTN","PRCSEB0",32,0) .W !,"Please enter another form type.",! "RTN","PRCSEB0",33,0) .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 "RTN","PRCSEB0",34,0) .K PRCVX,PRCVY "RTN","PRCSEB0",35,0) .S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y "RTN","PRCSEB0",36,0) I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP "RTN","PRCSEB0",37,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1 "RTN","PRCSEB0",38,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0 "RTN","PRCSEB0",39,0) W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),! "RTN","PRCSEB0",40,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 "RTN","PRCSEB0",41,0) ;P182--Removed reference to TEMPREQ in following line: no longer used. "RTN","PRCSEB0",42,0) ;Q:$D(TEMPREQ) S (DIC,DIE)="^PRCS(410," "RTN","PRCSEB0",43,0) K PRCVZ "RTN","PRCSEB0",44,0) S (DIC,DIE)="^PRCS(410," "RTN","PRCSEB0",45,0) G EDTD2:X="" "RTN","PRCSEB0",46,0) S PRCSTYP=X ;PRC*5.1*196 "RTN","PRCSEB0",47,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]" "RTN","PRCSEB0",48,0) 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 "RTN","PRCSEB0",49,0) 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 "RTN","PRCSEB0",50,0) . S PRCOMDT=$S($P(^PRCS(410,DA,1),U,4)'=DT:$P(^PRCS(410,DA,1),U,4),1:DT) "RTN","PRCSEB0",51,0) . S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE "RTN","PRCSEB0",52,0) . S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204 "RTN","PRCSEB0",53,0) S DA=PRCSDAA D RL^PRCSUT1 "RTN","PRCSEB0",54,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1 "RTN","PRCSEB0",55,0) K PRCSERR "RTN","PRCSEB0",56,0) I PRCSDR="[PRCSENCOD]" D W7 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSEB0",57,0) 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) "RTN","PRCSEB0",58,0) ; "RTN","PRCSEB0",59,0) ;if 2237 required field checks fail, warn user (PRC*5.1*174) "RTN","PRCSEB0",60,0) I PRCSDR'="[PRCSENCOD]",'$$REQCHECK^PRCHJUTL($G(DA),,1) "RTN","PRCSEB0",61,0) ; "RTN","PRCSEB0",62,0) D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB "RTN","PRCSEB0",63,0) EDTD2 S DA=PRCSDAA L -^PRCS(410,DA) G EXIT:$D(PRCSQ) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 G EDTD "RTN","PRCSEB0",64,0) 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 "RTN","PRCSEB0",65,0) 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 "RTN","PRCSEB0",66,0) W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCSEB0",67,0) W3 W !!,"Would you like to edit another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSEB0",68,0) 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 "RTN","PRCSEB0",69,0) 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 "RTN","PRCSUT") 0^7^B55616855^B54556386 "RTN","PRCSUT",1,0) PRCSUT ;WISC/SAW/DGL - CONTROL POINT ACTIVITY UTILITY PROGRAM ;9/14/00 15:49 "RTN","PRCSUT",2,0) V ;;5.1;IFCAP;**93,204**;Oct 20, 2000;Build 14 "RTN","PRCSUT",3,0) ;Per VHA Directive 6402, this routine should not be modified. "RTN","PRCSUT",4,0) ; "RTN","PRCSUT",5,0) ENF(PRCIPFLG) ;Entry point for Inv. Pt. selection "RTN","PRCSUT",6,0) EN ;STA,FY,QTR,CP W/SCREEN FOR INACTIVE CP "RTN","PRCSUT",7,0) I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0 "RTN","PRCSUT",8,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",9,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",10,0) D QT G EX:PRC("QTR")="^" "RTN","PRCSUT",11,0) S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))" "RTN","PRCSUT",12,0) I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG) "RTN","PRCSUT",13,0) I '$D(PRCSC) D CPF(PRCIPFLG) "RTN","PRCSUT",14,0) G EX:'SI!(Y<0) "RTN","PRCSUT",15,0) G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX "RTN","PRCSUT",16,0) G EN11 "RTN","PRCSUT",17,0) ; "RTN","PRCSUT",18,0) EN1F(PRCIPFLG) ; Entry point for Inv. Pt. selection "RTN","PRCSUT",19,0) EN1 ;STA,FY,QTR,CP "RTN","PRCSUT",20,0) I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0 "RTN","PRCSUT",21,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",22,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",23,0) D QT G EX:PRC("QTR")="^" "RTN","PRCSUT",24,0) I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG) "RTN","PRCSUT",25,0) I '$D(PRCSC) D CPF(PRCIPFLG) "RTN","PRCSUT",26,0) G EX:'SI!(Y<0) "RTN","PRCSUT",27,0) G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX "RTN","PRCSUT",28,0) EN11 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ") "RTN","PRCSUT",29,0) S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ") "RTN","PRCSUT",30,0) G EXIT "RTN","PRCSUT",31,0) ; "RTN","PRCSUT",32,0) EN2 ;STA,FY,QTR "RTN","PRCSUT",33,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",34,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",35,0) D QT G EX:PRC("QTR")="^" "RTN","PRCSUT",36,0) G EXIT "RTN","PRCSUT",37,0) ; "RTN","PRCSUT",38,0) EN3F(PRCIPFLG) ; Entry point for Inv. Pt. selection "RTN","PRCSUT",39,0) EN3 ;STA,CP "RTN","PRCSUT",40,0) I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0 "RTN","PRCSUT",41,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",42,0) I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG) "RTN","PRCSUT",43,0) D:'$D(PRCSC) CPF(PRCIPFLG) "RTN","PRCSUT",44,0) G EX:'SI!(Y<0) "RTN","PRCSUT",45,0) G EXIT "RTN","PRCSUT",46,0) ; "RTN","PRCSUT",47,0) EN4 ;STA,FY,QTR,CC "RTN","PRCSUT",48,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",49,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",50,0) D QT G EX:PRC("QTR")="^" "RTN","PRCSUT",51,0) D CC "RTN","PRCSUT",52,0) G EXIT "RTN","PRCSUT",53,0) ; "RTN","PRCSUT",54,0) EN5 ;STA,FY,QTR,BOC "RTN","PRCSUT",55,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",56,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",57,0) D QT G EX:PRC("QTR")="^" "RTN","PRCSUT",58,0) D SUB "RTN","PRCSUT",59,0) G EXIT "RTN","PRCSUT",60,0) ; "RTN","PRCSUT",61,0) EN6F(PRCIPFLG) ; Entry point for Inv. Pt. selection "RTN","PRCSUT",62,0) EN6 ;STA,CP,FY "RTN","PRCSUT",63,0) I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0 "RTN","PRCSUT",64,0) D STA G EX:'SI!(Y<0) "RTN","PRCSUT",65,0) I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG) "RTN","PRCSUT",66,0) I '$D(PRCSC) D CPF(PRCIPFLG) "RTN","PRCSUT",67,0) G EX:'SI!(Y<0) "RTN","PRCSUT",68,0) D FY G EX:PRC("FY")="^" "RTN","PRCSUT",69,0) G EXIT "RTN","PRCSUT",70,0) ; "RTN","PRCSUT",71,0) ;PRCSST is flag to not ask substation "RTN","PRCSUT",72,0) ;PRCSK is flag to allow selection of any station "RTN","PRCSUT",73,0) STA ;SELECT STATION NUMBER "RTN","PRCSUT",74,0) S N="",Y=0 "RTN","PRCSUT",75,0) I $D(PRCSK) S SI=2 ; if privilege flag is set, ask STATION "RTN","PRCSUT",76,0) ; else restrict station selection to user's authorized stations "RTN","PRCSUT",77,0) E F SI=0:1:2 S N=$O(^PRC(420,"A",DUZ,N)) Q:N'>0 S N(1)=N "RTN","PRCSUT",78,0) Q:'SI ; user not allowed to access any station "RTN","PRCSUT",79,0) I SI>1 D "RTN","PRCSUT",80,0) . S DIC="^PRC(420,",DIC(0)="AEMQ",DIC("A")="Select STATION NUMBER: " "RTN","PRCSUT",81,0) . I '$D(PRCSK) S DIC("S")="I $D(^PRC(420,""A"",DUZ,+Y))" "RTN","PRCSUT",82,0) . I $D(PRC("SITE")) S DIC("B")=PRC("SITE") "RTN","PRCSUT",83,0) . S D="B^C" "RTN","PRCSUT",84,0) . D MIX^DIC1 I Y>0 S PRC("SITE")=+Y "RTN","PRCSUT",85,0) I SI=1 S PRC("SITE")=N(1) "RTN","PRCSUT",86,0) I '$D(PRC("SITE")) S PRC("SITE")="",PRC("SST")="" "RTN","PRCSUT",87,0) I PRC("SITE")=""!(Y<0) K DIC,N Q "RTN","PRCSUT",88,0) ; substation "RTN","PRCSUT",89,0) I '$D(PRC("SST"))!'$D(^PRC(411,"UP",+PRC("SITE"))) S PRC("SST")="" "RTN","PRCSUT",90,0) I '$G(PRCSST),$D(^PRC(411,"UP",+PRC("SITE"))) D "RTN","PRCSUT",91,0) . S DIC("B")=PRC("SST") "RTN","PRCSUT",92,0) . S DIC="^PRC(411,",DIC(0)="AEQZ",DIC("A")="Select SUBSTATION: " "RTN","PRCSUT",93,0) . S DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")" "RTN","PRCSUT",94,0) . D ^DIC I Y>0 S PRC("SST")=+Y "RTN","PRCSUT",95,0) K DIC,N "RTN","PRCSUT",96,0) Q "RTN","PRCSUT",97,0) ; "RTN","PRCSUT",98,0) FY ;SELECT FISCAL YEAR "RTN","PRCSUT",99,0) D:'$D(DT) DT^DICRW "RTN","PRCSUT",100,0) S FYT=$E(100+$E(DT,2,3)+$E(DT,4),2,3),PRC("FY")=FYT "RTN","PRCSUT",101,0) W !,"Select FISCAL YEAR: ",FYT,"// " R PRC("FY"):DTIME "RTN","PRCSUT",102,0) S:'$T PRC("FY")=U "RTN","PRCSUT",103,0) S:PRC("FY")="" PRC("FY")=FYT "RTN","PRCSUT",104,0) Q:PRC("FY")="^" "RTN","PRCSUT",105,0) I PRC("FY")'?2N W $C(7),!,"Enter a two digit fiscal year (e.g., 87).",! G FY "RTN","PRCSUT",106,0) Q "RTN","PRCSUT",107,0) ; "RTN","PRCSUT",108,0) QT ;SELECT QUARTER "RTN","PRCSUT",109,0) D:'$D(DT) DT^DICRW "RTN","PRCSUT",110,0) I '$D(QTT) S:$D(PRC("QTR")) QTT=PRC("QTR") I '$D(QTT) S SI=$E(DT,4,5),QTT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",SI) "RTN","PRCSUT",111,0) W !,"Select QUARTER: ",QTT,"// " R PRC("QTR"):DTIME "RTN","PRCSUT",112,0) S:'$T PRC("QTR")=U "RTN","PRCSUT",113,0) S:PRC("QTR")="" PRC("QTR")=QTT "RTN","PRCSUT",114,0) Q:PRC("QTR")=U "RTN","PRCSUT",115,0) I PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N) W $C(7),!,"Enter a single digit number from 1 to 4.",! G QT "RTN","PRCSUT",116,0) Q "RTN","PRCSUT",117,0) ; "RTN","PRCSUT",118,0) CPF(PRCIPFLG) ; Entry point for inv. pt. selection "RTN","PRCSUT",119,0) CP ;SELECT CONTROL POINT "RTN","PRCSUT",120,0) N FCPDA "RTN","PRCSUT",121,0) K PRCSIP ; inventory distribution point variable "RTN","PRCSUT",122,0) I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0 "RTN","PRCSUT",123,0) S FCPDA=$O(^PRC(420,"A",DUZ,PRC("SITE"),0)) Q:'FCPDA ; no fcps "RTN","PRCSUT",124,0) I '$O(^PRC(420,"A",DUZ,PRC("SITE"),FCPDA)) D Q ; access to 1 fcp "RTN","PRCSUT",125,0) . S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,FCPDA,0)),U) "RTN","PRCSUT",126,0) . I PRC("CP"),PRCIPFLG D IP "RTN","PRCSUT",127,0) ; more than one fcp "RTN","PRCSUT",128,0) S DIC="^PRC(420,"_PRC("SITE")_",1," "RTN","PRCSUT",129,0) S DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: " "RTN","PRCSUT",130,0) I '$D(DIC("S")) S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))" "RTN","PRCSUT",131,0) I $D(PRC("CP")),PRC("CP"),$D(^PRC(420,PRC("SITE"),1,PRC("CP"))) S DIC("B")=+PRC("CP") "RTN","PRCSUT",132,0) S D="B^C" D MIX^DIC1 S:Y<0 PRC("CP")="^" "RTN","PRCSUT",133,0) I Y>0 S PRC("CP")=$P(Y(0),"^") I PRCIPFLG=1 D IP "RTN","PRCSUT",134,0) K DIC "RTN","PRCSUT",135,0) Q "RTN","PRCSUT",136,0) ; "RTN","PRCSUT",137,0) ;A=station #, B=fiscal year, C=fcp #, PRCA=1 if no user interactive "RTN","PRCSUT",138,0) BBFY(A,B,C,PRCA) ;extrinsic function of beginning budget fiscal year "RTN","PRCSUT",139,0) N D,E,F,X,Y "RTN","PRCSUT",140,0) K PRC("BBFY") "RTN","PRCSUT",141,0) S E=$G(^PRC(420,A,1,+C,5)) "RTN","PRCSUT",142,0) I $P(E,"^")]"" S F=$O(^PRCD(420.3,"B",$P(E,"^"),"")) I F I $P(^PRCD(420.3,F,0),"^",8)="Y" S PRC("BBFY")=+$$DATE^PRC0C($P(E,"^",8),"I") QUIT PRC("BBFY") "RTN","PRCSUT",143,0) S B=+$$YEAR^PRC0C(B) "RTN","PRCSUT",144,0) S D=$$APP^PRC0C(A,$E(B,3,4),C) "RTN","PRCSUT",145,0) I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY") "RTN","PRCSUT",146,0) S F=$$BBFY^PRC0D(A,C,'$G(PRCA)) "RTN","PRCSUT",147,0) I F="",$G(PRCA)=1 S PRC("BBFY")=B QUIT PRC("BBFY") "RTN","PRCSUT",148,0) I $G(PRCA)=1 S PRC("BBFY")=B-(B-$P(F,"~",2)#$P(F,"~",3)) QUIT PRC("BBFY") "RTN","PRCSUT",149,0) BBFY1 S E="^2:4^K:X'?2N&(X'?4N) X I $G(X)]"""" S X=+$$YEAR^PRC0C(X) K:X-$P(F,""~"",2)#$P(F,""~"",3) X" "RTN","PRCSUT",150,0) S Y(1)="Enter a 2 or 4 digit year." "RTN","PRCSUT",151,0) D FT^PRC0A(.X,.Y,"First Year of the Multi-Appropriation ("_$P(D,"^")_")",E,$S(F="":B,1:B-(B-$P(F,"~",2)#$P(F,"~",3)))) "RTN","PRCSUT",152,0) I Y?2.4N S Y=+$$YEAR^PRC0C(Y) I B0 S PRCSIP=$P(^TMP($J,"PRCSUT",Y),"^") W " ",$P(^TMP($J,"PRCSUT",Y),"^",2),! "RTN","PRCSUT",210,0) IPQ K ^TMP($J,"PRCSUT") "RTN","PRCSUT",211,0) Q "VER") 8.0^22.2 "BLD",10924,6) ^179 **END** **END**