source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTCO1.m@ 1800

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

initial load of WorldVistAEHR

File size: 5.2 KB
RevLine 
[613]1DGPTCO1 ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm
2 ;;5.3;Registration;**136,383,432,696,729**;Aug 13, 1993;Build 59
3 ;
4EN D CHKCUR W ! D DATE
5 S DIC("A")="Generate PTF Census Status Report for Census date: ",DIC="^DG(45.86,",DIC(0)="AEMQ" S:Y]"" DIC("B")=Y
6 D ^DIC K DIC G ENQ:Y<0
7 S DGCN=+Y,DGCDT=+$P(Y,U,2)_".9" K DGCHOICE
8 D DIV^DGPTCO2 G ENQ:'$D(DGCHOICE("DIV"))
9 D STATUS^DGPTCO2 G ENQ:'$D(DGCHOICE("STATUS"))
10 S %ZIS="NQ" D ^%ZIS K %ZIS G ENQ:POP D DOQ G ENQ:POP S DGIOP=ION_";"_IOM_";"_IOSL
11 I 'DGQ D START G ENQ
12 S ZTRTN="START^DGPTCO1",ZTIO=DGIOP,ZTDESC="Census Status Report"
13 F X="DGCHOICE(","DGCDT","DGCN","DGIOP" S ZTSAVE(X)=""
14 D ^%ZTLOAD D ^%ZISC
15ENQ K DGQ,DHIT,DIOEND,DGC,DGCN,DGCDT,DGIOP,DGCHOICE,DIS
16 Q
17 ;
18START ; -- produce report
19 ;Lock global to prevent duplicate entries in Census Workfile
20 L +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5 I '$T D Q
21 .N DGPTMSG
22 .D BLDMSG^DGPTCR
23 .I $E(IOST,1,2)'="C-" D SNDMSG^DGPTCR,ENQ Q
24 .N DGPTLINE
25 .S DGPTLINE=0
26 .F S DGPTLINE=$O(DGPTMSG(DGPTLINE)) Q:'DGPTLINE W !,?5,DGPTMSG(DGPTLINE,0)
27 .Q
28 I '$D(^DG(45.85,"ACENSUS",DGCN)) D REGEN^DGPTCR
29 S DIC="^DG(45.85,",(BY,FLDS)="[DGPT WORKFILE]",L=0,FR=DGCN_",,@",TO=DGCN_",,"
30 I DGCHOICE("STATUS")'="All" S (FR,TO)=DGCN_",,"_DGCHOICE("STATUS")
31 S DIS(0)="D DIS^DGPTCO1",DHIT="D DHIT^DGPTCO1",DIOEND="D DIOEND^DGPTCO1"
32 S Y=$P(DGCDT,".") X ^DD("DD") S DHD="Census Status Report for "_Y
33 S IOP=DGIOP K DGC
34 D EN1^DIP,ENQ
35 L -^DG(45.85,"DGPT CENSUS REGEN WORKFILE")
36END Q
37 ;
38DIOEND ; -- logic called at end of rpt for totals
39 I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR G DIOENDQ:X="^"
40 N D,S,Z S D="",Z="zzzz",$P(DGLN,"-",81)="" D NOW^%DTC S Y=% X ^DD("DD")
41 W @IOF,?30,"Census Status Report",?59,Y,!!?26,"Division Summary Statistics",!
42 ;
43 F I=0:0 S D=$O(DGC(D)) Q:D="" D DIV S S="" F J=0:0 S S=$O(DGC(D,S)) Q:S="" S C=DGC(D,S) D PRT I $O(DGC(D,S))=Z D TOT Q
44 W !,DGLN,!
45 I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR
46DIOENDQ K C,DGLN Q
47 ;
48DIV ;
49 W !,DGLN
50 I D="TOT" W !!?5,"OVERALL STATISTICS:" Q
51 W:$D(^DG(40.8,+D,0)) !?5,$P(^(0),U),":"
52 Q
53 ;
54TOT ;
55 W !?10,$S(D="TOT":"Grand Total: ",1:"Division Total: "),?30,$J(DGC(D,Z),4)
56 Q
57 ;
58PRT ;
59 W !?10,S,": ",?30,$J(C,4)
60 S:D'="TOT" DGC("TOT",S)=$S($D(DGC("TOT",S)):DGC("TOT",S),1:0)+C,DGC("TOT",Z)=$S($D(DGC("TOT",Z)):DGC("TOT",Z),1:0)+C
61 Q
62 ;
63DIS ; -- $T logic for each entry
64 N X S X=^DG(45.85,D0,0)
65 I DGCHOICE("DIV")=1 G DISQ
66 I $D(DGCHOICE("DIV",$S($D(^DIC(42,+$P(X,U,6),0)):+$P(^(0),U,11),1:0)))
67DISQ Q
68 ;
69DHIT ; -- logic called for each entry printed cum stats; DGC(div,status)
70 N D,S,Z S Z="zzzz" D STATUS
71 S S=X,D=$S($D(^DIC(42,+$P(^DG(45.85,D0,0),U,6),0)):+$P(^(0),U,11),1:0)
72 S DGC(D,S)=$S($D(DGC(D,S)):DGC(D,S),1:0)+1,DGC(D,Z)=$S($D(DGC(D,Z)):DGC(D,Z),1:0)+1
73 Q
74 ;
75FIND ; -- find CENSUS rec#
76 ; input: D0 := ifn of 45.85
77 ; output: X := status ; DGCI := census ifn ; PTF := ptf ifn
78 ;
79 S DGCI="",X=0,Y=$S($D(^DG(45.85,D0,0)):^(0),1:"")
80 G FINDQ:'Y S PTF=+$P(Y,U,12)
81 F DGCI=0:0 S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=+$P(Y,U,4) S X=+$P(^(0),U,6) Q
82FINDQ Q
83 ;
84STATUS ; -- compute CENSUS status
85 D FIND S X=$P($P($P(^DD(45,6,0),U,3),X_":",2),";")
86 K DGCI,PTF,Y Q
87 ;
88CREC ; -- compute CENSUS rec#
89 D FIND S X=DGCI
90 K DGCI,PTF,Y Q
91 ;
92DATE ; -- calculate default census date
93 S Y=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")
94 X:Y]"" ^DD("DD")
95 Q
96DOQ ;-- check if output device is queued. if not ask
97 S DGQ=0
98 I $D(IO("Q")) S DGQ=1 G DOQT
99 I IO=IO(0) G DOQT
100 S DIR(0)="Y",DIR("A")="DO YOU WANT YOUR OUTPUT QUEUED",DIR("B")="YES"
101 D ^DIR
102 I Y S DGQ=1
103DOQT ;
104 K Y,DIR
105 Q
106CHKCUR ; -- checks if new PTF Census Date record is needed
107 N DGIEN,DGCLOSE,DGACT,ERR
108 S DGIEN=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"")
109 S DGIEN=$O(^DG(45.86,"B",+$G(DGIEN),0))
110 S ERR=0
111 I 'DGIEN S ERR=1 D ERR Q
112 ; look at last census closeout date
113 S DGCLOSE=$P($G(^DG(45.86,DGIEN,0)),U,2)
114 I 'DGCLOSE S ERR=1 D ERR Q
115 I $P($G(^DG(45.86,DGIEN,0)),U)<3070930 D
116 . I $E(DGCLOSE,6,7)'=19 S ERR=1
117 E I $E(DGCLOSE,6,7)'=14 S ERR=1
118 S DGACT=$P($G(^DG(45.86,DGIEN,0)),U,4)
119 I 'DGACT S ERR=1
120 I ERR D ERR Q
121 I DT>DGCLOSE D ADDREC
122 Q
123ADDREC ; -- add new record
124 N DA,DIE,DR,DGYR,DGMONTH,DGSTRT,DGENDT,ERR,FDA,IEN696,ERR696
125 ; first inactivate last record
126 S DA=DGIEN,DIE="^DG(45.86,",DR=".04////0" D ^DIE
127 S DGYR=$E(DGCLOSE,1,3)
128 ; create new record depending on last closeout date (month)
129 S DGMONTH=$E(DGCLOSE,4,5)
130 I DGMONTH>"00",DGMONTH<"04" S DGSTRT=DGYR_"0101",DGENDT=DGYR_"0331",DGCLOSE=DGYR_"0414"
131 I DGMONTH>"03",DGMONTH<"07" S DGSTRT=DGYR_"0401",DGENDT=DGYR_"0630",DGCLOSE=DGYR_"0714"
132 I DGMONTH>"06",DGMONTH<"10" S DGSTRT=DGYR_"0701",DGENDT=DGYR_"0930",DGCLOSE=DGYR_"1014"
133 I DGMONTH>"09",DGMONTH<"13" S DGSTRT=DGYR_"1001",DGENDT=DGYR_"1231",DGYR=DGYR+1,DGCLOSE=DGYR_"0114"
134 ;S DIC="^DG(45.86,",X=DGENDT,DIC(0)="" K DO D FILE^DICN K DIC
135 ;I Y'>0 S ERR=1 D ERR Q
136 ;S DIE="^DG(45.86,",DA=+Y,DR=".02////"_DGCLOSE_";.03////2970331;.04////1;.05////"_DGSTRT
137 ;D ^DIE K DIE,DR,DA
138 S FDA(696,45.86,"?+1,",.01)=DGENDT
139 S FDA(696,45.86,"?+1,",.02)=DGCLOSE
140 S FDA(696,45.86,"?+1,",.03)=2970331
141 S FDA(696,45.86,"?+1,",.04)=1
142 S FDA(696,45.86,"?+1,",.05)=DGSTRT
143 D UPDATE^DIE("","FDA(696)","IEN696","ERR696")
144 I $D(ERR696) S ERR=1 D ERR
145 Q
146ERR ;
147 D BMES^XPDUTL("Problem with PTF CENSUS DATE File (#45.86).")
148 D BMES^XPDUTL("Please notify your Supervisor !!.")
149 Q
150 ;
Note: See TracBrowser for help on using the repository browser.