source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGQPTQ1.m@ 1306

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

initial load of WorldVistAEHR

File size: 7.5 KB
Line 
1DGQPTQ1 ; SLC/CLA - Functs which return DG patient lists and sources pt 1 ;12/15/97
2 ;;5.3;Registration;**447**;Aug 13, 1993
3VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME
4 N I,J,V
5 S I=1
6 S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1
7 Q
8VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME
9 N I,IEN,CNT S CNT=44
10 I DIR=0 D ; Forward direction
11 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D
12 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
13 . I +$G(Y(CNT))="" S Y(I)=""
14 I DIR=1 D ; Reverse direction
15 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D
16 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM
17 Q
18DEFTM(DGY) ; return current user's default team list
19 Q:'$D(DUZ)
20 N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
21 S DGY=$$GET^XPAR("USR^SRV.`"_+$G(DGSRV),"DGLP DEFAULT TEAM",1,"B")
22 Q
23TEAMS(DGY) ; return list of teams for a system
24 ; Also called under DBIA # 2692.
25 N DGTM,I,DGTMN
26 S DGTMN="",I=1
27 F S DGTMN=$O(^OR(100.21,"B",DGTMN)) Q:DGTMN="" D
28 .S DGTM="",DGTM=$O(^OR(100.21,"B",DGTMN,DGTM)) Q:DGTM=""
29 .S DGY(I)=DGTM_U_DGTMN,I=I+1
30 S:+$G(DGY(1))<1 DGY(1)="^No teams found."
31 Q
32TEAMPTS(DGY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
33 ; Also called under DBIA # 2692.
34 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
35 ; global root string passed in DGY, and builds the returned
36 ; list in that global instead of to a memory array.
37 N DOTMP,NEWTMP
38 S DOTMP=0
39 I $G(TMPFLAG) D ; Was value passed?
40 .I TMPFLAG S DOTMP=1 ; Is value TRUE?
41 I +$G(TEAM)<1 D
42 .I DOTMP S NEWTMP=DGY_1_")",@NEWTMP="^No team identified" Q
43 .I 'DOTMP S DGY(1)="^No team identified" Q
44 N DGI,DGPT,I
45 S I=0
46 S DGI=0 F S DGI=$O(^OR(100.21,+TEAM,10,DGI)) Q:DGI<1 D
47 .S DGPT=^OR(100.21,+TEAM,10,DGI,0)
48 .I DOTMP D
49 ..S I=I+1,NEWTMP=DGY_+I_")"
50 ..S @NEWTMP=+DGPT_U_$P(^DPT(+DGPT,0),U)
51 .I 'DOTMP S I=I+1,DGY(I)=+DGPT_U_$P(^DPT(+DGPT,0),U)
52 I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found."
53 I 'DOTMP S:I<1 DGY(1)="^No patients found."
54 Q
55TEAMPR(DGY,PROV) ; return list of teams linked to a provider
56 I +$G(PROV)<1 S DGY(1)="^No provider identified" Q
57 N DGTM,I,DGTMN
58 S DGTM="",I=1
59 F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D
60 .S DGTMN=$P(^OR(100.21,DGTM,0),U)
61 .S DGY(I)=DGTM_U_DGTMN,I=I+1
62 S:+$G(DGY(1))<1 DGY(1)="^No teams found."
63 Q
64TEAMPR2(DGY,PROV) ; return list of teams linked to a provider
65 ; This tag added by PKS/slc - 8/1999.
66 I +$G(PROV)<1 S DGY(1)="^No provider identified" Q
67 N DGTM,DGDATA,DGTMN,DGTYPE,I
68 S DGTM="",I=1
69 F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D
70 .S DGDATA=^OR(100.21,ORTM,0) ; Get value.
71 .S DGTMN=$P(ORDATA,U) ; Team List name.
72 .S DGTYPE=$P(ORDATA,U,2) ; Team List type.
73 .S DGY(I)=DGTM_U_DGTMN_U_DGTYPE,I=I+1
74 S:+$G(DGY(1))<1 DGY(1)="^No teams found."
75 Q
76TEAMPROV(DGY,TEAM) ; return list of providers linked to a team
77 I +$G(TEAM)<1 S DGY(1)="^No team identified"
78 N PROV,I,SEQ
79 S I=1
80 S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D
81 .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D
82 ..S DGY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1
83 S:+$G(DGY(1))<1 DGY(1)="^No providers found."
84 Q
85TPROVPT(PROV) ;return list of patients linked to a provider via teams
86 ; Modified by PKS: 8/1999.
87 I +$G(PROV)<1 S ^TMP("DGLPUPT",$J,"^No provider identified")=""
88 N DGTM,DGTMN,DGI,DGPT
89 S DGTM=""
90 F S DGTM=$O(^OR(100.21,"C",+PROV,DGTM)) Q:+$G(DGTM)<1 D ; Teams.
91 .S DGTMN=$P(^OR(100.21,+DGTM,0),U,1) ; Get name of Team List.
92 .S DGI=0 F S DGI=$O(^OR(100.21,+DGTM,10,DGI)) Q:DGI<1 D
93 ..S DGPT=^OR(100.21,+DGTM,10,DGI,0)
94 ..S ^TMP("DGLPUPT",$J,+DGPT_U_$P(^DPT(+DGPT,0),U))=""
95 ..; Next line added by PKS:
96 ..S ^TMP("DGLPUPT",$J,"B",DGTMN,$P(^DPT(+DGPT,0),U)_U_+DGPT)=""
97 I '$D(^TMP("DGLPUPT",$J)) S ^TMP("DGLPUPT",$J,"^No patients found.")=""
98 Q
99TMSPT(DGY,PT) ;return list of teams linked to a patient (patient is active)
100 I +$G(PT)<1 S DGY(1)="^No patient identified" Q
101 N DGTM,I,DGTMN,DGTMTYP
102 S DGTM="",I=1
103 F S DGTM=$O(^OR(100.21,"AB",+PT_";DPT(",DGTM)) Q:+$G(DGTM)<1 D
104 .S DGTMN=$P(^OR(100.21,DGTM,0),U)
105 .S DGTMTYP=$P(^OR(100.21,DGTM,0),U,2) I $L(DGTMTYP) D
106 ..S DGTMTYP=$$EXTERNAL^DILFD(100.21,1,"",DGTMTYP,"")
107 .S DGY(I)=DGTM_U_DGTMN_U_$S($L(DGTMTYP):DGTMTYP,1:"no type"),I=I+1
108 S:+$G(DGY(1))<1 DGY(1)="^No teams found."
109 Q
110TPTPR(DGY,PT) ;return list of providers linked to a patient via teams
111 I +$G(PT)<1 S DGY(1)="^No patient identified" Q
112 N DGTM,PROV,SEQ
113 S DGTM=""
114 F S DGTM=$O(^OR(100.21,"AB",+PT_";DPT(",DGTM)) Q:+$G(DGTM)<1 D
115 .S SEQ=0 F S SEQ=$O(^OR(100.21,+DGTM,1,SEQ)) Q:SEQ<1 D
116 ..S PROV=^OR(100.21,+DGTM,1,SEQ,0) I $L(PROV) D
117 ...S DGY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U)
118 S:'$D(DGY) DGY(1)="^No providers found."
119 Q
120PERSPR(DGY) ; return list of personal lists linked to current user
121 N DGTM,I,DGTMN
122 S DGTM="",I=1
123 F S DGTM=$O(^OR(100.21,"C",DUZ,DGTM)) Q:+$G(DGTM)<1 D
124 .Q:$P(^OR(100.21,DGTM,0),U,2)'="P" ;quit if not a personal list
125 .S DGTMN=$P(^OR(100.21,DGTM,0),U)
126 .S DGY(I)=DGTM_U_DGTMN,I=I+1
127 S:+$G(DGY(1))<1 DGY(1)="^No personal lists found."
128 Q
129PRIMPT(DGY,DGPT) ; return patient's PCMM primary care team
130 I +$G(DGPT)<1 S DGY(1)="^No patient identified"
131 N DGQPUR,DGQERROR,DGQLST,DGQERR,DGQDT,DGIDT,DGADT,DGX
132 S DGQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47]
133 D NOW^%DTC S DGQDT("BEGIN")=%-.0001,DGQDT("END")=%+.0001,DGQDT("INCL")=0
134 S DGQERROR=$$TMPT^SCAPMC(.DGPT,"DGQDT","DGQPUR","DGQLST","DGQERR")
135 I DGQERROR=0 S DGY="^Error in search for primary care team."
136 I +$G(DGQLST(1))>0 D
137 .S DGX=DGQLST(1),DGADT=$P(DGX,U,4),DGIDT=$P(DGX,U,5)
138 .I ($G(DGADT)>$G(DGIDT)) S DGY=$P(DGX,U)_U_$P(DGX,U,2)
139 S:+$G(DGY)<1 DGY="^No primary care team found."
140 K %
141 Q
142PROVPT(DGY,DGPT) ; return PCMM primary provider for a patient
143 I +$G(DGPT)<1 S DGY(1)="^No patient identified"
144 S DGY(1)=$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1)
145 Q
146PPLINK(DGPROV,DGPT) ; returns '1' if patient is linked to provider
147 N DGX,DGPP
148 S DGX="",DGPP=0
149 I (+$G(DGPT)<1)!(+$G(DGPROV)<1) Q 0
150 I $D(^DPT("APR",DGPROV,DGPT)) Q "1^PRIM" ;provider is patient's primary
151 I $D(^DPT("AAP",DGPROV,DGPT)) Q "1^ATTD" ;provider is patient's attending
152 ;is provider and patient on the same team:
153 D TPROVPT(DGPROV)
154 F S DGX=$O(^TMP("DGLPUPT",$J,DGX)) Q:DGX="" D
155 .I +DGX=DGPT S DGPP="1^OERRTM" Q
156 K ^TMP("DGLPUPT",$J)
157 ;
158 ;If not linked already, see if linked via PCMM:
159 I DGPP=0 S DGPP=$$PCMMLINK(DGPROV,DGPT)
160 ;
161 Q DGPP
162PDLINK(DGDEV,DGPT) ; returns '1' if patient is linked to device via team
163 ;DGDEV can be either ien or device name
164 N DGY,DGX,DGTM,DGDP,DGTMDEV,DGDEVIEN
165 S DGDP=0
166 I (+$G(DGPT)<1)!($L($G(DGDEV))<1) Q 0
167 ; Are device and patient on the same team?:
168 I '$D(^%ZIS(1,DGDEV,0)) D ;DGDEV is not an ien
169 .S DGDEVIEN=0,DGDEVIEN=$O(^%ZIS(1,"B",$P(DGDEV,U),ORDEVIEN))
170 .S DGDEV=DGDEVIEN
171 Q:+$G(DGDEV)<1 0
172 D TMSPT(.DGY,DGPT)
173 S DGX="" F S DGX=$O(DGY(DGX)) Q:DGX="" D
174 .S DGTM=DGY(DGX)
175 .I $D(^OR(100.21,+DGTM,0)),$P(^(0),U,4)=DGDEV S DGDP=1 Q
176 Q DGDP
177PCMMLINK(DGPROV,DGPT) ;returns '1' if patient is linked to provider via PCMM
178 N DGPP,DGPCMM,DGPCP
179 S DGPP=0
180 I (+$G(DGPT)<1)!(+$G(DGPROV)<1) Q 0
181 ;
182 ;provider is patient's PCMM primary care practitioner:
183 I DGPROV=+$$OUTPTPR^SDUTL3(DGPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252
184 ;
185 ;provider is patient's PCMM associate provider:
186 I DGPROV=+$$OUTPTAP^SDUTL3(DGPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252
187 ;
188 ;provider is linked to patient via PCMM team position assignment:
189 S DGPCMM=$$PRPT^SCAPMC(DGPT,,,,,,"^TMP(""DGPCMMLK"",$J)",) ;DBIA #1916
190 S DGPCP=0
191 F S DGPCP=$O(^TMP("DGPCMMLK",$J,"SCPR",DGPCP)) Q:'DGPCP!DGPP=1 D
192 .I DGPROV=DGPCP S DGPP="1^PCMMTM"
193 K ^TMP("DGPCMMLK",$J)
194 ;
195 Q DGPP
Note: See TracBrowser for help on using the repository browser.