source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMG2E2.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.8 KB
RevLine 
[613]1PXRMG2E2 ;SLC/JVS -GEC #2 EXTRACT #2 ;7/14/05 08:32
2 ;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
3 Q
4 ;
5 ;Variables
6 ;CNTREF=The unique counted Referral number
7 ;DA =DA or Ien of the Health Factor
8 ;REF =REFERRAL NUMBER
9 ;ARY =Array that is ordering through
10 Q
11EN ;Entry Point
12 ;SEND IN
13 ;BDT,EDT,QUARTER
14 ;-----TEMPORARY-----
15 ;K ^TMP("PXRMGEC",$J)
16 ;-----TEMPORARY-----
17 N CR1,CR2,CR3,CR4,CRITER,FOUND,CNT,ARY
18 N M1,M2,M3,BDTEDT
19 ;---TEMPORARY
20 ;S QUARTER=1
21 ;---TEMORARY
22 S CRITER=0,FOUND=0,CNT=0
23 D PROGRAM^PXRMG2E4,CRITER4^PXRMG2E3
24 I $D(YEAR),$D(QUARTER) D
25 .S BDTEDT=$$FMDATE(YEAR,QUARTER)
26 .S BDT=$P(BDTEDT,"^",1)
27 .S EDT=$P(BDTEDT,"^",2)
28 ;
29 D E^PXRMG2E1("HS",1,BDT,EDT,"F",DFNONLY,TPAT)
30 K VDOC
31 ;This creates the following array besides the HS array
32 ;TMP("PXRMGEC",$J,"GEC2",CNTREF,DA,AGE FLAG,APPOINTMENTS,MONTH)=""
33 ;
34 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
35 S REF=0 F S REF=$O(@ARY@(REF)) Q:REF<1 D
36 .I QUARTER=1 S M1=1,M2=2,M3=3
37 .I QUARTER=2 S M1=4,M2=5,M3=6
38 .I QUARTER=3 S M1=7,M2=8,M3=9
39 .I QUARTER=4 S M1=10,M2=11,M3=12
40 .D PRE(REF)
41 D POST
42 Q
43 ;======================================
44FMDATE(YEAR,QUARTER) ;Get BDT and EDT from year and quarter
45 Q:YEAR=""
46 Q:QUARTER=""
47 Q:QUARTER>4
48 Q:QUARTER=0
49 N YER,QAR,BDT,EDT
50 S YER=YEAR-1700
51 I QUARTER=1 S BDT=YER_"0101",EDT=YER_"0331"
52 I QUARTER=2 S BDT=YER_"0401",EDT=YER_"0630"
53 I QUARTER=3 S BDT=YER_"0701",EDT=YER_"0930"
54 I QUARTER=4 S BDT=YER_"1001",EDT=YER_"1231"
55 Q BDT_"^"_EDT
56 ;======================================
57GET(REF) ;Get Criteria
58 N DFN,MONTH,NAME,SSN,PROG
59 S (CR1,CR2,CR3,CR4,CRITER)=0
60 S CR1=$$C1^PXRMG2S1(REF)
61 S CR2=$$C2^PXRMG2S1(REF)
62 S CR3=$$C3^PXRMG2S1(REF)
63 S CR4=$$C4^PXRMG2S1(REF)
64 S DFN=$P(CR4,"^",2)
65 S MONTH=$P(CR4,"^",3)
66 S NAME=$P(^DPT(DFN,0),"^",1)
67 S SSN=$P(CR4,"^",4)
68 S DATE=$P(CR4,"^",5)
69 S PROG=$P(CR4,"^",6)
70 S CR4=+CR4
71 I CR1=1 S CRITER="1"
72 I CR2=1 S CRITER=$S(CRITER=0:2,1:CRITER_",2")
73 I CR3=1 S CRITER=$S(CRITER=0:3,1:CRITER_",3")
74 I CR4=1 S CRITER=$S(CRITER=0:4,1:CRITER_",4")
75 S ^TMP("PXRMGEC",$J,"GEC2","RPT",NAME,SSN,DATE,CRITER,PROG)=""
76 Q CRITER
77 ;
78PRE(REF) ;Pre Process array by Program and Month
79 N ARY
80 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
81 I $D(@ARY@(REF,$O(P441(0)))),$D(@ARY@(REF,$O(P449(0)))) D
82 .S @ARY@("ADHC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
83 I $D(@ARY@(REF,$O(P4410(0)))),$D(@ARY@(REF,$O(P449(0)))) D
84 .S @ARY@("HHHA",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
85 I $D(@ARY@(REF,$O(P4412(0)))),$D(@ARY@(REF,$O(P449(0)))) D
86 .S @ARY@("VAIHR",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
87 I $D(@ARY@(REF,$O(P451(0)))),$D(@ARY@(REF,$O(P452(0)))) D
88 .S @ARY@("CC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
89 Q
90 ;
91MONTH(REF,ARY) ;Get month out of array
92 Q:REF=""
93 Q:ARY=""
94 N IEN,AGE,APP,DFN,MON
95 S IEN=$O(@ARY@(REF,0))
96 S AGE=$O(@ARY@(REF,IEN,-1))
97 S APP=$O(@ARY@(REF,IEN,AGE,-1))
98 S DFN=$O(@ARY@(REF,IEN,AGE,APP,0))
99 S MON=$O(@ARY@(REF,IEN,AGE,APP,DFN,0))
100 Q MON
101 ;
102PIECE(CRITER) ;Get the piece in the array the criter goes into
103 N PIECE
104 I CRITER=0 S PIECE=5
105 I CRITER=1 S PIECE=6
106 I CRITER=2 S PIECE=7
107 I CRITER=3 S PIECE=8
108 I CRITER=4 S PIECE=9
109 I CRITER="1,2" S PIECE=10
110 I CRITER="1,3" S PIECE=11
111 I CRITER="1,4" S PIECE=12
112 I CRITER="2,3" S PIECE=13
113 I CRITER="2,4" S PIECE=14
114 I CRITER="3,4" S PIECE=15
115 I CRITER="1,2,3" S PIECE=16
116 I CRITER="1,2,4" S PIECE=17
117 I CRITER="1,3,4" S PIECE=18
118 I CRITER="2,3,4" S PIECE=19
119 I CRITER="1,2,3,4" S PIECE=20
120 Q PIECE
121 ;
122POST ;Set the Statistical Arrays
123 D START
124 N PROG,MON,REF,PIE,MONX,SITE,STOP,ARY,X,Y
125 S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
126 S PROG="ADH" F S PROG=$O(@ARY@(PROG)) Q:PROG="" D
127 .S MON=0 F S MON=$O(@ARY@(PROG,MON)) Q:MON="" D
128 ..Q:MON'=M1&(MON'=M2)&(MON'=M3)
129 ..S CNT=0
130 ..S REF=0 F S REF=$O(@ARY@(PROG,MON,REF)) Q:REF="" D
131 ...S CNT=CNT+1
132 ...S PIE=0 F S PIE=$O(@ARY@(PROG,MON,REF,PIE)) Q:PIE="" D
133 ....I MON=1!(MON=4)!(MON=7)!(MON=10) S MONX=1
134 ....I MON=2!(MON=5)!(MON=8)!(MON=11) S MONX=2
135 ....I MON=3!(MON=6)!(MON=9)!(MON=12) S MONX=3
136 ....S Y=$P($G(STAT(PROG,MONX)),",",PIE)
137 ....S Y=Y+1,$P(STAT(PROG,MONX),",",PIE)=Y
138 ....S $P(STAT(PROG,MONX),",",2)=MON
139 ....S $P(STAT(PROG,MONX),",",4)=CNT
140 Q
141 ;
142START ; Start the STAT(PROG,MON) ARRAYS
143 N I,SITE,F,S,T
144 I QUARTER=1 S F=1,S=2,T=3
145 I QUARTER=2 S F=4,S=5,T=6
146 I QUARTER=3 S F=7,S=8,T=9
147 I QUARTER=4 S F=10,S=11,T=12
148 S SITE=$P($$SITE^VASITE,"^",3)
149 F I=1:1:3 S STAT("ADHC",I)=SITE_",,"_"ADHC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
150 .I I=1 S $P(STAT("ADHC",I),",",2)=F
151 .I I=2 S $P(STAT("ADHC",I),",",2)=S
152 .I I=3 S $P(STAT("ADHC",I),",",2)=T
153 F I=1:1:3 S STAT("HHHA",I)=SITE_",,"_"HHHA"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
154 .I I=1 S $P(STAT("HHHA",I),",",2)=F
155 .I I=2 S $P(STAT("HHHA",I),",",2)=S
156 .I I=3 S $P(STAT("HHHA",I),",",2)=T
157 F I=1:1:3 S STAT("CC",I)=SITE_",,"_"CC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
158 .I I=1 S $P(STAT("CC",I),",",2)=F
159 .I I=2 S $P(STAT("CC",I),",",2)=S
160 .I I=3 S $P(STAT("CC",I),",",2)=T
161 F I=1:1:3 S STAT("VAIHR",I)=SITE_",,"_"VAIHR"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
162 .I I=1 S $P(STAT("VAIHR",I),",",2)=F
163 .I I=2 S $P(STAT("VAIHR",I),",",2)=S
164 .I I=3 S $P(STAT("VAIHR",I),",",2)=T
165 Q
166WRITE ;Write to screen the STAT array
167 N PROG,MON
168 W !,"An Email containing this information will be sent to all those who are listed"
169 W !,"in the ""G.GEC2 NATIONAL ROLLUP"" mail group",!
170 S PROG="AD" F S PROG=$O(STAT(PROG)) Q:PROG="" D
171 .S MON=0 F S MON=$O(STAT(PROG,MON)) Q:MON="" D
172 ..W !,$G(STAT(PROG,MON))
173 W !!,"The above information is a statistical compilation of the"
174 W !,"information seen in the local view of this option."
175 W !!,"Thanks in advance",!!
176 D MAIL^PXRMG2M1
177 D EXIT
178 Q
179 ;=================================================
180EXIT ;Exit and Clean up Variables
181 K C1101,C1107,C1108
182 K C1410,C1412,C1414,C142,C144,C146,C148,C166,C171
183 K C2110,C2114,C2118,C212,C2120,C214,C216,C218,C221,C224,C226
184 K C2710,C272,C274,C276,C278,C286
185 K P441,P4410,P4412,P449,P451,P452
186 K STAT
187 Q
Note: See TracBrowser for help on using the repository browser.