PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
RD ; READ THROUGH PURCHASE ORDERS (FILE 442) AND SELECT RECORDS FOR PRINTING FPDS REPORTS--BUILD ^TMP FILE TO PRINT,EXCLUDES IF,REQ AND ISSUES
S PRCHPOR=$O(^PRC(442,PRCHPOR)) Q:'PRCHPOR S PRCHX=$G(^(PRCHPOR,0)),PRCHPONO=$P(PRCHX,U,1) G:+PRCHX'=PRC("SITE") RD G:$P(PRCHX,U,2)'=25&($P(PRCHX,U,2)'<7) RD
S X=+$P($G(^PRC(442,PRCHPOR,1)),U,15) G:+X<FR RD I TO>0 G:+X>TO RD
I PRCHRPT=2 S Y=X D DD^%DT S PRCHPOD=Y
S PRCHTOTA=$P(PRCHX,U,15),PRCHTOTL=+$P(PRCHX,U,14)
I PRCHRPT=4 S:'$D(^TMP($J)) ^($J)="" S Y=U_($P(^($J),U,2)+1)_U_($P(^($J),U,3)+PRCHTOTL)_U_($P(^($J),U,4)+PRCHTOTA) S ^($J)=Y G RD
I PRCHRPT=5 S X=$P(PRCHX,U,3) G:X="" RD G:(+X<PRCHFR) RD I PRCHTO>0 G:(+X>PRCHTO) RD
I PRCHRPT=5 S:'$D(^TMP($J,"R","F",X)) ^(X)="" S Y=$P(^(X),U,1)_U_($P(^(X),U,2)+1)_U_($P(^(X),U,3)+PRCHTOTL)_U_($P(^(X),U,4)+PRCHTOTA) S ^(X)=Y G RD
G:(PRCHRPT=2)&(PRCHTOTA'>10000) RD G:(PRCHRPT=1)&(PRCHTOTA>10000) RD G:(PRCHRPT=3)&(PRCHTOTA>10000) RD
K ^TMP($J,"TEST"),^TMP($J,"TEST2") S PRCHET=0,I=0 D RDT
G RD
;
RDT ; READ THROUGH 'TYPE CODES' FOR REPORT OPTIONS 1, 2 OR 3
S I=$O(^PRC(442,PRCHPOR,9,I)) Q:'I S Y=^(I,0),PRCHAMT=+$P(Y,U,1),PRCHCON=$P(Y,U,3) G:(PRCHRPT=3)&(PRCHCON="") RDT S:PRCHCON="" PRCHCON=" "
I PRCHRPT=1 S X=$G(^PRCD(420.6,+$P(Y,U,2),0)),PRCHTYP=$P(X,U,1),PRCHTYPP=$P(X,U,2)
I PRCHRPT=1,PRCHTYP]"" S:'$D(^TMP($J,"R","T",PRCHTYP)) ^(PRCHTYP)=PRCHTYPP S Y=^(PRCHTYP),X=PRCHTYP D UPDU S ^TMP($J,"R","T",PRCHTYP)=Y G RDT
I PRCHRPT=2,PRCHPONO]"" S ^TMP($J,"R",PRCHPONO)=PRCHPOD_U_PRCHTOTL S:'$D(^TMP($J,"R",PRCHPONO,"C",PRCHCON)) ^(PRCHCON)="" S $P(^(PRCHCON),U,2)=$P(^(PRCHCON),U,2)+PRCHAMT G RDT
I PRCHRPT=3,PRCHCON]"" S:'$D(^TMP($J,"R","C",PRCHCON)) ^(PRCHCON)="" S Y=^(PRCHCON),X=PRCHCON D UPDU S ^TMP($J,"R","C",PRCHCON)=Y G RDT
G RDT
;
UPDU I '$D(^TMP($J,"TEST",X)) S $P(Y,U,2)=$P(Y,U,2)+1,$P(Y,U,3)=$P(Y,U,3)+PRCHTOTL
S $P(Y,U,4)=$P(Y,U,4)+PRCHAMT,^TMP($J,"TEST",X)="",J=0 D:PRCHRPT=1 RDB
Q
;
RDB ; READ THROUGH 'BREAKOUT CODES' FOR REPORT OPTION 1
S J=$O(^PRC(442,PRCHPOR,9,I,1,J)) Q:'J S K=+^(J,0)
S L=$G(^PRCD(420.6,K,0)),PRCHBOUT=$P(L,U,1),PRCHBOU2=$P(L,U,2) S:PRCHBOUT="" PRCHBOUT=" "
S:'$D(^TMP($J,"R","B",PRCHBOUT)) ^(PRCHBOUT)=PRCHBOU2 S K=^(PRCHBOUT)
I '$D(^TMP($J,"TEST2",PRCHBOUT)) S $P(K,U,2)=$P(K,U,2)+1,$P(K,U,3)=$P(K,U,3)+PRCHTOTL
S $P(K,U,4)=$P(K,U,4)+PRCHAMT,^TMP($J,"TEST2",PRCHBOUT)="",^TMP($J,"R","B",PRCHBOUT)=K
G RDB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT4 2594 printed Nov 22, 2024@17:20:37 Page 2
PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
RD ; READ THROUGH PURCHASE ORDERS (FILE 442) AND SELECT RECORDS FOR PRINTING FPDS REPORTS--BUILD ^TMP FILE TO PRINT,EXCLUDES IF,REQ AND ISSUES
+1 SET PRCHPOR=$ORDER(^PRC(442,PRCHPOR))
if 'PRCHPOR
QUIT
SET PRCHX=$GET(^(PRCHPOR,0))
SET PRCHPONO=$PIECE(PRCHX,U,1)
if +PRCHX'=PRC("SITE")
GOTO RD
if $PIECE(PRCHX,U,2)'=25&($PIECE(PRCHX,U,2)'<7)
GOTO RD
+2 SET X=+$PIECE($GET(^PRC(442,PRCHPOR,1)),U,15)
if +X<FR
GOTO RD
IF TO>0
if +X>TO
GOTO RD
+3 IF PRCHRPT=2
SET Y=X
DO DD^%DT
SET PRCHPOD=Y
+4 SET PRCHTOTA=$PIECE(PRCHX,U,15)
SET PRCHTOTL=+$PIECE(PRCHX,U,14)
+5 IF PRCHRPT=4
if '$DATA(^TMP($JOB))
SET ^($JOB)=""
SET Y=U_($PIECE(^($JOB),U,2)+1)_U_($PIECE(^($JOB),U,3)+PRCHTOTL)_U_($PIECE(^($JOB),U,4)+PRCHTOTA)
SET ^($JOB)=Y
GOTO RD
+6 IF PRCHRPT=5
SET X=$PIECE(PRCHX,U,3)
if X=""
GOTO RD
if (+X<PRCHFR)
GOTO RD
IF PRCHTO>0
if (+X>PRCHTO)
GOTO RD
+7 IF PRCHRPT=5
if '$DATA(^TMP($JOB,"R","F",X))
SET ^(X)=""
SET Y=$PIECE(^(X),U,1)_U_($PIECE(^(X),U,2)+1)_U_($PIECE(^(X),U,3)+PRCHTOTL)_U_($PIECE(^(X),U,4)+PRCHTOTA)
SET ^(X)=Y
GOTO RD
+8 if (PRCHRPT=2)&(PRCHTOTA'>10000)
GOTO RD
if (PRCHRPT=1)&(PRCHTOTA>10000)
GOTO RD
if (PRCHRPT=3)&(PRCHTOTA>10000)
GOTO RD
+9 KILL ^TMP($JOB,"TEST"),^TMP($JOB,"TEST2")
SET PRCHET=0
SET I=0
DO RDT
+10 GOTO RD
+11 ;
RDT ; READ THROUGH 'TYPE CODES' FOR REPORT OPTIONS 1, 2 OR 3
+1 SET I=$ORDER(^PRC(442,PRCHPOR,9,I))
if 'I
QUIT
SET Y=^(I,0)
SET PRCHAMT=+$PIECE(Y,U,1)
SET PRCHCON=$PIECE(Y,U,3)
if (PRCHRPT=3)&(PRCHCON="")
GOTO RDT
if PRCHCON=""
SET PRCHCON=" "
+2 IF PRCHRPT=1
SET X=$GET(^PRCD(420.6,+$PIECE(Y,U,2),0))
SET PRCHTYP=$PIECE(X,U,1)
SET PRCHTYPP=$PIECE(X,U,2)
+3 IF PRCHRPT=1
IF PRCHTYP]""
if '$DATA(^TMP($JOB,"R","T",PRCHTYP))
SET ^(PRCHTYP)=PRCHTYPP
SET Y=^(PRCHTYP)
SET X=PRCHTYP
DO UPDU
SET ^TMP($JOB,"R","T",PRCHTYP)=Y
GOTO RDT
+4 IF PRCHRPT=2
IF PRCHPONO]""
SET ^TMP($JOB,"R",PRCHPONO)=PRCHPOD_U_PRCHTOTL
if '$DATA(^TMP($JOB,"R",PRCHPONO,"C",PRCHCON))
SET ^(PRCHCON)=""
SET $PIECE(^(PRCHCON),U,2)=$PIECE(^(PRCHCON),U,2)+PRCHAMT
GOTO RDT
+5 IF PRCHRPT=3
IF PRCHCON]""
if '$DATA(^TMP($JOB,"R","C",PRCHCON))
SET ^(PRCHCON)=""
SET Y=^(PRCHCON)
SET X=PRCHCON
DO UPDU
SET ^TMP($JOB,"R","C",PRCHCON)=Y
GOTO RDT
+6 GOTO RDT
+7 ;
UPDU IF '$DATA(^TMP($JOB,"TEST",X))
SET $PIECE(Y,U,2)=$PIECE(Y,U,2)+1
SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+PRCHTOTL
+1 SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+PRCHAMT
SET ^TMP($JOB,"TEST",X)=""
SET J=0
if PRCHRPT=1
DO RDB
+2 QUIT
+3 ;
RDB ; READ THROUGH 'BREAKOUT CODES' FOR REPORT OPTION 1
+1 SET J=$ORDER(^PRC(442,PRCHPOR,9,I,1,J))
if 'J
QUIT
SET K=+^(J,0)
+2 SET L=$GET(^PRCD(420.6,K,0))
SET PRCHBOUT=$PIECE(L,U,1)
SET PRCHBOU2=$PIECE(L,U,2)
if PRCHBOUT=""
SET PRCHBOUT=" "
+3 if '$DATA(^TMP($JOB,"R","B",PRCHBOUT))
SET ^(PRCHBOUT)=PRCHBOU2
SET K=^(PRCHBOUT)
+4 IF '$DATA(^TMP($JOB,"TEST2",PRCHBOUT))
SET $PIECE(K,U,2)=$PIECE(K,U,2)+1
SET $PIECE(K,U,3)=$PIECE(K,U,3)+PRCHTOTL
+5 SET $PIECE(K,U,4)=$PIECE(K,U,4)+PRCHAMT
SET ^TMP($JOB,"TEST2",PRCHBOUT)=""
SET ^TMP($JOB,"R","B",PRCHBOUT)=K
+6 GOTO RDB
