source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1A3.m@ 634

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1PRCB1A3 ;WIOFO/DWA - CONTROL POINT LISTING W/COST CENTERS ;3/3/04 03:04 AM
2 ;;5.1;IFCAP;**76,74**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q ;invalid entry
5 ;
6EN1 ; entry point for CONTROL POINT LISTING W/COST CENTERS
7 N L,DIC,FLDS,BY,DHD
8 S L=0,DIC="^PRC(420,",FLDS="[PRCB CTRLPT]",BY=".01,1,1"
9 ;S DIS(0)="I $P(^PRC(420,D0,1,D1,0),""^"",19)'=1"
10 S DHD="CONTROL POINT LISTING W/ COST CENTERS PRINTED BY: "_$$USER^PRCPUREP(DUZ)
11 D EN1^DIP
12 Q
13 ;
14EN2 ; entry point for CONTROL POINT LISTING W/COST CENTER EXCEPTIONS
15 N STN,CP,CC,ACC,ACT,FUND,CPNAME,I,PAGE,LNCT,TODAY,EXC,CNT,RECORD
16 N CP1,CP2,FUND1,L,LN,LN1,SCREEN,DEV,ABORT,FLG,STN1,%ZIS,ZTDESC
17 N ZTRTN,ZTSAVE,X,Y,PAGE1
18 D NOW^%DTC S Y=% D DD^%DT S TODAY=Y KILL ^XTMP($J)
19 S (STN,CP,CC,ACC,ACT,FUND)=0,DEV=$J
20 F S STN=$O(^PRC(420,STN)) Q:'STN D
21 . S CP=0 F S CP=$O(^PRC(420,STN,1,CP)) Q:'CP!(CP=9999) D
22 . . S RECORD=$G(^PRC(420,STN,1,CP,0)) I RECORD="" Q
23 . . S FUND=$P(RECORD,"^",2) I 'FUND Q
24 . . S FUND=$P($G(^PRCD(420.3,FUND,0)),"^")
25 . . I (".0160.0162.0152.")'[("."_$E(FUND,1,4)_".") Q
26 . . S CPNAME=$P(RECORD,"^") ; format, nnn(n) xxxxx xxxx
27 . . S ACT=$P(RECORD,"^",19) ; 1=inactive
28 . . S ACC=$P($G(^PRC(420,STN,1,CP,5)),"^",3) ; pointer to ^PRCD(420.131,
29 . . S:'ACC ACC="NONE" D
30 . . . S:ACC'="NONE" ACC=$P($G(^PRCD(420.131,ACC,0)),"^")
31 . . . Q
32 . . S (CC,I)=0 F S CC=$O(^PRC(420,STN,1,CP,2,CC)) Q:'CC D
33 . . . D PROCESS
34 . . . I 'EXC Q
35 . . . S I=$G(I)+1
36 . . . S ^XTMP($J,"PRCCPE",STN,FUND,CP,I)=ACT_"^"_CPNAME_"^"_CC_"^"_ACC
37 . . . Q
38 . . Q
39 . Q
40 ;
41 S %ZIS="Q"
42 D ^%ZIS Q:POP
43 I $D(IO("Q")) D Q
44 . S ZTRTN="QUEUE^PRCB1A3"
45 . S ZTDESC="CONTROL POINT LISTING W/EXCEPTIONS"
46 . S ZTSAVE("TODAY")=""
47 . S ZTSAVE("DUZ")=""
48 . S ZTSAVE("DEV")=""
49 . D ^%ZTLOAD
50 . D HOME^%ZIS
51 . KILL ZTST,IO("Q")
52 ;
53QUEUE U IO
54 S (ABORT,PAGE,PAGE1,SCREEN)=0,LN1=45
55 I $E(IOST,1,2)="C-" S SCREEN=1
56 I SCREEN S LN1=17
57 D HDR
58 I SCREEN,IOSL>24 S PAGE1=1
59 ;
60 S (STN,STN1,CP,CC,ACC,ACT,FUND,FLG)=0
61 S (CP1,CP2,FUND1)=""
62 F S STN=$O(^XTMP(DEV,"PRCCPE",STN)) Q:'STN Q:ABORT D
63 . S FUND=0
64 . F S FUND=$O(^XTMP(DEV,"PRCCPE",STN,FUND)) Q:'FUND Q:ABORT D
65 . . S CP=0
66 . . F S CP=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP)) Q:'CP Q:ABORT D
67 . . . S CNT=0
68 . . . F S CNT=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)) Q:'CNT Q:ABORT D
69 . . . . S RECORD=^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)
70 . . . . S STATUS=$P(RECORD,U)
71 . . . . I STATUS=0 S STATUS="(ACTIVE)"
72 . . . . I STATUS=1 S STATUS="(INACTIVE)"
73 . . . . S CP1=$E($P(RECORD,U,2),1,20)
74 . . . . S CC=$P(RECORD,U,3)
75 . . . . S CC=$G(^PRCD(420.1,CC,0))
76 . . . . S CC=$E($P(CC,U),1,45)
77 . . . . S ACC=$P(RECORD,U,4)
78 . . . . I STN'=STN1 S FUND1=FUND W !!,STN,?6,FUND S LN=LN+1
79 . . . . I FUND'=FUND1 S CP2=CP1 W !!,?7,FUND,!,?9,CP1," ",STATUS S LN=LN+1
80 . . . . I CP1'=CP2 W !!,?9,CP1," ",STATUS S LN=LN+1
81 . . . . W !,?13,CC,?60,ACC S LN=LN+1
82 . . . . I STN'=STN1 S STN1=STN
83 . . . . I FUND'=FUND1 S FUND1=FUND
84 . . . . I CP1'=CP2 S CP2=CP1
85 . . . . I LN>LN1 D HDR:'PAGE1 Q:ABORT
86 ;
87 I 'ABORT W !!,"<End of Report>" R:SCREEN X:100
88 D ^%ZISC
89 Q
90 ;
91 ;--------------------------------------------------------------------
92PROCESS ; determine if exception exists
93 S EXC=0
94 ;
95 I $E(FUND,1,4)="0160" D
96 . I CC<820100 S EXC=1
97 . I CC>836400,CC<860100 S EXC=1
98 . I CC>860300,CC<875000 S EXC=1
99 . I CC>875200,CC<895900 S EXC=1
100 . I CC>895900,CC<899100 S EXC=1
101 . I CC>899600 S EXC=1
102 . I CC=824300 S EXC=1
103 . Q
104 ;
105 I $E(FUND,1,4)="0152" D
106 . I CC<800100 S EXC=1
107 . I CC>808300,CC<840100 S EXC=1
108 . I CC>847000,CC<860500 S EXC=1
109 . I CC>861700,CC<864900 S EXC=1
110 . I CC>866000,CC<895000 S EXC=1
111 . I CC>895900 S EXC=1
112 . I CC=863100 S EXC=0
113 . Q
114 ;
115 I $E(FUND,1,4)="0162" D
116 . I CC<850100 S EXC=1
117 . I CC>857500,CC<860400 S EXC=1
118 . I CC>860400,CC<862100 S EXC=1
119 . I CC>862300 S EXC=1
120 . I CC=824300 S EXC=0
121 . Q
122 ;
123 Q
124 ;
125 ;--------------------------------------------------------------
126HDR ;PRINT THE HEADER
127 I SCREEN,PAGE R !!,"Hit <RETURN> to continue, '^' to Exit ",X:100
128 ;
129 I SCREEN,X["^" S ABORT=1 Q
130 ;
131 S PAGE=$G(PAGE)+1
132 W #
133 W "CONTROL POINT LISTING W/EXCEPTIONS "
134 W "PRINTED BY: "_$$USER^PRCPUREP(DUZ)
135 W !," "_TODAY
136 W " PAGE ",PAGE
137 W !!,"STA# FUND"
138 W !," CONTROL POINT ACC"
139 W !," COST CENTER"
140 W ! F L=1:1:80 W "-"
141 S LN=8
142 Q
Note: See TracBrowser for help on using the repository browser.