Changeset 636 for FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (15 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 16 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m (modified) (1 diff)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m (modified) (7 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m (modified) (3 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m (modified) (4 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m (modified) (3 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m (modified) (2 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m (modified) (3 diffs)
-
IFCAP-PRC-PRX--PRCA--PRCN/PRCST5.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m
r628 r636 1 1 PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300 2 V ;;5.1;IFCAP; **114**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS 5 5 D:$D(ZTQUEUED) KILL^%ZTLOAD 6 S PRCFNAME=$S(PRCFASYS["CLM CLIRRLOG":"FEE/FEN, Receiving Reports & LOG",PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")6 S PRCFNAME=$S(PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG") 7 7 L +^PRCF(423,0):5 I '$T S X="Code Sheet file unavailable - File lock timeout.*" D MSG^PRCFQ Q 8 8 W:$D(IOF) @IOF W PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT" D NOW^PRCFQ W ?IOM-$L(%X),%X -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m
r628 r636 1 1 PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20 2 V ;;5.1;IFCAP; **114**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 A S PRCHLOG="",PRCFASYS="LOGDLA" Q 5 5 B K PRCHLOG,PRCFASYS Q … … 24 24 PURGE ;PURGE CODE SHEETS 25 25 D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q 26 PURGE2 ;PURGE ALL CODE SHEETS27 W !!,"** YOU MUST SELECT A DESIGNATED PRINTER FOR PURGE TO FUNCTION PROPERLY."28 W !,"** DEFAULTING TO HOME DEVICE (0) WILL NOT PURGE DATA SINCE THE OPTION WILL BE "29 W !,"** TASKED.",!30 S PRCFASYS="CLMCLIRRLOGDLAPHAGSA" D EN^PRCFACPR,B Q31 26 ADD ;ADD CODE SHEET TO PRINTED BATCH 32 27 D A,ADD^PRCFACR2,B Q -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m
r628 r636 1 1 PRCHEF ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;6/10/97 9:34 2 V ;;5.1;IFCAP; **107**;Oct 20, 2000;Build 133 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; 5 5 EN80 ;DELETE A RECEIVING REPORT (CONT.FROM PRCHE) … … 7 7 I $P($G(^PRC(442,PRCHPO,23)),U,11)="S"!($P($G(^(23)),U,11)="P") W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for purchase card orders.",! G EN80 8 8 I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for delivery orders.",! G EN80 9 I X<25!(X>33) W $C(7)," Receiving Report cannot be deleted, please create an adjustment voucher." G EN809 I X<25!(X>33) W $C(7)," ??" G EN80 10 10 I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN80 11 11 D LCK1^PRCHE G:'$D(DA) EN80 S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1 -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m
r628 r636 1 1 PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07 2 ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 REQ N PRCHREQ 2 ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 REQ ;Req. 5 N PRCHREQ 5 6 S PRCHREQ=1 6 PO N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT 7 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J 7 PO ;PO 8 N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON 9 N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT 10 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND 11 N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J 8 12 N PRCFL,MSG 9 13 LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0 10 ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments 14 ; 15 ; See routine PRCHAMXA for information on variable PRCHNORE and for 16 ; incidence of undefined DIK variable errors. 17 ; The var PRCHPO is the basic premise of locks applied to amendments. 18 ; Anytime amend module is accessed add +lock & save po# in PRCENTRY. 19 ; 11 20 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) 12 ; Lock simultaneous entry of users in amend. module for the same record. Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start 21 ; 22 ; Lock simultaneous entry of users in amend. module for the same record. 23 ; Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start 13 24 ; the process(AMENDNO) of amending the record we must have var PRCHPO. 25 ; 14 26 S PRCFL=0 15 27 W !! D GETPO^PRCHAMU 16 ; If no record is selected or time-out or up-arrow out then exit without unlocking a record. 28 ; If no record is selected or time-out or up-arrow out then exit 29 ; without unlocking a record. 17 30 I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1 18 31 I PRCFL=1 G LOOP … … 33 46 . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q 34 47 . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q 48 ; 35 49 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 36 50 I $D(DTOUT)!($D(DUOUT)) G EXIT 37 51 I $G(NOCAN)=1 G ASK 38 52 G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT 39 CAN1 S BFLAG=0 40 S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1 41 I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6 D 42 .S THISHLD=0 43 .F S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D 44 ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 45 .Q:BFLAG=1 46 .S THISHLD=0 47 .F S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D 48 ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 49 W:BFLAG=0 !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",! 50 G:BFLAG=0 EXIT 51 D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT 53 CAN1 D UPDATE^PRCHAMU G:$D(Y) EXIT 52 54 CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT 53 55 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D … … 66 68 ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2 67 69 ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2 68 ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered 70 ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to 71 ...; make sure that a contract number is entered 69 72 ...D PCD^PRCHMA1 70 73 ...Q … … 72 75 .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1 73 76 .Q 77 ;PRC*5.1*100: check line items without an FSC or PSC 74 78 D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT 75 79 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER="" 76 80 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1 77 81 I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER) 82 ; 83 ; Change below to allow checks for monthly limits in file #440.5 before 84 ; completion of the amendment. 85 ; 78 86 I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE 79 87 .D ^PRCHSF3 … … 107 115 .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE 108 116 .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 109 .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either 110 .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a 117 .; 118 .; Update file #440.5 after amendment has been approved. Consider orders 119 .; created and amended in the same month and year and the user either 120 .; cancels the order or enters other type of amendment that changes the 121 .; final amount of the order. No credit is given for orders from a 111 122 .; previous month and year. DT is the current date, system-supplied. 123 .; 112 124 .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8) 113 125 .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3) … … 132 144 S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1 133 145 I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 146 ; 134 147 D SOURCE^PRCHAMU:$G(SCE) 135 148 G EXIT 136 ENC S ER=0 149 ; 150 ENC ;Can 151 S ER=0 137 152 D CAN^PRCHMA3 138 153 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q … … 149 164 S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W ! 150 165 QUIT 151 APP S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN 166 APP ;App,pr 167 S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN 152 168 Q 153 REV N PRCH 169 REV ;Rev 170 N PRCH 154 171 S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN 155 172 I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM 156 173 Q 157 EXIT L -^PRC(442,PRCENTRY) 174 EXIT ;Ex 175 L -^PRC(442,PRCENTRY) 158 176 EXIT1 K ERROR,FIS,REPO,DEL 159 177 QUIT:$G(PRCPROST) 160 178 I $G(OUT)'=1 G LOOP 161 179 QUIT 162 FLAG I $G(FLAG)=1 K FLAG Q 180 ; 181 FLAG ; 182 I $G(FLAG)=1 K FLAG Q 163 183 Q 164 NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 184 NOSIGN ; 185 S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 165 186 NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@" 166 187 D ^DIE K DIE,DA,DR -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m
r628 r636 1 1 PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm 2 V ;;5.1;IFCAP; *112*;Oct 20, 2000;Build 23 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; 5 5 S PRCHSZ=1 … … 35 35 D SPRMK^PRCHNPO6 36 36 ; 37 N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 38 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) 39 F Q:'$F(PRCHX,",,") S PRCHX=$P(PRCHX,",,",1)_","_$P(PRCHX,",,",2,99) ; *112 remove consecutive commas 40 S:$E(PRCHX)="," PRCHX=$E(PRCHX,2,$L(PRCHX)) ; *112 remove leading comma 41 S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) ; *112 remove trailing comma 37 N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) 42 38 F I=1:1 S X=$P(PRCHX,",",I) Q:X="" I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX) S $P(PRCHX,",",I)=X(1)_":1:"_X(2) 43 39 I '$D(PRCHX) W " ??",$C(7) G N 44 X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J40 S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J 45 41 ; 46 42 3 G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K W !?3,PRCHSIT(K) … … 89 85 Q 90 86 ; 91 VENMSG ;mes sage to alert users that vendors don't match and that IMF will87 VENMSG ;mesasge to alert users that vendors don't match and that IMF will 92 88 ;be updated. 93 89 W !!,"NOTE-Vendors on PO and 2237 don't match. If you proceed IMF info"," will be used. If there is no IMF entry for the item for this vendor one will ","be created." -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m
r628 r636 1 1 PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00 10:59 2 V ;;5.1;IFCAP; **113**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; 5 5 EN1 ;FILE 442, FCP #1 … … 17 17 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 18 18 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 19 I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q20 19 Q 21 20 ; -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m
r628 r636 1 1 PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30 2 V ;;5.1;IFCAP; **113**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; 5 5 EN1 ;FILE 443.6, FCP #1 … … 15 15 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 16 16 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 17 I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q18 17 Q 19 18 ; -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m
r628 r636 1 1 PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96 21:40 2 ;;5.1;IFCAP; **113**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ASKPO ;Ask If they are processing a purchase or a requisition 5 5 N DIR,Y,PRCHPR,PRCHNE … … 83 83 K DA,%A,%B,% 84 84 QUIT 85 AOCANPC ;Approving Official Cancel a purchase card order86 N DIC,Y,NREC,X87 W ! S DIC="^PRC(442,",DIC(0)="AEQM"88 S DIC("A")="Select PURCHASE CARD ORDER NUMBER: "89 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))"90 D ^DIC Q:+Y<0 K DIC91 S %A="Are sure you want to cancel this order",%B="",%=292 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q93 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR94 D C2237^PRCH442A95 K DA,%A,%B,%96 QUIT -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m
r628 r636 1 1 PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27 2 ;;5.1;IFCAP;**63 ,114**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.2 ;;5.1;IFCAP;**63**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 HE ;Set up Heading segment 5 5 N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y … … 95 95 . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U) 96 96 . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1 97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA, 2,PRCA,5)),U,2)97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2) 98 98 . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^" 99 99 . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m
r628 r636 1 1 PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm 2 V ;;5.1;IFCAP;**83,98 ,112**;Oct 20, 2000;Build 22 V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;External reference to $$GET1^DIQ(4, is supported by ICR# 100905 ; *112 changes by: VMP, Holloway,T.6 4 ; 7 5 ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0 … … 105 103 ; 106 104 S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS) 107 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=$J(%,0,2) 105 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 106 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=% 108 107 ;Std. Turnover 109 108 S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1) 110 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=$J(%,0,2) 109 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 110 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=% 111 111 ;ODI Turnover 112 112 S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2) 113 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=$J(%,0,2) 113 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 114 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=% 114 115 ;All Turnover 115 116 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL")) … … 127 128 ; 128 129 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 129 I %="" S %=0 130 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=$J(%,0,2) 130 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 131 I %="" S %=0 132 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=% 131 133 ;Std. Inactive % 132 134 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 133 I %="" S %=0 134 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=$J(%,0,2) 135 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 136 I %="" S %=0 137 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=% 135 138 ;ODI Inactive % 136 139 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 137 I %="" S %=0 138 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=$J(%,0,2) 140 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 141 I %="" S %=0 142 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=% 139 143 ;All Inactive % 140 144 ; … … 158 162 ; 159 163 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 160 I %="" S %=0 161 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=$J(%,0,2) 164 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 165 I %="" S %=0 166 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=% 162 167 ;Std. Long Supply % 163 168 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 164 I %="" S %=0 165 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=$J(%,0,2) 169 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 170 I %="" S %=0 171 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=% 166 172 ;ODI Long Supply % 167 173 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 168 I %="" S %=0 169 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=$J(%,0,2) 174 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 175 I %="" S %=0 176 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=% 170 177 ;All Long Supply % 171 178 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL")) -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m
r628 r636 1 1 PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91 2 V ;;5.1;IFCAP;**1,83 ,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;**1,83**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; enter distribution point--input variables: 5 5 ; prcp("dptype")=distribution point type code [W,P,S] … … 20 20 I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q 21 21 ; 22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$ G(PRCP(I)) S %=1 Q22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q 23 23 I '% D DISPLAY Q 24 24 ; … … 101 101 ; 102 102 ; 103 PARAM(INVPT) ; set up parameters for inventory point103 PARAM(INVPT) ; set up parameters for inventory point 104 104 K PRCP 105 105 N DATA -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m
r628 r636 1 1 PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46 2 V ;;5.1;IFCAP; **107**;Oct 20, 2000;Build 133 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U 5 5 W !,"JUSTIFICATION OF NEED OR TURN-IN" … … 15 15 W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA) 16 16 N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28) 17 I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'> 5W " (",$P(^(.13),U,2),")"17 I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" 18 18 N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30) 19 19 W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m
r628 r636 1 1 PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53 2 V ;;5.1;IFCAP;**95 ,107**;Oct 20, 2000;Build 132 V ;;5.1;IFCAP;**95**;Oct 20, 2000 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 I '$D(^PRCS(410,DA,"RM",0)) G DEL … … 24 24 K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA) 25 25 N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31) 26 I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'> 5W " (",$P(^(.13),U,2),")"26 I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" 27 27 K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33) 28 28 W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m
r628 r636 1 1 PRCSP1A ;WISC/SAW/BGJ-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;5/1/92 9:20 AM [2/18/99 9:02am] 2 V ;;5.1;IFCAP;**90**;Oct 20, 2000 2 ;;5.1;IFCAP;**90**;Oct 20, 2000;Build 4 3 ;Modified from FOIA VISTA, 4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 5 ;General Public License See attached copy of the License. 6 ; 7 ;This program is free software; you can redistribute it and/or modify 8 ;it under the terms of the GNU General Public License as published by 9 ;the Free Software Foundation; either version 2 of the License, or 10 ;(at your option) any later version. 11 ; 12 ;This program is distributed in the hope that it will be useful, 13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;GNU General Public License for more details. 16 ; 17 ;You should have received a copy of the GNU General Public License along 18 ;with this program; if not, write to the Free Software Foundation, Inc., 19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 3 20 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 21 CPB ;CP BAL … … 60 77 HDR2 S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P,! Q 61 78 HOLD G HDR:$E(IOST,1,2)'="C-" 62 CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)& &('$D(C1))) D HDR79 CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)&('$D(C1))) D HDR 63 80 Q 64 81 CTR ;CEILING TRANS -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m
r628 r636 1 1 PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm 2 V ;;5.1;IFCAP;**13,81,101 ,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.2 V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; 5 5 ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be … … 33 33 SV ; 34 34 I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC 35 G EXIT:$D(ZTQUEUED) 35 36 ;patch *81 -DynaMed trx. is not allowed to be re-used 36 37 N PRCVSY,PRCVID … … 38 39 I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0) 39 40 I PRCVSY=1,PRCVID=1 G CHK1 40 G EXIT:$D(ZTQUEUED)41 41 U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV 42 42 CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS -
FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCST5.m
r628 r636 1 PRCST5 ; GENERATED FROM 'PRCS APPROVE REQUEST' PRINT TEMPLATE (#299) ; 11/15/05; (FILE 410, MARGIN=80)1 PRCST5 ; GENERATED FROM 'PRCS APPROVE REQUEST' PRINT TEMPLATE (#299) ; 04/11/06 ; (FILE 410, MARGIN=80) 2 2 G BEGIN 3 3 N W !
Note:
See TracChangeset
for help on using the changeset viewer.
