source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK1.m@ 1071

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

WorldVistAEHR overlayed on FOIAVistA
File size: 9.4 KB
Line 
1SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003 9:36 AM ; 10/24/07 12:24pm
2 ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
3 Q
4INACTIVE ;run every night to determine if patient can be inactivated from
5 ;team
6 ;Inactivation happens for patients without activity for 24 months
7 N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0
8 D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y
9 S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X
10 S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y
11 S A="^SCPT(404.43,""ADFN""",L=""""""
12 S Q=A_")"
13 F S Q=$Q(@Q) Q:Q'[A D
14 .S ENTRY=+$P(Q,",",6)
15 .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
16 .S POS=+$P(ZERO,U,2)
17 .S TEAM=$P(Q,",",4)
18 .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q ;no automatic for this team
19 .;I $G(^DPT(DFN,.35)) D DIS Q ;Patient is deceased
20 .I $P(ZERO,U,3)>STDT Q ;Later
21 .I $P(ZERO,U,17) Q ;Already reactivated
22 .;get preceptor position
23 .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
24 .;see if provider changed
25 .I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) Q
26 .I $P(ZERO,U,4) Q ;Already unassigned
27 .I '$P(ZERO,U,5) Q ;Not primary care
28 .;I $P(ZERO,U,16) Q ;No Automatic unassign
29 .;Check if any activity
30 .S DFN=$P(Q,",",3)
31 .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN)
32 .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
33 .D SEEN Q:SEEN
34 .I '$P(ZERO,U,15) D
35 ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE
36 ..S TPZ=$G(^SCTM(404.57,+POS,2))
37 ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
38 ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
39 Q
40SEEN ;was patient seen
41 S SEEN=0
42 N SCPRO,I,PRECP,PRO
43 N X,SCPRDTS,SCPR
44 ;get list of providers for this position
45 S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
46 S SCPRDTS("BEGIN")=TYDT
47 S SCPRDTS("END")=DT
48 S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
49 F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))=""
50 S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
51 F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN
52 .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN
53 ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
54 ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN
55 ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ
56 ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
57 Q
58DIS ;discharge
59 N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
60 I $P(ZERO,U,4) Q ;Already discharged
61 D DIS2^SCMCTSK7
62 Q
63EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
64 ;IEN^POSITION^PATIENT^EXTENDED^REASON
65 K DATA,SCDATA,SDDATA
66 N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="<DATA>"
67 D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
68 S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21
69 S POSA=""
70 S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q
71 F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D Q:CNT>100
72 .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS Q:CNT>100
73 I CNT>100 S DATA(1)="TOO MANY" Q
74EX1 S A="SDDATA",CNT=1 F S A=$Q(@A) Q:A="" D
75 .S B=@A
76 .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
77 .S CNT=CNT+1
78 Q
79POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position
80 I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC
81 ;get patients for this position
82 K ^TMP("SC TMP LIST",$J)
83 S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
84 S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D
85 .N J I $P(SCDATA,U,4)>STDT Q
86 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
87 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
88 .S DFN=+SCDATA
89 .D SEEN Q:SEEN
90 .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
91 K @SCLIST
92 Q
93FILE(RES,DATA) ;File data on FTEE
94 N I
95 F I=1:1 Q:'$D(DATA(I)) D
96 .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]")
97 .S ZERO=$G(^SCPT(404.43,+DATA(I),0))
98 .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q
99 .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6)
100 .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50)
101 .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ))
102 I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
103 Q
104SCREEN ;Screen for active assignments
105 N A S A=$G(^SCTM(404.52,D0,0))
106 N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
107 I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC
108 I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position
109 I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
110 I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
111 S X=1 Q
112SUM(PR,POSI) ; get positions for this provider
113 N I,INS,ZERO,SCA,TEAM,FTEE,Z
114 S I="",FTEE=0
115 F S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I D
116 .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO)) Q:(POSI=(+ZERO)) S SCA(+ZERO)=""
117 .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
118 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
119 .S (Z,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z,U,3)'=PR
120 .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z,DT+.5) Q:'ACTIVE
121 .S Z=$G(^SCTM(404.57,+Z,0))
122 .Q:'$P(Z,U,4) ;Cannot be primary
123 .S TEAM=$G(^SCTM(404.51,+$P(Z,U,2),0))
124 .Q:'$P(TEAM,U,5)
125 .S FTEE=FTEE+$P(ZERO,U,9)
126 Q FTEE
127FTEECHK(DATA,PAIEN) ;check Ftee greater than 1
128 N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A)
129 S DATA=0
130 S DATA=FTEE+$P(PAIEN,U,2)
131 Q
132SORT ;sort template
133 N DIC,DIPA
134 S DIC=4,DIC(0)="ZME"
135 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
136 S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR
137 I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",X=1 Q
138 D ^DIC I Y<0 S DIPA("SI")=X Q:X[U D
139 .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR
140 .I X="LAST" S DIPA("EI")="zzz"
141 I Y>0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: "
142 D ^DIC
143 I Y>0 S DIPA("EI")=$P(Y(0),U)
144 I Y<0 S DIPA("EI")=X Q:X[U
145 S X=1 Q
146FTEERPT ;FTEE REPORT
147 D FTERPT^SCMCTSK6 Q
148 Q
149POSCHK(DATA,INFO) ;
150 N PCLASS
151 ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN
152 I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q
153 I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q
154 I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q
155 S DATA=0
156 I ('INFO)!('$P(INFO,U,2)) Q
157 ;Check if provider can be in this role.
158 S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J=""
159 I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q
160 S K=0 S K=$O(^SCTM(404.52,"AIDT",+INFO,1,J,K)) Q:'K
161 S ZERO=$G(^SCTM(404.52,+K,0))
162 ;Get person class for provider
163 S PCLASS=$$GET^XUA4A72(+$P(ZERO,U,3))
164 ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
165 I '$D(^SD(403.46,+$P(INFO,U,3),2,"B",+PCLASS)) S DATA="1^Person Class of "_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_" is not valid in this Role." D POSCHK^SCMCTSK4
166 Q
167SEED ;seed one patient/provider
168 W !,"To retransmit all patients for a given provider press return to select the provider",!!
169 N DIC,SCADT,SCDDT,SCPAI
170 S SC177=$$PDAT^SCMCGU("SD*5.3*177")
171 I +SC177=0 D Q
172 . S SC2=" Unable to obtain SD*5.3*177 Installation Date."
173 . D MSG^SCMCCV6(SC1,SC2)
174 . Q
175 S DIC="^DPT(",DIC(0)="MEQA" D ^DIC G PRSEED:Y'>0
176 ;event filer for 1 patient
177 S SCDFN=+Y W !,SCDFN
178SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
179 ;
180 ;quit if no PC assignments
181 Q:'$D(@SC1)
182 S SCADT=0
183 F S SCADT=$O(@SC1@(SCADT)) Q:SCADT="" D
184 . S SCTP=0
185 . F S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP D
186 . . ;
187 . . ; quit if team position does not exist
188 . . Q:'$D(^SCTM(404.57,SCTP,0))
189 . . S SCPAI=0
190 . . F S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI D
191 . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
192 . . . ;
193 . . . ; quit if not active within date range
194 . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
195 . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
196 . . . ;
197 . . . ; add to HL7 event file
198 . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
199 . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1
200 . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
201 Q
202PRSEED ;seed practitioner
203 N AH,SC177
204 S SC177=$$PDAT^SCMCGU("SD*5.3*177")
205 I +SC177=0 D Q
206 . S SC2=" Unable to obtain SD*5.3*177 Installation Date."
207 . D MSG^SCMCCV6(SC1,SC2)
208 . Q
209 S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0
210 S SCPROV=+Y
211 F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH S TP=+$G(^SCTM(404.52,+AH,0)) D
212 . Q:$D(SCTP(TP))
213 . S SCTP(TP)=1
214 . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1
215 . Q:'$P($G(^SCTM(404.57,TP,0)),U,4)
216 . S SCVAR=AH_";SCTM(404.52,"
217 . ;Quit if an event entry already exists
218 . N QUIT,I S QUIT=0
219 . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q
220 . Q:QUIT
221 . D ADD^SCMCHLE("NOW",SCVAR,,AH,1)
222 Q
223INCON ;get list of incositent provider assignments
224 N POS
225 D INCON^SCMCTSK3
226 Q
227INCONR ;inconsistent report
228 N BY
229 K ^TMP("SCMCTSK",$J)
230 S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1"
231 D EN1^DIP
232 Q
233CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
234 S DATA(0)=-1
235 N I
236 N POS,DFN S DFN=+$G(INFO) Q:'DFN S POS=+$P($G(INFO),U,2) Q:'POS
237 F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"."
238 I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2)
239 Q
240INACTDT(PA) ;Scheduled inactivation date.
241 D INACT^SCMCTSK3 Q
242IU(DFN) ;is patient inactivity unassigned
243 Q $$IU^SCMCTSK3(DFN)
244 N I,A,B,DATA
Note: See TracBrowser for help on using the repository browser.