| 1 | PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | RD ; READ THROUGH PURCHASE ORDERS (FILE 442) AND SELECT RECORDS FOR PRINTING FPDS REPORTS--BUILD ^TMP FILE TO PRINT,EXCLUDES IF,REQ AND ISSUES
|
|---|
| 6 | 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
|
|---|
| 7 | S X=+$P($G(^PRC(442,PRCHPOR,1)),U,15) G:+X<FR RD I TO>0 G:+X>TO RD
|
|---|
| 8 | I PRCHRPT=2 S Y=X D DD^%DT S PRCHPOD=Y
|
|---|
| 9 | S PRCHTOTA=$P(PRCHX,U,15),PRCHTOTL=+$P(PRCHX,U,14)
|
|---|
| 10 | 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
|
|---|
| 11 | I PRCHRPT=5 S X=$P(PRCHX,U,3) G:X="" RD G:(+X<PRCHFR) RD I PRCHTO>0 G:(+X>PRCHTO) RD
|
|---|
| 12 | 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
|
|---|
| 13 | G:(PRCHRPT=2)&(PRCHTOTA'>10000) RD G:(PRCHRPT=1)&(PRCHTOTA>10000) RD G:(PRCHRPT=3)&(PRCHTOTA>10000) RD
|
|---|
| 14 | K ^TMP($J,"TEST"),^TMP($J,"TEST2") S PRCHET=0,I=0 D RDT
|
|---|
| 15 | G RD
|
|---|
| 16 | ;
|
|---|
| 17 | RDT ; READ THROUGH 'TYPE CODES' FOR REPORT OPTIONS 1, 2 OR 3
|
|---|
| 18 | 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=" "
|
|---|
| 19 | I PRCHRPT=1 S X=$G(^PRCD(420.6,+$P(Y,U,2),0)),PRCHTYP=$P(X,U,1),PRCHTYPP=$P(X,U,2)
|
|---|
| 20 | 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
|
|---|
| 21 | 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
|
|---|
| 22 | 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
|
|---|
| 23 | G RDT
|
|---|
| 24 | ;
|
|---|
| 25 | 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
|
|---|
| 26 | S $P(Y,U,4)=$P(Y,U,4)+PRCHAMT,^TMP($J,"TEST",X)="",J=0 D:PRCHRPT=1 RDB
|
|---|
| 27 | Q
|
|---|
| 28 | ;
|
|---|
| 29 | RDB ; READ THROUGH 'BREAKOUT CODES' FOR REPORT OPTION 1
|
|---|
| 30 | S J=$O(^PRC(442,PRCHPOR,9,I,1,J)) Q:'J S K=+^(J,0)
|
|---|
| 31 | S L=$G(^PRCD(420.6,K,0)),PRCHBOUT=$P(L,U,1),PRCHBOU2=$P(L,U,2) S:PRCHBOUT="" PRCHBOUT=" "
|
|---|
| 32 | S:'$D(^TMP($J,"R","B",PRCHBOUT)) ^(PRCHBOUT)=PRCHBOU2 S K=^(PRCHBOUT)
|
|---|
| 33 | 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
|
|---|
| 34 | S $P(K,U,4)=$P(K,U,4)+PRCHAMT,^TMP($J,"TEST2",PRCHBOUT)="",^TMP($J,"R","B",PRCHBOUT)=K
|
|---|
| 35 | G RDB
|
|---|
