source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRPL.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCHRPL ;SF/TKW,WISC/CLH-LOCAL PROCUREMENT PUBLIC LAW 100-322 REPORT ; 6/17/97 9:23 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 S PRCF("X")="SP" D ^PRCFSITE Q:'$D(PRC("SITE"))
6 ;
7EN10 S PRCHD="DATE",M="DATE RECEIVED" D RNG^PRCHRPT1 G Q:FR["^"!(TO["^") I FR["?"!(TO["?") W $C(7),!!,"Enter a beginning and ending RECEIPT DATE range for this report." G EN10
8 S PRCHNULL=0 I (FR["@")!(TO["@") S PRCHNULL=1 S:FR["@" FR="" S:TO["@" TO="z"
9 ;
10EN11 K PRCHQ S PRCHQ="EN2^PRCHRPL" D ^PRCHQUE
11 G Q
12 ;
13EN2 D NOW^%DTC S Y=% D DD^%DT S PRCHPDAT=Y K ^TMP($J) S PRCHSITE="** INVALID STATION **",X=$O(^PRC(411,"B",PRC("SITE"),0)) I $D(^PRC(411,+X,0)),$D(^DIC(4,+$P(^(0),U,10),0)) S PRCHSITE=$P(^(0),U,1)
14 S PRCHFT="ALL DATES" I FR S Y=FR D DD^%DT S PRCHFT=Y_" through "
15 S:'TO PRCHFT=PRCHFT_" LAST date" I TO S Y=TO D DD^%DT S PRCHFT=PRCHFT_Y
16 ;
17 ;**** NOTE: FSC CODES SELECTED ARE SET HERE--CAN BE CHANGED BY ADDING
18 ; OR DELETING FROM LIST IN ^TMP
19 ;
20 F I=65,66,73 S ^TMP($J,"FSCG",I)=$P($G(^PRC(441.3,+I,0)),U,2)
21 S (PRCHPO,PRCHCNT)=0 D RD
22 ;
23P S PRCHPAGE=0,PRCHDY=0 D EN^PRCHRPL1
24 W !,$C(13) D:$D(ZTSK) KILL^%ZTLOAD K ZTSK,ZTSKT
25 G Q
26 ;
27RD S PRCHPO=$O(^PRC(442,PRCHPO)) Q:'PRCHPO G:'$D(^(PRCHPO,0)) RD G:'$D(^(1)) RD S PRCH0=^(0),X=^(1) G:+PRCH0'=PRC("SITE") RD G:'$O(^PRC(442,PRCHPO,11,0)) RD G:"13478"'[($P(PRCH0,U,2)) RD
28 G:$P(X,U,18)="N" RD S PRCHDT=$P(X,U,15) G:PRCHDT]TO RD
29 S PRCHV=+X,PRCHRC=$P(X,U,19),PRCHEMG=$P(X,U,17),PRCHSRC=$P($G(^PRCD(420.8,+$P(X,U,7),0)),U,1)
30 G:PRCHRC="" RD S PRCHI=0 D RD1
31 G RD
32 ;
33RD1 S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)) Q:'PRCHI G:'$O(^(PRCHI,3,0)) RD1 S PRCHI0=^PRC(442,PRCHPO,2,PRCHI,0)
34 I PRCHSRC["B",$D(^PRC(442,PRCHPO,2,PRCHI,2)),$P(^(2),U,2)]"" G RD1
35 I $D(^PRC(442,PRCHPO,2,PRCHI,2)) S X=+$P(^(2),U,3) I $D(^TMP($J,"FSCG",$E(X,1,2))) S PRCHFSC=X S:'$D(^TMP($J,"FSC",X)) ^TMP($J,"FSC",X)=$P($G(^PRC(441.2,X,0)),U,2) S PRCHR=0 D RD2
36 G RD1
37 ;
38RD2 S PRCHR=$O(^PRC(442,PRCHPO,2,PRCHI,3,PRCHR)) Q:'PRCHR G:'$D(^(PRCHR,0)) RD2 S PRCHD0=^(0),PRCHRDT=$P(^(0),U,1) G:FR]PRCHRDT!(PRCHRDT]TO) RD2 D BLD
39 G RD2
40 ;
41BLD I '$D(^TMP($J,"V",PRCHV)) S:$D(^PRC(440,+PRCHV,0)) ^TMP($J,"V",PRCHV)=$P(^(0),U,1) S:'$D(^TMP($J,"V",PRCHV)) ^(PRCHV)="**INVALID VENDOR**"
42 S PRCHDESC="",PRCHDESC=$P($G(^PRC(441,+$P(PRCHI0,U,5),0)),U,2)
43 I PRCHDESC="" S X=$O(^PRC(442,PRCHPO,2,PRCHI,1,0)) I X,$D(^(X,0)) S PRCHDESC=^(0) ;$S($D(
44 S:PRCHDESC="" PRCHDESC="** MISSING ITEM DESCRIPTION **"
45 S PRCHCNT=PRCHCNT+1,PRCHTOT=$P(PRCHD0,U,3),(X,PRCHNIIN)=$P(PRCHI0,U,13) I X]"" S PRCHNIIN=$P(X,"-",2)_"-"_$P(X,"-",3)_"-"_$P(X,"-",4)
46 S ^TMP($J,"R",PRCHRC,PRCHFSC,$E(PRCHDESC,1,30),^TMP($J,"V",PRCHV),PRCHCNT)=$P($P(PRCH0,U,1),"-",2)_U_PRCHNIIN_U_$P(PRCHI0,U,15)_U_$P(PRCHD0,U,2)_U_$P(PRCHI0,U,9)_U_PRCHTOT_U_$P($P(PRCH0,U,3)," ",1)_U_PRCHEMG_U_PRCHSRC
47 S X=^TMP($J,"FSC",PRCHFSC),$P(X,U,2)=$P(X,U,2)+PRCHTOT
48 S ^TMP($J,"FSC",PRCHFSC)=X
49 I '$D(^TMP($J,"RC",PRCHRC)) S ^(PRCHRC)=0
50 S ^TMP($J,"RC",PRCHRC)=^(PRCHRC)+$P(PRCHD0,U,3)
51 I '$D(^TMP($J,"RC","FSC",PRCHFSC)) S ^(PRCHFSC)=0
52 S ^TMP($J,"RC","FSC",PRCHFSC)=^(PRCHFSC)+$P(PRCHD0,U,3)
53 I '$D(^TMP($J,"RC","FSC",PRCHRC,PRCHFSC)) S ^(PRCHFSC)=0
54 S ^TMP($J,"RC","FSC",PRCHRC,PRCHFSC)=^(PRCHFSC)+$P(PRCHD0,U,3)
55 Q
56 ;
57Q K %,%ZIS,IO("Q"),IOP,I,J,K,L,M,PRC,PRCF,PRCH0,PRCHCNT,PRCHD,PRCHD0,PRCHDESC,PRCHDET,PRCHDT,PRCHDY,PRCHEMG,PRCHFSC,PRCHFSCG,PRCHFT,PRCHGT,PRCHI,PRCHI0,PRCHNIIN,PRCHNULL
58 K PRCHPAGE,PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,ZTRTN,PRCHRC,^TMP($J),ZZI,ZZJ
59 Q
Note: See TracBrowser for help on using the repository browser.