Released PRC*5.1*165 SEQ #150 Extracted from mail message **KIDS**:PRC*5.1*165^ **INSTALL NAME** PRC*5.1*165 "BLD",7020,0) PRC*5.1*165^IFCAP^0^3120302^y "BLD",7020,1,0) ^^7^7^3120125^ "BLD",7020,1,1,0) 1. Items falling below emergency stock level are not showing on Auto-Gen "BLD",7020,1,2,0) suggested orders. "BLD",7020,1,3,0) "BLD",7020,1,4,0) 2. Amendment problem where user is not authorized to amend order. "BLD",7020,1,5,0) "BLD",7020,1,6,0) 3. User encountered subscript error while running option 'APPROVE "BLD",7020,1,7,0) REQUESTS'. "BLD",7020,4,0) ^9.64PA^440.5^1 "BLD",7020,4,440.5,0) 440.5 "BLD",7020,4,440.5,2,0) ^9.641^440.512^1 "BLD",7020,4,440.5,2,440.512,0) SURROGATE USER (sub-file) "BLD",7020,4,440.5,2,440.512,1,0) ^9.6411^.01^1 "BLD",7020,4,440.5,2,440.512,1,.01,0) SURROGATE USER "BLD",7020,4,440.5,222) y^n^p^^^^n^^n "BLD",7020,4,440.5,224) "BLD",7020,4,"APDD",440.5,440.512) "BLD",7020,4,"APDD",440.5,440.512,.01) "BLD",7020,4,"B",440.5,440.5) "BLD",7020,6.3) 12 "BLD",7020,"ABPKG") n "BLD",7020,"KRN",0) ^9.67PA^779.2^20 "BLD",7020,"KRN",.4,0) .4 "BLD",7020,"KRN",.401,0) .401 "BLD",7020,"KRN",.402,0) .402 "BLD",7020,"KRN",.403,0) .403 "BLD",7020,"KRN",.5,0) .5 "BLD",7020,"KRN",.84,0) .84 "BLD",7020,"KRN",3.6,0) 3.6 "BLD",7020,"KRN",3.8,0) 3.8 "BLD",7020,"KRN",9.2,0) 9.2 "BLD",7020,"KRN",9.8,0) 9.8 "BLD",7020,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",7020,"KRN",9.8,"NM",1,0) PRCH442^^0^B51303635 "BLD",7020,"KRN",9.8,"NM",2,0) PRCHUSER^^0^B18801135 "BLD",7020,"KRN",9.8,"NM",3,0) PRCSAPP^^0^B14893513 "BLD",7020,"KRN",9.8,"NM","B","PRCH442",1) "BLD",7020,"KRN",9.8,"NM","B","PRCHUSER",2) "BLD",7020,"KRN",9.8,"NM","B","PRCSAPP",3) "BLD",7020,"KRN",19,0) 19 "BLD",7020,"KRN",19.1,0) 19.1 "BLD",7020,"KRN",101,0) 101 "BLD",7020,"KRN",409.61,0) 409.61 "BLD",7020,"KRN",771,0) 771 "BLD",7020,"KRN",779.2,0) 779.2 "BLD",7020,"KRN",870,0) 870 "BLD",7020,"KRN",8989.51,0) 8989.51 "BLD",7020,"KRN",8989.52,0) 8989.52 "BLD",7020,"KRN",8994,0) 8994 "BLD",7020,"KRN","B",.4,.4) "BLD",7020,"KRN","B",.401,.401) "BLD",7020,"KRN","B",.402,.402) "BLD",7020,"KRN","B",.403,.403) "BLD",7020,"KRN","B",.5,.5) "BLD",7020,"KRN","B",.84,.84) "BLD",7020,"KRN","B",3.6,3.6) "BLD",7020,"KRN","B",3.8,3.8) "BLD",7020,"KRN","B",9.2,9.2) "BLD",7020,"KRN","B",9.8,9.8) "BLD",7020,"KRN","B",19,19) "BLD",7020,"KRN","B",19.1,19.1) "BLD",7020,"KRN","B",101,101) "BLD",7020,"KRN","B",409.61,409.61) "BLD",7020,"KRN","B",771,771) "BLD",7020,"KRN","B",779.2,779.2) "BLD",7020,"KRN","B",870,870) "BLD",7020,"KRN","B",8989.51,8989.51) "BLD",7020,"KRN","B",8989.52,8989.52) "BLD",7020,"KRN","B",8994,8994) "BLD",7020,"QDEF") ^^^^NO^^^^^^YES "BLD",7020,"QUES",0) ^9.62^^ "BLD",7020,"REQB",0) ^9.611^2^2 "BLD",7020,"REQB",1,0) PRC*5.1*81^2 "BLD",7020,"REQB",2,0) PRC*5.1*125^2 "BLD",7020,"REQB","B","PRC*5.1*125",2) "BLD",7020,"REQB","B","PRC*5.1*81",1) "FIA",440.5) PURCHASE CARD INFORMATION "FIA",440.5,0) ^PRC(440.5, "FIA",440.5,0,0) 440.5I "FIA",440.5,0,1) y^n^p^^^^n^^n "FIA",440.5,0,10) "FIA",440.5,0,11) "FIA",440.5,0,"RLRO") "FIA",440.5,0,"VR") 5.1^PRC "FIA",440.5,440.5) 1 "FIA",440.5,440.5,12) "FIA",440.5,440.512) 1 "FIA",440.5,440.512,.01) "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) 165^3120302 "PKG",455,22,1,"PAH",1,1,0) ^^7^7^3120302 "PKG",455,22,1,"PAH",1,1,1,0) 1. Items falling below emergency stock level are not showing on Auto-Gen "PKG",455,22,1,"PAH",1,1,2,0) suggested orders. "PKG",455,22,1,"PAH",1,1,3,0) "PKG",455,22,1,"PAH",1,1,4,0) 2. Amendment problem where user is not authorized to amend order. "PKG",455,22,1,"PAH",1,1,5,0) "PKG",455,22,1,"PAH",1,1,6,0) 3. User encountered subscript error while running option 'APPROVE "PKG",455,22,1,"PAH",1,1,7,0) REQUESTS'. "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","PRCH442") 0^1^B51303635^B40109640 "RTN","PRCH442",1,0) PRCH442 ;WISC/KMB/DL/DXH - CREATE PURCHASE CARD ORDER FROM RIL ;12.1.99 "RTN","PRCH442",2,0) ;;5.1;IFCAP;**13,81,165**;Oct 20, 2000;Build 12 "RTN","PRCH442",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCH442",4,0) START ; entry point for delivery orders "RTN","PRCH442",5,0) S1 N RLFLAG S RLFLAG=1 "RTN","PRCH442",6,0) S2 ; entry point for purchase card orders "RTN","PRCH442",7,0) N RPUSE,SS,FSC,AA,BB,CC,EE,FF,CP,FCP,IB,J,ITEM,UCOST,MAX,PMULT,VSTOCK,VENDOR,VENDOR1,NDC,CONT,UOP,CONV,SKU,SPEC,APP,QTY,ORDTOT,PDA,CTT,CNNT,NCOST,COSTTOT,REQCT "RTN","PRCH442",8,0) N HM,CCDA,II,PP,IB,IJ,CTT,CTR,OUTRL,SERV,TDATE,CNNT1,ZS,ZS0,XDA,YDA,WHSE,COMMENT,PRCS,PRCVDYN,PRCKILL,GG "RTN","PRCH442",9,0) W ! S DIC="^PRCS(410.3,",DIC(0)="AEMQ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" D ^DIC K DIC("S") Q:Y'>0 "RTN","PRCH442",10,0) K DIC S (YDA,XDA,DA)=+Y "RTN","PRCH442",11,0) S:'$D(PRC("SST")) PRC("SST")="" S DIC("B")=PRC("SST") I $D(^PRC(411,"UP",+PRC("SITE"))) S DIC="^PRC(411,",DIC(0)="AEQZS",DIC("A")="Select SUBSTATION: ",DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")" D ^DIC I Y>0 S PRC("SST")=+Y "RTN","PRCH442",12,0) K DIC Q:Y'>0 "RTN","PRCH442",13,0) I '$D(PRC("PARAM")) S PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0) "RTN","PRCH442",14,0) S COMMENT="purchase card",WHSE=+$O(^PRC(440,"AC","S",0)) S:$G(RLFLAG)=1 COMMENT="delivery" "RTN","PRCH442",15,0) ; introducing prcsip as package-wide "RTN","PRCH442",16,0) S OUTRL=0,PRCSIP=$P(^PRCS(410.3,XDA,0),U,3) "RTN","PRCH442",17,0) S CTT=$P($G(^PRCS(410.3,XDA,1,0)),"^",4) I +CTT=0 W !,"There are no items on this repetitive item list." Q "RTN","PRCH442",18,0) ; "RTN","PRCH442",19,0) ;See NOIS MON-0399-51726 "RTN","PRCH442",20,0) KILL ^TMP($J) "RTN","PRCH442",21,0) S IB=0,PRCVDYN=0 "RTN","PRCH442",22,0) ; "RTN","PRCH442",23,0) ; PRC*5.1*81 set flag (PRCVDYN) for DynaMed RIL "RTN","PRCH442",24,0) I $O(^PRCV(414.02,"C",$P(^PRCS(410.3,XDA,0),"^",1),0))]"" S PRCVDYN=1 "RTN","PRCH442",25,0) ; "RTN","PRCH442",26,0) F S IB=$O(^PRCS(410.3,XDA,1,IB)) Q:'IB D ; "RTN","PRCH442",27,0) . S FF=$G(^PRCS(410.3,XDA,1,IB,0)) "RTN","PRCH442",28,0) . S ^TMP($J,410.3,XDA,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)="" "RTN","PRCH442",29,0) ; "RTN","PRCH442",30,0) W !,"This repetitive item list has the following vendors:",! "RTN","PRCH442",31,0) ; "RTN","PRCH442",32,0) S HM="" "RTN","PRCH442",33,0) F S HM=$O(^TMP($J,410.3,XDA,1,"AC",HM)) Q:HM="" D "RTN","PRCH442",34,0) . W !,$P(HM,";"),?40,"NUMBER: ",$P(HM,";",2) "RTN","PRCH442",35,0) ; "RTN","PRCH442",36,0) W ! "RTN","PRCH442",37,0) S ZS=$P(^PRCS(410.3,XDA,0),"^"),PRC("SITE")=$P(ZS,"-"),CP=+$P(ZS,"-",4),CCEN=$P(ZS,"-",5) "RTN","PRCH442",38,0) D FY "RTN","PRCH442",39,0) S SPEC=$P($G(^PRC(420,PRC("SITE"),1,CP,0)),"^",12),(FCP,PRC("CP"))=$P($G(^PRC(420,PRC("SITE"),1,CP,0)),"^"),SERV=$P($G(^(0)),"^",10) "RTN","PRCH442",40,0) S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")),APP=$P($$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),"^",11) "RTN","PRCH442",41,0) PROCESS ; "RTN","PRCH442",42,0) ; get item data from repetitive item list "RTN","PRCH442",43,0) S VENDOR1=0,(REQCT,COSTTOT,IB)=0 "RTN","PRCH442",44,0) F S VENDOR1=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1)) Q:VENDOR1="" D PROCESS1 "RTN","PRCH442",45,0) W !!!,"Total number of requests generated: ",REQCT,!,"Total cost of all requests: $",$J(COSTTOT,0,2) "RTN","PRCH442",46,0) Q:REQCT=0 "RTN","PRCH442",47,0) W !,"Generating ",COMMENT," orders...." "RTN","PRCH442",48,0) I $D(EE($J)) S PP="",RPUSE=1 F S PP=$O(EE($J,PP)) Q:PP="" S DA=PP D "RTN","PRCH442",49,0) .K CCDA D ^PRCH410 "RTN","PRCH442",50,0) .I $G(CCDA)'="" W !,"Request ",$P(^PRCS(410,CCDA,0),"^")," created.",! "RTN","PRCH442",51,0) ; "RTN","PRCH442",52,0) ; PRC*5.1*81 if DynaMed RIL and trouble with item, save RIL# to ^TMP "RTN","PRCH442",53,0) I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) S ^TMP($J,"PRCVHMSG",YDA)=$P(^PRCS(410.3,YDA,0),"^",1) "RTN","PRCH442",54,0) ; "RTN","PRCH442",55,0) D RENUM^PRCH442A "RTN","PRCH442",56,0) SLIST S PRCKILL=0 I 'PRCVDYN D "RTN","PRCH442",57,0) . I $G(^PRCS(410.3,YDA,0))'="" S %=2 W !,"Do you wish to re-use this list" D YN^DICN G:%=0 SLIST I %=2 S PRCKILL=1 "RTN","PRCH442",58,0) ; "RTN","PRCH442",59,0) ; PRC*5.1*81 - send DynaMed a cancel txn for any items not moved to a PC "RTN","PRCH442",60,0) I PRCVDYN D "RTN","PRCH442",61,0) . I +$O(^PRCS(410.3,YDA,1,0))>0 D EN^PRCVRCA(YDA) "RTN","PRCH442",62,0) ; "RTN","PRCH442",63,0) I PRCVDYN!PRCKILL S DA=YDA,DIK="^PRCS(410.3," D ^DIK K DIK "RTN","PRCH442",64,0) ; "RTN","PRCH442",65,0) ; PRC*5.1*81 - send message to user of problems found "RTN","PRCH442",66,0) I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) D DYNAMSG "RTN","PRCH442",67,0) ; "RTN","PRCH442",68,0) W !,"End of processing." "RTN","PRCH442",69,0) K RLFLAG,PRCHPC,PRCS,^TMP($J) QUIT "RTN","PRCH442",70,0) ; "RTN","PRCH442",71,0) PROCESS1 ; "RTN","PRCH442",72,0) N PRCVDATE "RTN","PRCH442",73,0) S NCOST=0,CNNT=0,PRCVDATE="" "RTN","PRCH442",74,0) S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,0)),VENDOR=$P($G(^PRCS(410.3,XDA,1,IB,0)),"^",5) "RTN","PRCH442",75,0) I VENDOR="" Q "RTN","PRCH442",76,0) I VENDOR=WHSE,$G(SPEC)'=2 Q "RTN","PRCH442",77,0) I OUTRL=1 Q "RTN","PRCH442",78,0) I $G(RLFLAG) N ITMCKER S ITMCKER=0 D ITMCK K % Q:ITMCKER ;PRC*5.1*165 for item exclusion for no vendor contract# on Delivery Order "RTN","PRCH442",79,0) S IB=0 F S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,IB)) Q:IB="" D ITEM Q:OUTRL "RTN","PRCH442",80,0) Q:CNNT=0 "RTN","PRCH442",81,0) K PDA D SETUP^PRCH442A "RTN","PRCH442",82,0) I '$D(PDA) Q "RTN","PRCH442",83,0) S REQCT=REQCT+1,COSTTOT=COSTTOT+NCOST "RTN","PRCH442",84,0) W !,"Request ",$P($G(^PRC(442,PDA,0)),"^")," has been created." "RTN","PRCH442",85,0) W !,"The vendor for this request is: ",$P(VENDOR1,";")," " "RTN","PRCH442",86,0) W "(",$P(VENDOR1,";",2),")" "RTN","PRCH442",87,0) W !,"Total cost of request: $",$J(NCOST,0,2),!,"Total items on ",COMMENT," request: ",CNNT "RTN","PRCH442",88,0) QUIT "RTN","PRCH442",89,0) ITEM ; "RTN","PRCH442",90,0) S SS=$G(^PRCS(410.3,XDA,1,IB,0)) "RTN","PRCH442",91,0) I $G(RLFLAG)=1,$P(SS,"^",6)'="Y" Q "RTN","PRCH442",92,0) S ITEM=$P(SS,"^"),QTY=$P(SS,"^",2),EST=$P(SS,"^",4) "RTN","PRCH442",93,0) I '$D(^PRC(441,+ITEM,2,+VENDOR,0)) Q "RTN","PRCH442",94,0) S ZS0=$G(^PRC(441,ITEM,2,VENDOR,0)) "RTN","PRCH442",95,0) S ZS=$G(^PRC(441,ITEM,0)),NSN=$P(ZS,"^",5),BOC=$P(ZS,"^",10),FSC=$P(ZS,"^",3) "RTN","PRCH442",96,0) I SPEC=2 S BOC=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(ITEM),1,4)) S BOC=$S(BOC=1:2697,BOC=1:2698,BOC=8:2696,1:2699) "RTN","PRCH442",97,0) I BOC'="" S BOC=$P($G(^PRCD(420.2,BOC,0)),"^"),BOC=$E(BOC,1,30) "RTN","PRCH442",98,0) S SKU=$P($G(^PRC(441,ITEM,3)),"^",8) "RTN","PRCH442",99,0) S UCOST=$P(ZS0,"^",2),CONT=$P(ZS0,"^",3),VSTOCK=$P(ZS0,"^",4),NDC=$P(ZS0,"^",5),UOP=$P(ZS0,"^",7),PMULT=$P(ZS0,"^",8),MAX=$P(ZS0,"^",9),CONV=$P(ZS0,"^",10) "RTN","PRCH442",100,0) S:CONT'="" CONT=$P($G(^PRC(440,+VENDOR,4,CONT,0)),"^") "RTN","PRCH442",101,0) S CNNT=CNNT+1 "RTN","PRCH442",102,0) S AA(CNNT)=CNNT_"^"_QTY_"^"_UOP_"^"_BOC_"^"_ITEM_"^"_VSTOCK_"^"_UCOST_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV "RTN","PRCH442",103,0) ; enter item description from file "RTN","PRCH442",104,0) S CNNT1=$P($G(^PRC(441,ITEM,1,0)),"^",4) "RTN","PRCH442",105,0) I CNNT1'="" F J=1:1:CNNT1 S BB(CNNT,J)=$G(^PRC(441,ITEM,1,J,0)) "RTN","PRCH442",106,0) S TOTAL=QTY*UCOST,CC(CNNT)=TOTAL_"^"_CONT_"^"_FSC,NCOST=NCOST+TOTAL "RTN","PRCH442",107,0) ; "RTN","PRCH442",108,0) ; PRC*5.1*81 - save DM DOC ID and earliest DATE NEEDED BY, set any problems into ^TMP "RTN","PRCH442",109,0) I PRCVDYN D "RTN","PRCH442",110,0) . S $P(CC(CNNT),"^",15)=$P(^PRCS(410.3,XDA,1,IB,0),"^",7) ; DM DOC ID "RTN","PRCH442",111,0) . I $P(CC(CNNT),"^",15)']"" S ^TMP($J,"PRCVHMSG",XDA,ITEM)="" ; no DOCID "RTN","PRCH442",112,0) . I $P(SS,"^",8)>0,$P(SS,"^",8)0 S DA=+Y,PRCRI(440.5)=DA,PRCIEN=DA "RTN","PRCHUSER",9,0) N SITECHK S SITECHK=$P($G(^PRC(440.5,DA,2)),U,3) I +SITECHK'=0,SITECHK'=PRC("SITE") W !!,"This card is not entered for this station." H 3 G MORE "RTN","PRCHUSER",10,0) S DIE="^PRC(440.5,",DR="[PRCH PURCHASE CARD]" D ^DIE ;Q:$D(Y) "RTN","PRCHUSER",11,0) D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"70////P;71////"_DT) "RTN","PRCHUSER",12,0) K PRCHHLDR,PRCHAPP,PRCHALT,PRCHSING,PRCHMNTH "RTN","PRCHUSER",13,0) I '$G(DA) G Q "RTN","PRCHUSER",14,0) S DA(1)=DA S PRCHUSER=$P(^PRC(440.5,DA,0),U,8) "RTN","PRCHUSER",15,0) I $G(PRCHUSER),$G(PRCHORIG),PRCHUSER'=PRCHORIG D "RTN","PRCHUSER",16,0) . S DIK="^PRC(440.5,"_DA(1)_",1,",DA=PRCHORIG D ^DIK K Y,DIK "RTN","PRCHUSER",17,0) I $G(PRCHUSER),'$D(^PRC(440.5,DA,1,PRCHUSER)) D "RTN","PRCHUSER",18,0) . I '$G(^PRC(440.5,DA(1),1,0)) D "RTN","PRCHUSER",19,0) . . S $P(^PRC(440.5,DA(1),1,0),U,2)=$P(^DD(440.5,12,0),U,2) "RTN","PRCHUSER",20,0) . S DIE="^PRC(440.5,"_DA(1)_",1,",DA=PRCHUSER,DR=".01////^S X=PRCHUSER" "RTN","PRCHUSER",21,0) . D ^DIE "RTN","PRCHUSER",22,0) . S $P(^PRC(440.5,DA(1),1,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1 "RTN","PRCHUSER",23,0) . K DIE,DR,PRCHUSER "RTN","PRCHUSER",24,0) ;PRC*5.1*165 Text added to inform user that surrogates lookup/add will only "RTN","PRCHUSER",25,0) ; show those having access to FCP linked to PCard. "RTN","PRCHUSER",26,0) W !!,?25,"*** ATTENTION ***" "RTN","PRCHUSER",27,0) W !,?5,"Adding a new surrogate will now check surrogate name entered" "RTN","PRCHUSER",28,0) W !,?5,"for valid access to the Fund Control Point linked to the PCard." "RTN","PRCHUSER",29,0) W !,?5,"It will be possible to enter a name search and not find any" "RTN","PRCHUSER",30,0) W !,?5,"due to an invalid name entry or user name with no access to" "RTN","PRCHUSER",31,0) W !,?5,"Purchase Card FCP.",! "RTN","PRCHUSER",32,0) MORES S:'$D(DA(1)) DA(1)=DA S DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AELQ" "RTN","PRCHUSER",33,0) S DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)" D ^DIC "RTN","PRCHUSER",34,0) G:$D(DUOUT)!$D(DTOUT) Q G REPL:Y'>0 S DA=+Y "RTN","PRCHUSER",35,0) I $P(Y,U,3)'=1 D "RTN","PRCHUSER",36,0) . W !!?5,"Would you like to delete this surrogate user" S %=2 D YN^DICN "RTN","PRCHUSER",37,0) . Q:%<1!(%=2) "RTN","PRCHUSER",38,0) . S DA=+Y,DIK="^PRC(440.5,"_DA(1)_",1," "RTN","PRCHUSER",39,0) . D ^DIK K Y,DIK "RTN","PRCHUSER",40,0) G MORES "RTN","PRCHUSER",41,0) REPL ;REPLACEMENT CARD ENTRY "RTN","PRCHUSER",42,0) D NOW^%DTC S XNOW=X "RTN","PRCHUSER",43,0) K DIR "RTN","PRCHUSER",44,0) S PRCRPLO=$P($G(^PRC(440.5,PRCIEN,50)),U) "RTN","PRCHUSER",45,0) REPL1 S DIR("A")="REPLACED CARD: " S:PRCRPLO'="" DIR("B")=PRCRPLO S DIR("?")="Enter a valid card number for replaced card, 16 digits",DIR(0)="FAO^16:16" "RTN","PRCHUSER",46,0) D ^DIR G Q:$D(DIRUT)!$D(DTOUT) S PRCRPLN=X K DIR "RTN","PRCHUSER",47,0) I PRCRPLN'?1.N W " Must be 16 digits!!" G REPL1 "RTN","PRCHUSER",48,0) I PRCRPLO=PRCRPLN!'PRCRPLN G Q "RTN","PRCHUSER",49,0) S PRCRIENN=$O(^PRC(440.5,"B",PRCRPLN,0)) I 'PRCRIENN W " Not a valid Purchase Card number" G REPL "RTN","PRCHUSER",50,0) I $P(^PRC(440.5,PRCRIENN,2),U,2)'="Y" W " Replaced Card Must be INACTIVE" G REPL "RTN","PRCHUSER",51,0) S PRCIENP=$O(^PRC(440.5,"ARPC",PRCRPLN,0)) I PRCIENP W " Replaced Card already listed under card: ",$P(^PRC(440.5,PRCIENP,0),U) G REPL "RTN","PRCHUSER",52,0) S ERR="" D I ERR'="" W !," >> Replaced card does not match this card for: ",ERR G REPL "RTN","PRCHUSER",53,0) . S PRCUR0=^PRC(440.5,PRCIEN,0),PRCUR2=^PRC(440.5,PRCIEN,2),PRCRPL0=$G(^PRC(440.5,PRCRIENN,0)),PRCRPL2=$G(^PRC(440.5,PRCRIENN,2)) "RTN","PRCHUSER",54,0) . I $P(PRCUR0,U,8)'=$P(PRCRPL0,U,8) S ERR="CARD HOLDER" "RTN","PRCHUSER",55,0) . I $P(PRCUR0,U,2)'=$P(PRCRPL0,U,2) S:ERR'="" ERR=ERR_"," S ERR=ERR_"FUND CONTROL POINT" "RTN","PRCHUSER",56,0) . I $P(PRCUR0,U,3)'=$P(PRCRPL0,U,3) S:ERR'="" ERR=ERR_"," S ERR=ERR_"COST CENTER" "RTN","PRCHUSER",57,0) . I $P(PRCUR0,U,4)'=$P(PRCRPL0,U,4) S:ERR'="" ERR=ERR_"," S ERR=ERR_"BUDGET OBJECT CODE" "RTN","PRCHUSER",58,0) . I $P(PRCUR2,U,3)'=$P(PRCRPL2,U,3) S:ERR'="" ERR=ERR_"," S ERR=ERR_"STATION NUMBER" "RTN","PRCHUSER",59,0) K DIE S DIE="^PRC(440.5,",DA=PRCIEN,DR="51///^S X=PRCRPLN" D ^DIE K DIE,DA,DR "RTN","PRCHUSER",60,0) Q W !!?5,"Would you like to register another purchase card" S %=2 D YN^DICN "RTN","PRCHUSER",61,0) W ! G:%=1 MORE I %=0 W !!,"Please answer 'Yes' or 'No'" "RTN","PRCHUSER",62,0) K DLAYGO,DA,PRCRPLO,DIR,PRCRPLN,PRCIEN,PRCRIENN,PRCIENP,ERR,PRCUR0,PRCUR2,PRCRPL0,PRCRPL2,XNOW,DIRUT,DTOUT,DIK,DUOUT,DIROUT "RTN","PRCHUSER",63,0) QUIT "RTN","PRCHUSER",64,0) INPUT1 ;Input transform for File #440.5, Field #1 "RTN","PRCHUSER",65,0) S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" S DIC("S")="I $D(^PRC(420,""C"",PRCHHLDR,PRC(""SITE""),+Y))",D="B^C" D MIX^DIC1 K:Y<0 X K DIC,D "RTN","PRCHUSER",66,0) Q:'$D(X) S X=$P(Y(0),U) "RTN","PRCHUSER",67,0) Q "RTN","PRCSAPP") 0^3^B14893513^B13811690 "RTN","PRCSAPP",1,0) PRCSAPP ;WISC/KMB-NEW 2237 APPROVAL ; 10-27-93 12:00 "RTN","PRCSAPP",2,0) V ;;5.1;IFCAP;**165**;Oct 20, 2000;Build 12 "RTN","PRCSAPP",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSAPP",4,0) ;Patch PRC*5.1*165 adds a check @SETUP to insure station is not only defined "RTN","PRCSAPP",5,0) ; but has a value >0. "RTN","PRCSAPP",6,0) START ; "RTN","PRCSAPP",7,0) N APPREQ,MESSAGE,YY,XY,SPENDCP,ALL,LOOP,FOUND,PRCS1,%,AA,TEST,II,CPARRAY "RTN","PRCSAPP",8,0) N FND,CPVAR,STOP1,SLP,PRCSDA,PRCSI,CONT,LINE "RTN","PRCSAPP",9,0) S (FND,STOP1,TEST,FOUND,ALL,PRC("CP"))=0,XY="",AA=0,SPENDCP=0 "RTN","PRCSAPP",10,0) K CPCK S APPREQ=1 W !!,"Please wait while I check your control points..." D ^PRCSUT1 "RTN","PRCSAPP",11,0) I '$D(CPCK) W !,"You have no transactions ready for approval." Q "RTN","PRCSAPP",12,0) SETUP ; set up array of all cps user has access to "RTN","PRCSAPP",13,0) D STA^PRCSUT I $D(DIRUT)!($D(DUOUT)) K DIRUT,DUOUT Q "RTN","PRCSAPP",14,0) I '$D(PRC("SITE")) W !,$P($T(MESSAGE+1),";;",2) Q "RTN","PRCSAPP",15,0) I +$G(PRC("SITE"))'>0 W !,$P($T(MESSAGE+7),";;",2) G SETUP "RTN","PRCSAPP",16,0) S MESSAGE="" D ESIG^PRCUESIG(DUZ,.MESSAGE) I MESSAGE<1 W !,$P($T(MESSAGE+2),";;",2) Q "RTN","PRCSAPP",17,0) ; "RTN","PRCSAPP",18,0) S (AA,PRC("CP"))=0 F S PRC("CP")=$O(^PRC(420,"A",DUZ,PRC("SITE"),PRC("CP"))) Q:PRC("CP")="" D "RTN","PRCSAPP",19,0) .Q:$G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))="" "RTN","PRCSAPP",20,0) .I $P($G(^(0)),"^",19)'=1,$D(^PRC(420,"A",DUZ,PRC("SITE"),PRC("CP"),1)),$D(CPCK(PRC("CP"))) S CPARRAY(AA)=PRC("CP"),AA=AA+1 "RTN","PRCSAPP",21,0) D INQUIRE W !!,"***END OF PROCESSING***" D LINE K CPCK Q "RTN","PRCSAPP",22,0) INQUIRE ; "RTN","PRCSAPP",23,0) S %=1 W !,"Loop thru all control points" D YN^DICN Q:%=-1 S:%=1 ALL=1 I %=0 W !,$P($T(MESSAGE+3),";;",2),! H 1 G INQUIRE "RTN","PRCSAPP",24,0) INQUIRE1 ; "RTN","PRCSAPP",25,0) I %=2 W @IOF D LINE R !,"Select CONTROL POINT: ",XY:DTIME Q:XY["^"!(XY="") I XY'?1.N D SHOW G INQUIRE1 "RTN","PRCSAPP",26,0) F II=0:1:AA-1 S FOUND=0 Q:STOP1=-1 I $D(CPARRAY(II)) I (+XY=CPARRAY(II)!ALL=1) D PROCESS Q:STOP1=-1!(ALL=0) "RTN","PRCSAPP",27,0) I FOUND=0 S %=2 W !,$P($T(MESSAGE+4),";;",2),! D LINE H 2 G INQUIRE1 "RTN","PRCSAPP",28,0) Q "RTN","PRCSAPP",29,0) PROCESS ; "RTN","PRCSAPP",30,0) S FOUND=1,PRC("CP")=CPARRAY(II),CONT=0 "RTN","PRCSAPP",31,0) W @IOF D LINE "RTN","PRCSAPP",32,0) S %=1 W !!,"Loop thru all transactions for CP ",CPARRAY(II) D YN^DICN S:%=-1 STOP1=-1 Q:%=-1 I %=0 W !,$P($T(MESSAGE+5),";;",2),! H 1 G PROCESS "RTN","PRCSAPP",33,0) I %=1 G PROCESS2 "RTN","PRCSAPP",34,0) PROCESS1 ; "RTN","PRCSAPP",35,0) Q:CONT=1 D LOOKUP Q:(CONT=1) S:$D(Y) YY=+Y D CHECK G PROCESS1 "RTN","PRCSAPP",36,0) PROCESS2 ; "RTN","PRCSAPP",37,0) ; start here if all transactions selected "RTN","PRCSAPP",38,0) S CPVAR=PRC("SITE")_"-"_PRC("CP"),SLP="0-0-0" "RTN","PRCSAPP",39,0) F PRCSI=0:0 S SLP=$O(^PRCS(410,"F",CPVAR_"-"_$P(SLP,"-",3))) Q:$P(CPVAR,"-",1,2)'=$P(SLP,"-",1,2)!(SLP="") Q:STOP1=-1 S PRCSDA=$O(^PRCS(410,"F",SLP,0)) Q:PRCSDA'>0 I $D(^PRCS(410,PRCSDA,0)) D CHECK "RTN","PRCSAPP",40,0) I FND=0 W !,"No transactions found for this control point.",! D LINE "RTN","PRCSAPP",41,0) H 2 S FND=0 Q "RTN","PRCSAPP",42,0) CHECK ; "RTN","PRCSAPP",43,0) S:$D(YY) DA=YY S:$D(PRCSDA) DA=PRCSDA "RTN","PRCSAPP",44,0) Q:'$D(DA) S FND=1 D CHEC^PRCSAPP1 "RTN","PRCSAPP",45,0) ; if all checks are passed, go on for final approval "RTN","PRCSAPP",46,0) I SPENDCP=0 D FINAL^PRCSAPP2 "RTN","PRCSAPP",47,0) S SPENDCP=0 Q "RTN","PRCSAPP",48,0) LOOKUP ; "RTN","PRCSAPP",49,0) S PRCSID=1,PRC("CP")=CPARRAY(II),DIC="^PRCS(410,",DIC(0)="AEQ",D="F" "RTN","PRCSAPP",50,0) S DIC("S")="I +^(0)=PRC(""SITE""),+$P(^(0),""-"",4)=PRC(""CP""),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),PRC(""CP""),1))" "RTN","PRCSAPP",51,0) W @IOF D LINE "RTN","PRCSAPP",52,0) W !,$P($T(MESSAGE+6),";;",2),! "RTN","PRCSAPP",53,0) S DIC("A")="Select TRANSACTION: " D ^PRCSDIC K PRCSID,DIC,DIC("S"),DIC("A") "RTN","PRCSAPP",54,0) S:Y<0 CONT=1 Q "RTN","PRCSAPP",55,0) SHOW ; "RTN","PRCSAPP",56,0) W !,"Select from the following control points: ",! "RTN","PRCSAPP",57,0) F II=0:1:AA I $D(CPARRAY(II)) W !,?10,$P($G(^PRC(420,PRC("SITE"),1,CPARRAY(II),0)),"^") "RTN","PRCSAPP",58,0) H 4 "RTN","PRCSAPP",59,0) Q "RTN","PRCSAPP",60,0) LINE ; "RTN","PRCSAPP",61,0) W ! F LINE=1:1:53 W "_" "RTN","PRCSAPP",62,0) W !! Q "RTN","PRCSAPP",63,0) MESSAGE ; "RTN","PRCSAPP",64,0) ;;Please contact your ADP Site manager to grant system access. "RTN","PRCSAPP",65,0) ;;Contact your Site Manager for an electronic signature code. "RTN","PRCSAPP",66,0) ;;Enter Yes to loop thru all your CPs, No to select only one. "RTN","PRCSAPP",67,0) ;;Control Point has no transactions for approval! "RTN","PRCSAPP",68,0) ;;Enter yes or no "RTN","PRCSAPP",69,0) ;;Enter the last four digits,i.e.,'0094',of transaction number "RTN","PRCSAPP",70,0) ;;Please select site "UP",440.5,440.512,-1) 440.5^1 "UP",440.5,440.512,0) 440.512 "VER") 8.0^22.0 "^DD",440.5,440.5,12,0) SURROGATE USER^440.512P^^1;0 "^DD",440.5,440.5,12,21,0) ^.001^1^1^3111206^^^^ "^DD",440.5,440.5,12,21,1,0) This is the user who can also use this purchase card to order items. "^DD",440.5,440.512,0) SURROGATE USER SUB-FIELD^^.01^1 "^DD",440.5,440.512,0,"NM","SURROGATE USER") "^DD",440.5,440.512,.01,0) SURROGATE USER^M*P200'X^VA(200,^0;1^S DIC("S")="I $D(^PRC(420,PRC(""SITE""),1,+$P(^PRC(440.5,DA(1),0),U,2),1,+Y))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X S:+$G(X) DINUM=X "^DD",440.5,440.512,.01,1,0) ^.1 "^DD",440.5,440.512,.01,1,1,0) 440.512^B "^DD",440.5,440.512,.01,1,1,1) S ^PRC(440.5,DA(1),1,"B",$E(X,1,30),DA)="" "^DD",440.5,440.512,.01,1,1,2) K ^PRC(440.5,DA(1),1,"B",$E(X,1,30),DA) "^DD",440.5,440.512,.01,1,2,0) 440.5^C "^DD",440.5,440.512,.01,1,2,1) S ^PRC(440.5,"C",$E(X,1,30),DA(1),DA)="" "^DD",440.5,440.512,.01,1,2,2) K ^PRC(440.5,"C",$E(X,1,30),DA(1),DA) "^DD",440.5,440.512,.01,1,2,"DT") 2960509 "^DD",440.5,440.512,.01,3) Please enter an alternate purchase card user "^DD",440.5,440.512,.01,12) Cannot be surrogate if no access to PCard FCP "^DD",440.5,440.512,.01,12.1) S DIC("S")="I $D(^PRC(420,PRC(""SITE""),1,+$P(^PRC(440.5,DA(1),0),U,2),1,+Y))" "^DD",440.5,440.512,.01,21,0) ^.001^1^1^3111206^^^ "^DD",440.5,440.512,.01,21,1,0) A user who has the ability to act as a surrogate for the card holder. "^DD",440.5,440.512,.01,23,0) ^.001^1^1^3111206^^^ "^DD",440.5,440.512,.01,23,1,0) The surrogate MUST have access to the FCP linked to the Purchase Card. "^DD",440.5,440.512,.01,"AUDIT") "^DD",440.5,440.512,.01,"AX") "^DD",440.5,440.512,.01,"DT") 3120301 "BLD",7020,6) ^150 **END** **END**