source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK.m@ 1093

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1SCMCTSK ;ALB/JDS - PCMM ; 03 Jun 2004 3:30 PM
2 ;;5.3;Scheduling;**264,278,272,297**;AUG 13, 1993
3 Q
4RPT1 ;REPORT
5 N DHD,DIOBEG
6 S DIOBEG="D INACTIVE^SCMCTSK",DIC="^SCPT(404.43,",(FLDS,BY)="[SCMC PENDING UNASSIGN]"
7 S DHD="Patients Flagged for Inactivation from Primary Care Panels"
8 D EN1^DIP
9 Q
10INACTIVE ;run every night to determine if patient can be inactivated from
11 ;team
12 ;Inactivation happens for patients without activity for 24 months
13 N I,TEAMNM
14 D DT^DICRW S X="T-12M" D ^%DT S STDT=Y
15 S X="T-24M" D ^%DT S TYDT=+Y
16RPT ;eneter for report with STDT and TYDT defined
17 S A="^SCPT(404.43,""ADFN""",L=""""""
18 S Q=A_")"
19 F S Q=$Q(@Q) Q:Q'[A D
20 .S ENTRY=+$P(Q,",",6)
21 .S TEAM=$P(Q,",",4)
22 .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q ;no automatic for this team
23 .;I $G(^DPT(DFN,.35)) D DIS Q ;Patient is deceased
24 .I $P(Q,",",5)>STDT Q ;Later
25 .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
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),DFN=+$G(^SCPT(404.42,+DFN,0))
31 .S SEEN=0
32 .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
33 .;who was provider for this position
34 .Q:$$SEEN1(DFN,+$P(ZERO,U,2))
35 .;I $G(DIS) D DIS Q
36 .S ^TMP("SCMCTSK",$J,ENTRY)=""
37 Q
38SEEN1(DFN,POS) ;
39 S SEEN=0
40 K PROV F I=0:0 S I=$O(^SCTM(404.52,"B",+$G(POS),I)) Q:'I D
41 .N A S A=$G(^SCTM(404.52,+I,0)) I $P(A,U,4) S PROV(+$P(A,U,3))="" Q
42 .I $P(A,U,2)<TYDT K PROV(+$P(A,U,3))
43 F PROV=0:0 S PROV=$O(PROV(PROV)) Q:'PROV D SEEN
44 Q SEEN
45SEEN ;See if seen in last 24 months go through visits
46 F I=0:0 S I=$O(^AUPNVSIT("AA",DFN,I)) Q:'I Q:(9999999-I<TYDT) D Q:SEEN
47 .F J=0:0 S J=$O(^AUPNVSIT("AA",DFN,I,J)) Q:'J D
48 ..F P=0:0 S P=$O(^AUPNVPRV("AD",J,P)) Q:'P S:PROV=(+$G(^AUPNVPRV(P,0))) SEEN=1 Q:SEEN ;GET THE PROVIDERJ
49 Q
50DIS ;discharge
51 N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
52 I $P(ZERO,U,4) Q ;Already discharged
53 ;I $P(ZERO,U,16) Q
54 S DA=ENTRY,DIE="^SCPT(404.43,",DR=".04////"_DT_";.12////IU"
55 D ^DIE
56 ;
57 Q
58DEATH ;Called from date of death event
59 ;
60 I $G(DGFILE)'=2 Q
61 I $G(DGFIELD)'=.351 Q
62 S DFN=+$G(DGDA)
63 N DEATH,I,DR,SCJ
64 D DEM^VADPT S DEATH=$G(VADM(6))
65 ;loop through assignments
66 F SCJ=0:0 S SCJ=$O(^SCPT(404.42,"B",DFN,SCJ)) Q:'SCJ D
67 .S ZERO=$G(^SCPT(404.42,SCJ,0)) Q:'$L(ZERO)
68 .I DEATH,'$P(ZERO,U,9) D
69 ..S DA=SCJ,DIE="^SCPT(404.42,",DR=".09////"_DT_";.15////DU" D ^DIE
70 .I ('DEATH)&($P(ZERO,U,15)="DU")&($P(ZERO,U,9)) D
71 ..S DA=SCJ,DIE="^SCPT(404.42,",DR=".09///@;.15////DD" D ^DIE
72 .F SCI=0:0 S SCI=$O(^SCPT(404.43,"B",SCJ,SCI)) Q:'SCI D
73 ..S ZERO=$G(^SCPT(404.43,SCI,0)),SCTP=+$P(ZERO,U,2) Q:'$L(ZERO)
74 ..I DEATH,$P(ZERO,U,4) Q
75 ..I 'DEATH I (('$P(ZERO,U,4))!($P(ZERO,U,12)'="DU")) Q
76 ..I DEATH D Q
77 ...S DA=SCI,DIE="^SCPT(404.43,",DR=".04////"_DT_";.12////DU" D ^DIE
78 ..I '+$$ACTHIST^SCAPMCU2(404.52,SCTP,,.SCERR) Q
79 ..S DA=SCI,DIE="^SCPT(404.43,",DR=".04///@;.12////DD" D ^DIE
80 Q:'DEATH
81 ;DISPOSITION WAIT LIST
82 F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D
83 .I $G(^SDWL(409.3,I,"DIS")) Q
84 .N FDA S FDA(409.3,I_",",21)="D"
85 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
86 .S FDA(409.3,I_",",20)=DUZ
87 .D UPDATE^DIE("","FDA")
88 Q
89POST ;
90 D MES^XPDUTL("Deleting Traditional ASTAT CROSS REFERENCE from FILE 404.43")
91 D DELIX^DDMOD(404.43,.12,1)
92 N ENTRY,DGDA,DGFIELD,DGFILE
93 K DGLEFDA,YEAR
94 I '$D(^SCTM(404.46,"B","1.2.3.0")) D
95 .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.0" D FILE^DICN
96 I '$D(^SCTM(404.45,"B","SD*5.3*264")) D
97 .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.0",0))
98 .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
99 .K DO S X="SD*5.3*264",DIC="^SCTM(404.45," D FILE^DICN
100 D MES^XPDUTL("Removing Patients with Date of Death from Team/Position Assignments")
101 S YEAR=0
102 F DATE=0:0 S DATE=$O(^DPT("AEXP1",DATE)) Q:'DATE F DGDA=0:0 S DGDA=$O(^DPT("AEXP1",DATE,DGDA)) Q:'DGDA D
103 .S DFN=+DGDA D DEM^VADPT I $G(VADM(6)) S DGFILE=2,DGFIELD=.351 D DEATH
104 .I $E(YEAR,1,3)'=$E(DATE,1,3) S YEAR=$E(DATE,1,3) I "05"[$E(YEAR,3) D MES^XPDUTL("Starting with Dates of Death in "_(1700+YEAR))
105 Q
106POST278 ;postinit for 278
107 D MES^XPDUTL("Setting up GUI to VistA mapping")
108 I '$D(^SCTM(404.46,"B","1.2.3.1")) D
109 .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.2.3.1" D FILE^DICN
110 I '$D(^SCTM(404.45,"B","SD*5.3*278")) D
111 .S ENTRY=$O(^SCTM(404.46,"B","1.2.3.1",0))
112 .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"
113 .K DO S X="SD*5.3*278",DIC="^SCTM(404.45," D FILE^DICN
114 Q
115FTEE(DATA,SCTEAM) ;return list of posistions for the team
116 ;IEN^POSITION^PROVIDER^FTEE
117 N CNT,I,J,K,A S CNT=1 S SCTEAM=+$G(SCTEAM),DATA(1)="<DATA>"
118 S A=""
119 F S A=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A)) Q:A="" D
120 .F I=0:0 S I=$O(^SCTM(404.57,"ATMPOS",SCTEAM,A,I)) Q:'I D
121 ..I '$$DATES^SCAPMCU1(404.59,I) Q ;Not an active position
122 ..I '$P($G(^SCTM(404.57,I,0)),U,4) Q ;Not PC
123 ..S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",I,1,J)) Q:J=""
124 ..I $O(^SCTM(404.52,"AIDT",I,0,-(DT+1)))<J Q
125 ..S K=0 S K=$O(^SCTM(404.52,"AIDT",I,1,J,K)) Q:'K
126 ..S ZERO=$G(^SCTM(404.52,+K,0)) Q:'$P(ZERO,U,4)
127 ..S CNT=CNT+1
128 ..S DATA(CNT)=K_U_A_U_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_U_$P(ZERO,U,9)_U_K_U_$P(ZERO,U,3)
129 Q
130FILE(RES,DATA) ;File data on FTEE
131 N I
132 F I=1:1 Q:'$D(DATA(I)) D
133 .S ZERO=$G(^SCTM(404.52,+DATA(I),0))
134 .I $P(ZERO,U,9)=$P(DATA(I),U,7) Q
135 .S FLDA(404.52,(+DATA(I))_",",.09)=+$TR($P(DATA(I),U,7)," ")
136 I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
137 Q
138FTEXR ;Ftee cross reference
139 N DIC,DD,DO,DINUM,DS,ENTRY,VALUE
140 I '$D(^SCTM(404.52,+DA,1,0)) S ^(0)="^404.521DA"
141 S ENTRY=+$G(DA),VALUE=X
142 N DIC,FLDA,Y,DA,X S DIC="^SCTM(404.52,"_ENTRY_",1,",DA(1)=ENTRY
143 S DIC(0)="LM",X="NOW",DIC("DR")=".02////"_VALUE_";.03////"_$G(DUZ)
144 D ^DICN
145 Q
146SCREEN ;Screen for active assignments
147 N A S A=$G(^SCTM(404.52,D0,0))
148 N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
149 I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC
150 I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position
151 I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
152 I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
153 S X=1 Q
Note: See TracBrowser for help on using the repository browser.