source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRPT4.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5RD ; 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 ;
17RDT ; 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 ;
25UPDU 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 ;
29RDB ; 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
Note: See TracBrowser for help on using the repository browser.