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