- PRCHRPL ;SF/TKW,WISC/CLH-LOCAL PROCUREMENT PUBLIC LAW 100-322 REPORT ; 6/17/97 9:23 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN1 S PRCF("X")="SP" D ^PRCFSITE Q:'$D(PRC("SITE"))
- ;
- EN10 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
- S PRCHNULL=0 I (FR["@")!(TO["@") S PRCHNULL=1 S:FR["@" FR="" S:TO["@" TO="z"
- ;
- EN11 K PRCHQ S PRCHQ="EN2^PRCHRPL" D ^PRCHQUE
- G Q
- ;
- EN2 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)
- S PRCHFT="ALL DATES" I FR S Y=FR D DD^%DT S PRCHFT=Y_" through "
- S:'TO PRCHFT=PRCHFT_" LAST date" I TO S Y=TO D DD^%DT S PRCHFT=PRCHFT_Y
- ;
- ;**** NOTE: FSC CODES SELECTED ARE SET HERE--CAN BE CHANGED BY ADDING
- ; OR DELETING FROM LIST IN ^TMP
- ;
- F I=65,66,73 S ^TMP($J,"FSCG",I)=$P($G(^PRC(441.3,+I,0)),U,2)
- S (PRCHPO,PRCHCNT)=0 D RD
- ;
- P S PRCHPAGE=0,PRCHDY=0 D EN^PRCHRPL1
- W !,$C(13) D:$D(ZTSK) KILL^%ZTLOAD K ZTSK,ZTSKT
- G Q
- ;
- RD 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
- G:$P(X,U,18)="N" RD S PRCHDT=$P(X,U,15) G:PRCHDT]TO RD
- 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)
- G:PRCHRC="" RD S PRCHI=0 D RD1
- G RD
- ;
- RD1 S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)) Q:'PRCHI G:'$O(^(PRCHI,3,0)) RD1 S PRCHI0=^PRC(442,PRCHPO,2,PRCHI,0)
- I PRCHSRC["B",$D(^PRC(442,PRCHPO,2,PRCHI,2)),$P(^(2),U,2)]"" G RD1
- 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
- G RD1
- ;
- RD2 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
- G RD2
- ;
- BLD 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**"
- S PRCHDESC="",PRCHDESC=$P($G(^PRC(441,+$P(PRCHI0,U,5),0)),U,2)
- I PRCHDESC="" S X=$O(^PRC(442,PRCHPO,2,PRCHI,1,0)) I X,$D(^(X,0)) S PRCHDESC=^(0) ;$S($D(
- S:PRCHDESC="" PRCHDESC="** MISSING ITEM DESCRIPTION **"
- 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)
- 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
- S X=^TMP($J,"FSC",PRCHFSC),$P(X,U,2)=$P(X,U,2)+PRCHTOT
- S ^TMP($J,"FSC",PRCHFSC)=X
- I '$D(^TMP($J,"RC",PRCHRC)) S ^(PRCHRC)=0
- S ^TMP($J,"RC",PRCHRC)=^(PRCHRC)+$P(PRCHD0,U,3)
- I '$D(^TMP($J,"RC","FSC",PRCHFSC)) S ^(PRCHFSC)=0
- S ^TMP($J,"RC","FSC",PRCHFSC)=^(PRCHFSC)+$P(PRCHD0,U,3)
- I '$D(^TMP($J,"RC","FSC",PRCHRC,PRCHFSC)) S ^(PRCHFSC)=0
- S ^TMP($J,"RC","FSC",PRCHRC,PRCHFSC)=^(PRCHFSC)+$P(PRCHD0,U,3)
- Q
- ;
- Q 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
- K PRCHPAGE,PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,ZTRTN,PRCHRC,^TMP($J),ZZI,ZZJ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPL 3576 printed Mar 13, 2025@21:15:13 Page 2
- PRCHRPL ;SF/TKW,WISC/CLH-LOCAL PROCUREMENT PUBLIC LAW 100-322 REPORT ; 6/17/97 9:23 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- EN1 SET PRCF("X")="SP"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- +1 ;
- EN10 SET PRCHD="DATE"
- SET M="DATE RECEIVED"
- DO RNG^PRCHRPT1
- if FR["^"!(TO["^")
- GOTO Q
- IF FR["?"!(TO["?")
- WRITE $CHAR(7),!!,"Enter a beginning and ending RECEIPT DATE range for this report."
- GOTO EN10
- +1 SET PRCHNULL=0
- IF (FR["@")!(TO["@")
- SET PRCHNULL=1
- if FR["@"
- SET FR=""
- if TO["@"
- SET TO="z"
- +2 ;
- EN11 KILL PRCHQ
- SET PRCHQ="EN2^PRCHRPL"
- DO ^PRCHQUE
- +1 GOTO Q
- +2 ;
- EN2 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET PRCHPDAT=Y
- KILL ^TMP($JOB)
- SET PRCHSITE="** INVALID STATION **"
- SET X=$ORDER(^PRC(411,"B",PRC("SITE"),0))
- IF $DATA(^PRC(411,+X,0))
- IF $DATA(^DIC(4,+$PIECE(^(0),U,10),0))
- SET PRCHSITE=$PIECE(^(0),U,1)
- +1 SET PRCHFT="ALL DATES"
- IF FR
- SET Y=FR
- DO DD^%DT
- SET PRCHFT=Y_" through "
- +2 if 'TO
- SET PRCHFT=PRCHFT_" LAST date"
- IF TO
- SET Y=TO
- DO DD^%DT
- SET PRCHFT=PRCHFT_Y
- +3 ;
- +4 ;**** NOTE: FSC CODES SELECTED ARE SET HERE--CAN BE CHANGED BY ADDING
- +5 ; OR DELETING FROM LIST IN ^TMP
- +6 ;
- +7 FOR I=65,66,73
- SET ^TMP($JOB,"FSCG",I)=$PIECE($GET(^PRC(441.3,+I,0)),U,2)
- +8 SET (PRCHPO,PRCHCNT)=0
- DO RD
- +9 ;
- P SET PRCHPAGE=0
- SET PRCHDY=0
- DO EN^PRCHRPL1
- +1 WRITE !,$CHAR(13)
- if $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK,ZTSKT
- +2 GOTO Q
- +3 ;
- RD SET PRCHPO=$ORDER(^PRC(442,PRCHPO))
- if 'PRCHPO
- QUIT
- if '$DATA(^(PRCHPO,0))
- GOTO RD
- if '$DATA(^(1))
- GOTO RD
- SET PRCH0=^(0)
- SET X=^(1)
- if +PRCH0'=PRC("SITE")
- GOTO RD
- if '$ORDER(^PRC(442,PRCHPO,11,0))
- GOTO RD
- if "13478"'[($PIECE(PRCH0,U,2))
- GOTO RD
- +1 if $PIECE(X,U,18)="N"
- GOTO RD
- SET PRCHDT=$PIECE(X,U,15)
- if PRCHDT]TO
- GOTO RD
- +2 SET PRCHV=+X
- SET PRCHRC=$PIECE(X,U,19)
- SET PRCHEMG=$PIECE(X,U,17)
- SET PRCHSRC=$PIECE($GET(^PRCD(420.8,+$PIECE(X,U,7),0)),U,1)
- +3 if PRCHRC=""
- GOTO RD
- SET PRCHI=0
- DO RD1
- +4 GOTO RD
- +5 ;
- RD1 SET PRCHI=$ORDER(^PRC(442,PRCHPO,2,PRCHI))
- if 'PRCHI
- QUIT
- if '$ORDER(^(PRCHI,3,0))
- GOTO RD1
- SET PRCHI0=^PRC(442,PRCHPO,2,PRCHI,0)
- +1 IF PRCHSRC["B"
- IF $DATA(^PRC(442,PRCHPO,2,PRCHI,2))
- IF $PIECE(^(2),U,2)]""
- GOTO RD1
- +2 IF $DATA(^PRC(442,PRCHPO,2,PRCHI,2))
- SET X=+$PIECE(^(2),U,3)
- IF $DATA(^TMP($JOB,"FSCG",$EXTRACT(X,1,2)))
- SET PRCHFSC=X
- if '$DATA(^TMP($JOB,"FSC",X))
- SET ^TMP($JOB,"FSC",X)=$PIECE($GET(^PRC(441.2,X,0)),U,2)
- SET PRCHR=0
- DO RD2
- +3 GOTO RD1
- +4 ;
- RD2 SET PRCHR=$ORDER(^PRC(442,PRCHPO,2,PRCHI,3,PRCHR))
- if 'PRCHR
- QUIT
- if '$DATA(^(PRCHR,0))
- GOTO RD2
- SET PRCHD0=^(0)
- SET PRCHRDT=$PIECE(^(0),U,1)
- if FR]PRCHRDT!(PRCHRDT]TO)
- GOTO RD2
- DO BLD
- +1 GOTO RD2
- +2 ;
- BLD IF '$DATA(^TMP($JOB,"V",PRCHV))
- if $DATA(^PRC(440,+PRCHV,0))
- SET ^TMP($JOB,"V",PRCHV)=$PIECE(^(0),U,1)
- if '$DATA(^TMP($JOB,"V",PRCHV))
- SET ^(PRCHV)="**INVALID VENDOR**"
- +1 SET PRCHDESC=""
- SET PRCHDESC=$PIECE($GET(^PRC(441,+$PIECE(PRCHI0,U,5),0)),U,2)
- +2 ;$S($D(
- IF PRCHDESC=""
- SET X=$ORDER(^PRC(442,PRCHPO,2,PRCHI,1,0))
- IF X
- IF $DATA(^(X,0))
- SET PRCHDESC=^(0)
- +3 if PRCHDESC=""
- SET PRCHDESC="** MISSING ITEM DESCRIPTION **"
- +4 SET PRCHCNT=PRCHCNT+1
- SET PRCHTOT=$PIECE(PRCHD0,U,3)
- SET (X,PRCHNIIN)=$PIECE(PRCHI0,U,13)
- IF X]""
- SET PRCHNIIN=$PIECE(X,"-",2)_"-"_$PIECE(X,"-",3)_"-"_$PIECE(X,"-",4)
- +5 SET ^TMP($JOB,"R",PRCHRC,PRCHFSC,$EXTRACT(PRCHDESC,1,30),^TMP($JOB,"V",PRCHV),PRCHCNT)=$PIECE($PIECE(PRCH0,U,1),"-",2)_U_PRCHNIIN_U_$PIECE(PRCHI0,U,15)_U_$PIECE(PRCHD0,U,2)_U_$PIECE(PRCHI0,U,9)_U_PRCHTOT_U_$PIECE(...
- ... $PIECE(PRCH0,U,3)," ",1)_U_PRCHEMG_U_PRCHSRC
- +6 SET X=^TMP($JOB,"FSC",PRCHFSC)
- SET $PIECE(X,U,2)=$PIECE(X,U,2)+PRCHTOT
- +7 SET ^TMP($JOB,"FSC",PRCHFSC)=X
- +8 IF '$DATA(^TMP($JOB,"RC",PRCHRC))
- SET ^(PRCHRC)=0
- +9 SET ^TMP($JOB,"RC",PRCHRC)=^(PRCHRC)+$PIECE(PRCHD0,U,3)
- +10 IF '$DATA(^TMP($JOB,"RC","FSC",PRCHFSC))
- SET ^(PRCHFSC)=0
- +11 SET ^TMP($JOB,"RC","FSC",PRCHFSC)=^(PRCHFSC)+$PIECE(PRCHD0,U,3)
- +12 IF '$DATA(^TMP($JOB,"RC","FSC",PRCHRC,PRCHFSC))
- SET ^(PRCHFSC)=0
- +13 SET ^TMP($JOB,"RC","FSC",PRCHRC,PRCHFSC)=^(PRCHFSC)+$PIECE(PRCHD0,U,3)
- +14 QUIT
- +15 ;
- Q KILL %,%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
- +1 KILL PRCHPAGE,PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,ZTRTN,PRCHRC,^TMP($JOB),ZZI,ZZJ
- +2 QUIT
