PRCHRPT9 ;SF/TKW/WISC/CLH,AKS-PUBLIC LAW 100-322 REPORT ;3/19/93 16:41
V ;;5.1;IFCAP;*89*;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"
W !! S PRCHDET=0,%A="Print Detail Report as well as Summary ",%B="Answer 'YES' to if you wish to print the Detail Report as well as",%B(1)="the Summary, 'NO' if you wish to print ONLY the summary.",%=1 D YN^PRCFYN G:%=-1 Q S:%=1 PRCHDET=1
;
EN11 K PRCHQ S PRCHQ="EN2^PRCHRPT9" 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=99
I '$D(^TMP($J,"FSC")) D NONE^PRCHRPTA
I $D(^TMP($J,"FSC")) D:PRCHDET EN^PRCHRPTA S PRCHPAGE=0 D EN2^PRCHRPTA
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,PRCHEMG=$P(X,U,17),PRCHSRC=$P($G(^PRCD(420.8,+$P(X,U,7),0)),U,1)
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 $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,ITEMNO)="",UNIT=0
I $D(^PRC(441,+$P(PRCHI0,U,5),0)) S PRCHDESC=$P(^(0),U,2),ITEMNO=$P(^(0),U,1)
I $D(^PRC(442,PRCHPO,2,PRCHI,0)) S UNIT=$P(^(0),U,3) S:UNIT'="" UNIT=$G(^PRCD(420.5,UNIT,0)),UNIT=$P(UNIT,U) S:UNIT="" UNIT=0
I PRCHDESC="" S X=$O(^PRC(442,PRCHPO,2,PRCHI,1,0)) I X,$D(^(X,0)) S PRCHDESC=^(0)
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)
I X']"" S PRCHNIIN=0
S FLG=0 I PRCHSRC=2 S FLG=1
I PRCHSRC="B"&($P($G(^PRC(442,PRCHPO,2,PRCHI,2)),U,2)="") S FLG=1
I 'FLG D SUM Q
S X=$G(^TMP($J,"R",PRCHFSC,$E(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC))
S $P(X,U,2)=PRCHNIIN,$P(X,U,4)=$P(X,U,4)+$P(PRCHD0,U,2)
S $P(X,U,6)=$P(X,U,6)+PRCHTOT,$P(X,U,9)=PRCHSRC
S:$P(X,U,10)="" $P(X,U,10)=$P(PRCHI0,U,9)
I $P(PRCHI0,U,9)<$P(X,U,10) S $P(X,U,10)=$P(PRCHI0,U,9)
I $P(PRCHI0,U,9)>$P(X,U,11) S $P(X,U,11)=$P(PRCHI0,U,9)
S $P(X,U,12)=ITEMNO
S ^TMP($J,"R",PRCHFSC,$E(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC)=X D SUM
Q
;
SUM S X=^TMP($J,"FSC",PRCHFSC),$P(X,U,2)=$P(X,U,2)+PRCHTOT I 'FLG S ^TMP($J,"FSC",PRCHFSC)=X Q
I FLG S $P(X,U,3)=$P(X,U,3)+PRCHTOT S I=$S(PRCHEMG="Y":4,1:5),$P(X,U,I)=$P(X,U,I)+PRCHTOT S ^TMP($J,"FSC",PRCHFSC)=X
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
K PRCHPAGE,PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,ZTRTN,^TMP($J),FLG,PRCHTOTD,PRCHI0,PRCHNIIN,PRCHNULL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT9 4108 printed Nov 22, 2024@17:20:41 Page 2
PRCHRPT9 ;SF/TKW/WISC/CLH,AKS-PUBLIC LAW 100-322 REPORT ;3/19/93 16:41
V ;;5.1;IFCAP;*89*;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 WRITE !!
SET PRCHDET=0
SET %A="Print Detail Report as well as Summary "
SET %B="Answer 'YES' to if you wish to print the Detail Report as well as"
SET %B(1)="the Summary, 'NO' if you wish to print ONLY the summary."
SET %=1
DO YN^PRCFYN
if %=-1
GOTO Q
if %=1
SET PRCHDET=1
+3 ;
EN11 KILL PRCHQ
SET PRCHQ="EN2^PRCHRPT9"
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 ;**** NOTE: FSC CODES SELECTED ARE SET HERE--CAN BE CHANGED BY ADDING OR DELETING FROM LIST IN TMP
+4 FOR I=65,66,73
SET ^TMP($JOB,"FSCG",I)=$PIECE($GET(^PRC(441.3,+I,0)),U,2)
+5 SET (PRCHPO,PRCHCNT)=0
DO RD
+6 ;
P SET PRCHPAGE=0
SET PRCHDY=99
+1 IF '$DATA(^TMP($JOB,"FSC"))
DO NONE^PRCHRPTA
+2 IF $DATA(^TMP($JOB,"FSC"))
if PRCHDET
DO EN^PRCHRPTA
SET PRCHPAGE=0
DO EN2^PRCHRPTA
+3 WRITE !,$CHAR(13)
if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK,ZTSKT
+4 GOTO Q
+5 ;
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 PRCHEMG=$PIECE(X,U,17)
SET PRCHSRC=$PIECE($GET(^PRCD(420.8,+$PIECE(X,U,7),0)),U,1)
+3 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 $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
+2 GOTO RD1
+3 ;
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,ITEMNO)=""
SET UNIT=0
+2 IF $DATA(^PRC(441,+$PIECE(PRCHI0,U,5),0))
SET PRCHDESC=$PIECE(^(0),U,2)
SET ITEMNO=$PIECE(^(0),U,1)
+3 IF $DATA(^PRC(442,PRCHPO,2,PRCHI,0))
SET UNIT=$PIECE(^(0),U,3)
if UNIT'=""
SET UNIT=$GET(^PRCD(420.5,UNIT,0))
SET UNIT=$PIECE(UNIT,U)
if UNIT=""
SET UNIT=0
+4 IF PRCHDESC=""
SET X=$ORDER(^PRC(442,PRCHPO,2,PRCHI,1,0))
IF X
IF $DATA(^(X,0))
SET PRCHDESC=^(0)
+5 if PRCHDESC=""
SET PRCHDESC="** MISSING ITEM DESCRIPTION **"
+6 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)
+7 IF X']""
SET PRCHNIIN=0
+8 SET FLG=0
IF PRCHSRC=2
SET FLG=1
+9 IF PRCHSRC="B"&($PIECE($GET(^PRC(442,PRCHPO,2,PRCHI,2)),U,2)="")
SET FLG=1
+10 IF 'FLG
DO SUM
QUIT
+11 SET X=$GET(^TMP($JOB,"R",PRCHFSC,$EXTRACT(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC))
+12 SET $PIECE(X,U,2)=PRCHNIIN
SET $PIECE(X,U,4)=$PIECE(X,U,4)+$PIECE(PRCHD0,U,2)
+13 SET $PIECE(X,U,6)=$PIECE(X,U,6)+PRCHTOT
SET $PIECE(X,U,9)=PRCHSRC
+14 if $PIECE(X,U,10)=""
SET $PIECE(X,U,10)=$PIECE(PRCHI0,U,9)
+15 IF $PIECE(PRCHI0,U,9)<$PIECE(X,U,10)
SET $PIECE(X,U,10)=$PIECE(PRCHI0,U,9)
+16 IF $PIECE(PRCHI0,U,9)>$PIECE(X,U,11)
SET $PIECE(X,U,11)=$PIECE(PRCHI0,U,9)
+17 SET $PIECE(X,U,12)=ITEMNO
+18 SET ^TMP($JOB,"R",PRCHFSC,$EXTRACT(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC)=X
DO SUM
+19 QUIT
+20 ;
SUM SET X=^TMP($JOB,"FSC",PRCHFSC)
SET $PIECE(X,U,2)=$PIECE(X,U,2)+PRCHTOT
IF 'FLG
SET ^TMP($JOB,"FSC",PRCHFSC)=X
QUIT
+1 IF FLG
SET $PIECE(X,U,3)=$PIECE(X,U,3)+PRCHTOT
SET I=$SELECT(PRCHEMG="Y":4,1:5)
SET $PIECE(X,U,I)=$PIECE(X,U,I)+PRCHTOT
SET ^TMP($JOB,"FSC",PRCHFSC)=X
+2 QUIT
+3 ;
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
+1 KILL PRCHPAGE,PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,ZTRTN,^TMP($JOB),FLG,PRCHTOTD,PRCHI0,PRCHNIIN,PRCHNULL
+2 QUIT
