source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRAT9.m@ 846

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

initial load of WorldVistAEHR
File size: 4.1 KB
RevLine 
[613]1PRCHRAT9 ;SF/TKW/WISC/CLH-PUBLIC LAW 100-322 REPORT ;12/15/94 3:51 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 S PRCF("X")="SP" D ^PRCFSITE Q:'$D(PRC("SITE"))
6 ;
7EN10 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.",!,"No '@' allowed." G EN10
8 I (FR["@")!(TO["@") W !,"Entering '@' is not allowed." G EN10
9 I FR="" S FR=2000101
10 I TO="z" D NOW^%DTC S TO=X K %,%H,%I,X
11 S DIR(0)="Y",DIR("A")="Do you want to transmit P.L. 100-322 report to Austin",DIR("B")="NO" D ^DIR G:$D(DIRUT) Q G:Y=0 Q
12 K DTOUT S %DT="AERS",%DT(0)="NOW",%DT("A")="Please enter the date/time to start the P.L. 100-322 report. ",%DT("B")="NOW" D ^%DT G:Y'>0 Q G:$D(DTOUT) Q
13 ;
14EN11 S ZTIO="",ZTRTN="EN2^PRCHRAT9",ZTDESC="Build and transmit P.L. 100-322 report",ZTDTH=Y,ZTSAVE("DUZ")=""
15 S ZTSAVE("FR")="",ZTSAVE("TO")="",ZTSAVE("PRC(""SITE"")")="",ZTSAVE("PRC(""PER"")")="",ZTSAVE("U")="",ZTREQ="@" D ^%ZTLOAD
16 G Q
17 ;
18EN2 G:$$S^%ZTLOAD Q
19 D NOW^%DTC S Y=% D DD^%DT S PRCHPDAT=Y K ^TMP($J)
20 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)
21 ;**** NOTE: FSC CODES SELECTED ARE SET HERE--CAN BE CHANGED BY ADDING OR DELETING FROM LIST IN TMP
22 F I=65,66,73 S ^TMP($J,"FSCG",I)=$P($G(^PRC(441.3,+I,0)),U,2)
23 S (PRCHPO,PRCHCNT)=0 D RD G:$$S^%ZTLOAD Q
24 ;
25P N COUNTER S COUNTER=1 D IFC^PRCHRATA,RH^PRCHRATA,EN^PRCHRATA,EN2^PRCHRATA,EN3^PRCHRATA
26 D KILL^%ZTLOAD K ZTSK,ZTSKT
27 G Q
28 ;
29RD 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
30 G:$P(X,U,18)="N" RD S PRCHDT=$P(X,U,15) G:PRCHDT]TO RD
31 S PRCHV=+X,PRCHEMG=$P(X,U,17),PRCHSRC=$P($G(^PRCD(420.8,+$P(X,U,7),0)),U,1)
32 S PRCHI=0 D RD1
33 G RD
34 ;
35RD1 S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)) Q:'PRCHI G:'$O(^(PRCHI,3,0)) RD1 S PRCHI0=^PRC(442,PRCHPO,2,PRCHI,0)
36 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
37 G RD1
38 ;
39RD2 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 G:$$S^%ZTLOAD Q
40 ;
41BLD 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**"
42 S (PRCHDESC,ITEMNO)="",UNIT=0
43 I $D(^PRC(441,+$P(PRCHI0,U,5),0)) S PRCHDESC=$P(^(0),U,2),ITEMNO=$P(^(0),U,1)
44 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="XX"
45 I PRCHDESC="" S X=$O(^PRC(442,PRCHPO,2,PRCHI,1,0)) I X,$D(^(X,0)) S PRCHDESC=^(0)
46 S:PRCHDESC="" PRCHDESC="** MISSING ITEM DESCRIPTION **"
47 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)
48 I X']"" S PRCHNIIN=0
49 S FLG=0 I PRCHSRC=2 S FLG=1
50 I PRCHSRC="B"&($P($G(^PRC(442,PRCHPO,2,PRCHI,2)),U,2)="") S FLG=1
51 I 'FLG D SUM Q
52 S X=$G(^TMP($J,"R",PRCHFSC,$E(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC))
53 S $P(X,U,2)=PRCHNIIN,$P(X,U,4)=$P(X,U,4)+$P(PRCHD0,U,2)
54 S $P(X,U,6)=$P(X,U,6)+PRCHTOT,$P(X,U,9)=PRCHSRC
55 S:$P(X,U,10)="" $P(X,U,10)=$P(PRCHI0,U,9)
56 I $P(PRCHI0,U,9)<$P(X,U,10) S $P(X,U,10)=$P(PRCHI0,U,9)
57 I $P(PRCHI0,U,9)>$P(X,U,11) S $P(X,U,11)=$P(PRCHI0,U,9)
58 S $P(X,U,12)=ITEMNO
59 S ^TMP($J,"R",PRCHFSC,$E(PRCHDESC,1,30),UNIT,PRCHNIIN,PRCHSRC)=X D SUM
60 Q
61 ;
62SUM S X=^TMP($J,"FSC",PRCHFSC),$P(X,U,2)=$P(X,U,2)+PRCHTOT I 'FLG S ^TMP($J,"FSC",PRCHFSC)=X Q
63 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
64 Q
65 ;
66Q K %,%DT,%ZIS,DIR,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
67 K PRCHPDAT,PRCHPO,PRCHQ,PRCHR,PRCHRDT,PRCHSITE,PRCHSRC,PRCHT,PRCHTOT,PRCHV,X,Y,ZTRTN,^TMP($J),FLG,PRCHTOTD
68 Q
Note: See TracBrowser for help on using the repository browser.