source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRRLU0.m@ 1334

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1DGRRLU0 ;alb/GAH - DG Replacement and Rehosting RPC for VADPT ;10/10/05 09:53
2 ;;5.3;Registration;**538,725**;Aug 13, 1993;Build 12
3 ;
4 SET X="You Can't Enter DGRRLU0 at top of routine!"
5 QUIT
6 ;
7BYFILTER(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) ; -- search type by clinic, provider, or ward.
8 NEW PCNT,OKAY,VAL
9 K ^TMP("DGPTLKUP",$J)
10 SET (OKAY,PCNT)=0
11 ;
12 DO ADD^DGRRUTL("<record count='0'>")
13 SET LINENO=DGRRLINE
14 FOR I=1:1 S VAL=$P(FILTERV,DELIM,I) QUIT:VAL="" DO Q:$$STOP^XOBVLIB()
15 . IF FILTER="WARD" DO WARDPTS(VAL) S OKAY=1 Q
16 . IF FILTER="CLINIC" DO CLINPTS(VAL,BDATE,EDATE) S OKAY=2 Q
17 . IF FILTER="PROVIDER" D PROVPTS(VAL) S OKAY=3 Q
18 . IF FILTER="SPECIALTY" D SPECPTS(VAL) S OKAY=4 Q
19 ;
20 IF OKAY<1 DO ADD^DGRRUTL("<error message='Filter not correctly specified'></error>")
21 ;
22 ; -- update the record count
23 DO ADDPTS()
24 SET @DGRRESLT@(LINENO)="<record count='"_PCNT_"'>"
25 IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
26 DO ADD^DGRRUTL("<error message=''></error>")
27 QUIT
28 ;
29FILTCHK(DFN,TYPE,VALUE) ; -- Filter search -
30 ; -- check patients to match search type and search value for filter searches
31 ; -- returns 1 if matches, 0 if no match
32 ;
33 SET VALUE=$$UP^XLFSTR(VALUE)
34 Q:($G(VALUE)="")!($G(VALUE)="*") 1
35 Q:($G(TYPE)="") 1
36 Q:($G(DFN)<1) 0
37 ;
38 NEW I,J,OKAY,CHKVAL
39 SET OKAY=0
40 IF TYPE="NAME" DO
41 . IF VALUE[", " SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ; REMOVE FIRST SPACE line added sgg 070104
42 . SET CHKVAL=$P($G(^DPT(DFN,0)),"^",1)
43 . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
44 IF TYPE="SSN" DO
45 . SET CHKVAL=$P($G(^DPT(DFN,0)),"^",9)
46 . SET VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES line added sgg 070104
47 . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
48 IF TYPE="ICN" DO
49 . ;SET CHKVAL=$P($G(^DPT(DFN,"MPI")),"^",1)
50 . S CHKVAL=+$$GETICN^MPIF001(DFN)
51 . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
52 IF TYPE="SSN4" DO
53 . SET CHKVAL=$E($P($G(^DPT(DFN,0)),"^",1),1)_$E($P($G(^DPT(DFN,0)),"^",9),6,9)
54 . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
55 QUIT OKAY
56 ;
57WARDPTS(WARD) ; RETURN LIST OF PATIENTS IN A WARD
58 ; Based on ORQPTQ2
59 Q:+$G(WARD)<1
60 N DFN
61 S DFN=0
62 S WARD=$P(^DIC(42,WARD,0),"^") ;GET WARD NAME FOR "CN" LOOKUP
63 Q:WARD=""
64 F D Q:DFN'>0 Q:$$STOP^XOBVLIB()
65 . S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0
66 . Q:'$$FILTCHK(DFN,SEARCH,VALUE)
67 . S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
68 Q
69 ;
70PROVPTS(PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
71 ; Based on ORQPTQ2
72 ; "APR" xref is on field PROVIDER in file 2 (2;.104)
73 ; "AAP" xref is on field ATTENDING PHYSICIAN in file 2 (2;.1041)
74 ;
75 Q:+$G(PROV)<1
76 ;
77 N DFN,XREF
78 S DFN=0
79 F XREF="AAP","APR" DO
80 . F S DFN=$O(^DPT(XREF,PROV,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
81 .. Q:'$$FILTCHK(DFN,SEARCH,VALUE)
82 .. S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
83 Q
84 ;
85CLINPTS(CLIN,BDATE,EDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
86 Q:+$G(CLIN)<1
87 ;
88 N DFN,NAME,I,J,X,Y,ORJ,ORSRV,ORNOWDT,CHKX,CHKIN,MAXAPPTS,ORC,CLNAM,NOWDT
89 S MAXAPPTS=200
90 S NOWDT=$$NOW^XLFDT
91 ;
92 S DFN=0,I=1
93 IF $G(BDATE)="" S BDATE="T"
94 IF $G(EDATE)="" S EDATE="T+1"
95 ;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME
96 D DT^DILF("T",BDATE,.BDATE,"","")
97 D DT^DILF("T",EDATE,.EDATE,"","")
98 I (BDATE=-1)!(EDATE=-1) S Y(1)="^Error in date range." Q
99 S EDATE=$P(EDATE,".")_.5 ;ADD 1/2 DAY TO END DATE
100 ;
101 D CLINPT2(+CLIN,BDATE,EDATE)
102 QUIT
103 ;
104CLINPT2(CLIN,BEGIN,END) ; -- Use scheduling rehosting API from patches SD*5.3*253 and SD*5.3*275
105 ; -- GETPLIST^SDAMA202(SDIEN,SDFIELDS,SDAPSTAT,SDSTART,SDEND,.SDRESULT,SDIOSTAT)
106 ;
107 K ^TMP($J,"SDAMA202","GETPLIST")
108 NEW I,X,APPTS,APPTDT SET APPTS=""
109 ;
110 ; -- get appointment date/time, patient status, patient ien & name,
111 ; only get appointment status = "R" for scheduled or kept appointments.
112 DO GETPLIST^SDAMA202(+CLIN,"1;3;4","R",BEGIN,END,.APPTS)
113 ;
114 ; -- check number of appointments
115 I APPTS<1 K ^TMP($J,"SDAMA202","GETPLIST") Q
116 ;
117 ; -- check for an error, may need to pass message up.
118 I $D(^TMP($J,"SDAMA202","GETPTLIST","ERROR")) QUIT
119 ;
120 ; -- move list of appointments to list of patients, ordered by name, dfn
121 S (I,X)=""
122 F SET I=$O(^TMP($J,"SDAMA202","GETPLIST",I)) Q:I<1 S X=^(I,4) DO
123 . Q:'$$FILTCHK(+X,SEARCH,VALUE) ;check if meets search criteria
124 . S APPTDT=$G(^TMP($J,"SDAMA202","GETPLIST",I,1))
125 . S ^TMP("DGPTLKUP",$J,$P(X,"^",2),+X,+APPTDT)=""
126 K ^TMP($J,"SDAMA202","GETPLIST")
127 QUIT
128 ;
129SPECPTS(SPEC) ;Returns a list of patients associated with a specialty
130 ; "ATR" cross reference is on the Treating Specialty (#.103) field
131 ; in the Patient (#2) file and is a pointer to the Facility
132 ; Treating Specialty (#45.7) file.
133 ;
134 Q:+$G(SPEC)<1
135 N DFN
136 S DFN=0
137 F S DFN=$O(^DPT("ATR",+SPEC,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
138 .Q:'$$FILTCHK(DFN,SEARCH,VALUE)
139 .S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),U),DFN)=""
140 Q
141 ;
142ADDPTS() ;
143 N NAME,DFN,DGRRFLG,DGRRAPTS,DGRRCTR
144 S NAME=""
145 S (DGRRFLG,DGRRCTR)=0
146 S DGRRAPTS=$S(FILTER="CLINIC":1,1:0)
147 FOR SET NAME=$O(^TMP("DGPTLKUP",$J,NAME)) Q:NAME=""!(DGRRFLG=1) DO
148 . S DFN="" FOR SET DFN=$O(^TMP("DGPTLKUP",$J,NAME,DFN)) Q:DFN<1!(DGRRFLG=1) DO
149 .. S DGRRCTR=DGRRCTR+1
150 .. I DGRRCTR>MAXSIZE S DGRRFLG=1 Q
151 .. DO PTDATA^DGRRLUA(DFN,.PCNT)
152 .. I FILTER'="CLINIC" Q
153 .. D ADD^DGRRUTL("<appointments>")
154 .. N APPTDT
155 .. S APPTDT=""
156 .. F S APPTDT=$O(^TMP("DGPTLKUP",$J,NAME,DFN,APPTDT)) Q:'APPTDT D
157 ...D ADD^DGRRUTL("<appointmentTime>"_APPTDT_"</appointmentTime>")
158 .. D ADD^DGRRUTL("</appointments>")
159 .. D ADD^DGRRUTL("</patient>")
160 I DGRRCTR>MAXSIZE D
161 .IF $G(MAXSIZRE)<1 DO ADD^DGRRLU("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
162 .SET MAXSIZRE=1
163 K ^TMP("DGPTLKUP",$J)
164 ;IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
165 Q
166 ;
167NAMECOMP(DFN,DGRRCNT) ; ENTRY IS +$P($G(^DPT(DFN,"NAME")),"^",1)
168 ;
169 N LN,FN,MI,PR,SU,DE,DGA,DGNMC
170 S DGA=+$P($G(^DPT(DFN,"NAME")),U)_","
171 D GETS^DIQ(20,+DGA,"1:6","","DGNMC")
172 S LN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,1)))
173 S FN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,2)))
174 S MI=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,3)))
175 S PR=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,4)))
176 S SU=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,5)))
177 S DE=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,6)))
178 DO ADD^DGRRUTL("<namecomp number='"_DGRRCNT_"' last='"_LN_"' first='"_FN_"' middle='"_MI_"' prefix='"_PR_"' suffix='"_SU_"' degree='"_DE_"' ></namecomp>")
179 ;
Note: See TracBrowser for help on using the repository browser.