source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCWAIT.m@ 1267

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

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1SCMCWAIT ;ALB/SCK - Broker Utilities for Placement on Wait List ; 30 Oct 2002 3:42 PM ; Compiled May 25, 2007 09:07:17
2 ;;5.3;Scheduling;**264,297,446**;AUG 13, 1993;Build 77
3 ;
4 Q
5 ;
6WAIT(SCOK,SC) ; Place patient on wait list
7 ; 'SC BLD PAT CLN LIST'
8 ;
9 ;M ^JDS=SC
10 N COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN
11 S TEAM=$G(SC("TEAM")),POS=$G(SC("POSITION")),DFN=$G(SC("DFN")),COMMENT=$G(SC("COMMENT")),SC=$G(SC("SC"))
12 S SDWLIN=+$P($G(^SCTM(404.51,+$G(TEAM),0)),U,7),SDINTR=$G(SC("SDINTR")),SDREJ=$G(SC("SDREJ")),SDMTM=$G(SC("SDMTM"))
13 ; check if transfer and if multiple teams in institution
14 S SDCNT=0,SDINTR="",SDREJ="",SDMTM="",SDCC=TEAM
15 ;identify INTRA-transfer
16 ;- is patient assigned to PC provider?
17 I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
18 .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
19 .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
20 ..;check available PCMM teams in other institutions and if so set up rejection flag
21 ..N SDT S SDCNT=0,SDT=""
22 ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
23 ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
24 ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
25 ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
26 ...I SCTMCT<SCTMMAX S SDREJ=1
27 ..;find all teams from institution SDWLIN
28 .I SDINTR S SDCNT=0,SDT="" D
29 ..F S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT="" I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1
30 I SDCNT>1 S SDMTM=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" N DR,Y D WT Q
31 I SDCNT'>1 D WT Q
32WT N RES D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_SDCC_U_$S(POS:POS_U_DUZ,1:U_DUZ)_U_COMMENT_U_SC_U_SDINTR_U_SDREJ_U_SDMTM)
33 I RES S SDWLRES=RES ; 446
34 Q
35WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST
36 N SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES
37 S SDTEAM=$G(TEAM)
38 ; check if transfer and if multiple teams in institution
39 S SDCNT=0,SDINTR="",SDREJ="",SDMTM="" I 'POS&TEAM D
40 .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)
41 .;- is patient assigned to PC provider?
42 I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
43 .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
44 .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
45 ..;check available PCMM teams in other institutions and if so set up rejection flag
46 ..N SDT S SDCNT=0,SDT=""
47 ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
48 ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
49 ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
50 ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
51 ...I SCTMCT<SCTMMAX S SDREJ=1
52 ..;find all teams from institution SDWLIN
53 .I SDINTR S SDCNT=0,SDT="" D
54 ..F S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT="" I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1
55 I SDCNT>1 S SDMTM=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" S TEAM=SDCC N DR,Y S SDWLRES=$$WMT
56 I SDCNT'>1 N DR,Y S SDWLRES=$$WMT
57 S TEAM=$G(SDTEAM) Q $G(SDWLRES)
58WMT() N RES
59 D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_TEAM_U_$S(POS:POS_U_DUZ,1:U_DUZ)_"^^"_SC_U_SDINTR_U_SDREJ_U_SDMTM)
60 I $G(RES) D
61 .N DA,DIE,DIK,DR,OK
62 .S SDWLRES=RES ; 446
63 .S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1"
64 .D ^DIE
65 .I 'OK S DIK=DIE D ^DIK W !,"Wait list entry deleted" S RES=0
66 Q $G(RES)
67TEAMRM(DFN,TEAM) ;
68 N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAM) Q ;not PC panel assignment
69 I SDTM'=TEAM D CLONE(DFN,TEAM) Q ;TEAM IS NOT PCP
70 ;close EWL entries only if assignment to PC panel, not necessarily to a team
71 N I
72 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
73 .I 12'[$P(A,U,5) Q
74 .;I $P(A,U,6)'=$G(TEAM) Q
75 .I $G(^SDWL(409.3,I,"DIS")) Q
76 .;INACTIVATE I
77 .N FDA S FDA(409.3,I_",",21)="SA"
78 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
79 .S FDA(409.3,I_",",20)=DUZ
80 .D UPDATE^DIE("","FDA")
81 Q
82POSRM(TEAMP,POS) ;
83 ;
84 S DFN=+$G(^SCPT(404.42,+$G(TEAMP),0))
85 N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAMP,POS) Q ;not PC panel assignment
86 I SDTM'=TEAMP D CLONE(DFN,TEAMP,POS) Q
87 I $G(POS) I '$P($G(^SCPT(404.43,+POS,0)),U,5) Q ;not pc
88 I '$P($G(^SCPT(404.42,+$G(TEAMP),0)),U,8) Q ;not pc
89 ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN
90 N I
91 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
92 .I 12'[$P(A,U,5) Q
93 .;I $P(A,U,7)'=$G(POS) Q
94 .I $G(^SDWL(409.3,I,"DIS")) Q
95 .N FDA S FDA(409.3,I_",",21)="SA",FDA(409.3,I_",",23)="C"
96 .S FDA(409.3,I_",",19)=DT
97 .S FDA(409.3,I_",",20)=DUZ
98 .D FILE^DIE("","FDA")
99 .;INACTIVATE
100 Q
101CLONE(DFN,TEAM,POS) ;clean one entry only or two if position
102 N I,SDONE S SDONE=0
103 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 Q:SDONE
104 .I 12'[$P(A,U,5) Q
105 .I $P(A,U,5)=1 I $P(A,U,6)'=$G(TEAM) Q
106 .I $P(A,U,5)=2 I $P(A,U,6)'=$G(POS) Q
107 .I $G(^SDWL(409.3,I,"DIS")) Q
108 .;INACTIVATE I
109 .N FDA S FDA(409.3,I_",",21)="SA"
110 .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
111 .S FDA(409.3,I_",",20)=DUZ
112 .D UPDATE^DIE("","FDA")
113 .S SDONE=1
114 Q
115PCPVER(DFN,SDTM) ;verify if PCP assignment
116 S SDTM=0 ; return 0 if no PCP assignment
117 K ^TMP("SDPCP",$J)
118 N SDATE,SDPCP
119 N SDI F SDI="BEGIN","END" S SDATE(SDI)=DT
120 S SDATE="SDATE",SDPCP="^TMP(""SDPCP"",$J)"
121 ;
122 N SDI S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)
123 N SDII S SDII=0
124 F S SDII=$O(^TMP("SDPCP",$J,DFN,"PCPOS",SDII)) Q:'SDII D
125 .N SDX S SDX=^TMP("SDPCP",$J,DFN,"PCPOS",SDII)
126 .I +$P(SDX,U,7)'=2 Q ;PCP role
127 .I +$P(SDX,U,6)>0&(+$P(SDX,U,6)<DT) Q
128 .S SDTM=$P(SDX,U,3)
129 Q
130ONWAIT(DFN) ;is patient on wait list
131 D DEM^VADPT I $G(VADM(6)) Q 9 ;Patient is dead
132 N I,X
133 S X=0
134 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 Q:X
135 .I 12'[$P(A,U,5) Q
136 .I $G(^SDWL(409.3,I,"DIS")) Q
137 .S X="3;ON WAITLIST TEAM: "_$P($G(^SCTM(404.51,+$P(A,U,6),0)),U)
138 .I $P(A,U,7) S X=X_" POSITION: "_$P($G(^SCTM(404.57,+$P(A,U,7),0)),U)
139 I X Q X
140 ;Q X
141 ;CHECK IF ON TEAM
142 N SCD,SCDT,SCOK S SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1") I $D(SCD(1)) S X=1
143 N SCPOS S SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR") I $D(SCPOS(1)) S X=2
144 Q X
145 ;CHECK IF ON POSITION
146SORT ;From sort template
147 S X=0
148 Q
149PC(RESULT,POS) ;rpc to see if provider can be pc
150 N POENT,RES
151 D ROLE(.RES,POS) I RES=1 S RESULT(0)=0 Q
152 S POENT=+$O(^SCTM(404.52,"AIDT",+$G(POS),1,-(DT+.1))),POENT=$O(^(POENT,0))
153 ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)
154 I 'POENT S RESULT(0)=1 Q
155 N D0 S D0=+$G(POENT) D SORT S RESULT(0)=X
156 Q
157ROLE(RESULT,POS) ;rpc to see if role of position is resident
158 N ZERO S ZERO=$G(^SCTM(404.57,+$G(POS),0))
159 I $P(ZERO,U,4) S RESULT=0 Q ;Already pc let them change it.
160 S RESULT=0
161 I $P($G(^SD(403.46,+$P(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)" S RESULT=1
162 Q
163SC(DFN) ;Is patient 0-50 sc%
164 N TEAM,INST S TEAM=$P(DFN,U,2),INST=+$P($G(^SCTM(404.51,+TEAM,0)),U,7)
165 S X=0,DFN=+DFN
166 N A D ELIG^VADPT S A=$G(VAEL(3)) I $P(A,U)'="Y" Q 0
167 I $P(A,U,2)<50 Q $P(A,U,2)
168 Q 0
169SCLI(RESULT,SC) ;sc sc list
170 K RESULT N RES
171 S DFN=+$G(SC("DFN"))
172 D SDSC^SDWLRP3(.RES,DFN) I RES=-1 S RESULT(0)=-1 Q
173 S RESULT(0)="<RESULTS>" N CNT,I S CNT=1 F I=0:0 S I=$O(^TMP("SDWLRP3",$J,I)) Q:'I S RESULT(CNT)=^(I),CNT=CNT+1
Note: See TracBrowser for help on using the repository browser.