source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHFPD.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: 3.9 KB
Line 
1PRCHFPD ;SF-ISC/KSS,WISC/RWS,SC-NEW FPDS REPORT <25K ;7-10-89/2:30 PM
2V ;;5.1;IFCAP;**16**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5FPD S %DT("A")="START WITH P.O. DATE: ",%DT="AE" D ^%DT
6 I Y'>0 K %DT,Y Q
7 S PRCHF=Y,%DT("A")="GO TO P.O. DATE: "
8 ;
9F1 D ^%DT G FPD:Y'>0 I PRCHF>Y W !,"Last date cannot be prior to first date." G FPD
10 S PRCHT=Y D DD^%DT S PRCHPT=Y S Y=PRCHF D DD^%DT S PRCHPF=Y
11 G F2
12 ;
13INIT S PRCHN=0 K ^TMP("CN",$J)
14 F PRCHO=0:0 S PRCHN=$O(^PRCD(420.6,"B",PRCHN)) Q:PRCHN="" S (^TMP("CN",$J,PRCHN),^TMP("CN",$J,PRCHN,"A"))=0
15 Q
16 ;
17F2 K %DT,PRCHN,PRCHO
18 S DHD="[PRCH FPDS <25K HEADER]",DIOBEG="D INIT^PRCHFPD",L=0,FLDS="[PRCH FPDS <25K PRINT]",BY="[PRCH FPDS <25K]",FR=PRCHF_","_PRC("SITE")_"-,9,0",TO=PRCHT_","_PRC("SITE")_"z,,25000",DIC="^PRC(442,",DIOEND="D P^PRCHFPD" D EN1^DIP
19 ;
20FEND K ^TMP("CN",$J),^TMP("TOT",$J),PRCHF,PRCHI,PRCHG,PRCHN,PRCHP,PRCHPF,PRCHPT,PRCHQ,PRCHS,PRCHT,PRCHTN,PTCHTA,PRCHV,PRCHY
21 ;
22K K DIC,DHD,L,FLDS,BY,FR,TO
23 Q
24 ;
25P ;PRINT TOTALS FROM 'DIOEND' VARIABLE WITH PRINT TEMPLATE
26 F PRCHP="A","B","C","D","E","X","Y","Z" S ^TMP("TOT",$J,PRCHP)=0
27 S PRCHS=" $ # P.O. ",$P(PRCHG,"-",20)="- "
28 W !,"TOTALS:",!,?1,PRCHS,PRCHS,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
29 S (PRCHTN,PRCHTA)=0 F PRCHN=1:1:4 S ^TMP("CN",$J,"T"_PRCHN)=0,^TMP("CN",$J,"T"_PRCHN,"A")=0
30 F PRCHN=1:1:4 W !,?1 F PRCHP="A","B","C","D","E" D P3 D:PRCHP="E" P5
31 W !,?1,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG
32 W:IOST="C-" ?1
33 W:IOST'="C-" !,?1
34 F PRCHP="A","B","C","D","E" W "TOT NO.("_PRCHP_") ",$J(^TMP("TOT",$J,PRCHP),9)," "
35 W "A-E",$J(PRCHTA,11,2)," ",$J(PRCHTN,5)
36 W !!,?22,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
37 S (PRCHTN,PRCHTA)=0 F PRCHN=1:1:4 S ^TMP("CN",$J,"T"_PRCHN)=0,^TMP("CN",$J,"T"_PRCHN,"A")=0
38 F PRCHN=1:1:4 W !,?22 F PRCHP="X","Y","Z" D P3 D:PRCHP="Z" P5
39 W !,?22,PRCHG,PRCHG,PRCHG,PRCHG,!,?22 F PRCHP="X","Y","Z" W "TOT NO.("_PRCHP_") ",$J(^TMP("TOT",$J,PRCHP),9)," "
40 W "X-Z",$J(PRCHTA,11,2)," ",$J(PRCHTN,5)
41 S L="L" I ^TMP("CN",$J,"L")'=0 S ^("K")=^("K")+^("L"),L=^("L","A"),^("A")=^TMP("CN",$J,"K","A")+L,L=""
42 ;'I' category is being changed to 'T1' as per FPDS
43 ;W !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22 F PRCHP="I",L,"N","S" D P4
44 W !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22 F PRCHP="T1",L,"N","LV" D P4
45 W !,?22 F PRCHP="J","M","P","U" D P4
46 ;Removing Category K & leaving the format of report as is, at a later time we might re-use the position for future categories per FPDS --- SC
47 ;W !,?22 F PRCHP="K","O","Q","W" D P4
48 W !,?22 F PRCHP="","HP","O","W" D P4
49 W !,?22 F PRCHP="","HZ","RV","LW" D P4
50 W !,?22 F PRCHP="","","S","OO" D P4
51 ;
52PEND W @IOF Q
53 ;
54P3 S PRCHV=PRCHP_PRCHN,^TMP("TOT",$J,PRCHP)=^TMP("TOT",$J,PRCHP)+^TMP("CN",$J,PRCHV)
55 S ^TMP("CN",$J,"T"_PRCHN)=^TMP("CN",$J,"T"_PRCHN)+^TMP("CN",$J,PRCHV),^TMP("CN",$J,"T"_PRCHN,"A")=^TMP("CN",$J,"T"_PRCHN,"A")+^TMP("CN",$J,PRCHV,"A")
56 W PRCHV," ",$J(^TMP("CN",$J,PRCHV,"A"),11,2)," ",$J(^TMP("CN",$J,PRCHV),5)," "
57 Q
58 ;
59P4 I PRCHP="" W " " Q ;BLANK ANY CATEGORY WHERE CODE IS NULL
60 W $J(PRCHP,2)," ",$J(^TMP("CN",$J,PRCHP,"A"),11,2)," ",$J(^TMP("CN",$J,PRCHP),5)," "
61 Q
62 ;
63P5 W "T"_PRCHN," ",$J(^TMP("CN",$J,"T"_PRCHN,"A"),11,2)," ",$J(^TMP("CN",$J,"T"_PRCHN),5) S PRCHTN=PRCHTN+^TMP("CN",$J,"T"_PRCHN),PRCHTA=PRCHTA+^TMP("CN",$J,"T"_PRCHN,"A")
64 Q
65 ;
66CALC ;LOOP THRU AMOUNTS IN TEMPLATE (442)
67 S PRCHJ=0 F PRCHO=0:0 S PRCHJ=$O(^PRC(442,D0,9,PRCHJ)) Q:PRCHJ'>0 I $D(^(PRCHJ,0)) S PRCHX=^(0) D C1
68 K PRCHA,PRCHC,PRCHJ,PRCHK,PRCHL,PRCHO,PRCHX,PRCHY
69 ;
70CEND Q
71 ;
72C1 ;LOOP THRU CODES AND ADD TO ^TMP("CN",$J,ARRAY)
73 F PRCHK=2,4,5 S PRCHY=$P(PRCHX,U,PRCHK) D C2:PRCHY
74 ;LOOP THRU BREAKOUT CODES AND ADD TO ^TMP("CN",$J,ARRAY)
75 S PRCHL=0 F PRCHO=0:0 S PRCHL=$O(^PRC(442,D0,9,PRCHJ,1,PRCHL)) Q:PRCHL'>0 I $D(^(PRCHL,0)) S PRCHY=$P(^(0),U,1) D C2:PRCHY
76 Q
77 ;
78C2 Q:'$D(^PRCD(420.6,PRCHY,0))
79 S PRCHC=$P(^PRCD(420.6,PRCHY,0),U,1),^TMP("CN",$J,PRCHC)=^TMP("CN",$J,PRCHC)+1,PRCHA=$P(PRCHX,U,1),^TMP("CN",$J,PRCHC,"A")=^TMP("CN",$J,PRCHC,"A")+PRCHA
80 Q
Note: See TracBrowser for help on using the repository browser.