source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m@ 810

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

initial load of FOIAVistA 6/30/08 version

File size: 6.4 KB
Line 
1PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;11/16/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
5 N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
6 W @IOF
7 K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
8 S DELIM=0
9OPTION ;
10 W !,"Select the items to include on the report."
11ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
12 I $D(DTOUT)!$D(DUOUT) Q
13APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
14 I $D(DTOUT)!$D(DUOUT) G ADDSEL
15DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
16 I $D(DTOUT)!$D(DUOUT) G APPSEL
17PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
18 I $D(DTOUT)!$D(DUOUT) G DEMSEL
19 S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
20ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
21 I $D(DTOUT)!$D(DUOUT) G PFACSEL
22DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
23 I $D(DTOUT)!$D(DUOUT) G ELIGSEL
24INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
25 I $D(DTOUT)!$D(DUOUT) G DATASEL
26REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
27 I $D(DTOUT)!$D(DUOUT) G INPSEL
28 S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
29 I $D(DTOUT)!$D(DUOUT) G REMDATA
30 S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
31 I $D(DTOUT)!$D(DUOUT) G OPTION
32DEVICE ;
33 N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
34 S %ZIS="M"
35 S DESC="Patient List Demographic Report"
36 S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
37 S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
38 S SAVE("DDATA(")=""
39 S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
40 I PXRMQUE'="" G EXIT
41 I $D(DTOUT)!$D(DUOUT) G EXIT
42 S DIR(0)="E" D ^DIR
43EXIT D KVA^VADPT
44 K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
45 Q
46 ;
47GETPDATA(DELIM,DC,PLIEN,DDATA) ;
48 N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
49 N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
50 N IEN,IND,JND,KND,LND
51 N LISTNAME,PIECE
52 N PDATA,PNAME,RIEN,TDATA
53 K ^TMP("PXRMPD",$J)
54 S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
55 S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
56 S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
57 S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
58 S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
59 S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
60 S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
61 S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
62 S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
63 S IEN=0
64 F S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0 D
65 . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
66 .;#DBIA 10035
67 . S PNAME=$P($G(^DPT(DFN,0)),U,1)
68 . I PNAME="" S PNAME="UNDEFINED"_DFN
69 . S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
70 . S PDATA=""
71 . I GETDEM D
72 .. N VADM
73 .. D DEM^VADPT
74 .. F IND=1:1:DDATA("DEM","LEN") D
75 ... S JND=$P(DDATA("DEM"),",",IND)
76 ... S KND=0
77 ... F S KND=$O(DDATA("DEM",JND,KND)) Q:KND="" D
78 .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
79 .... S TDATA=$P(VADM(KND),U,PIECE)
80 .... S LND=""
81 .... F S LND=$O(VADM(KND,LND)) Q:LND="" D
82 ..... I TDATA'="" S TDATA=TDATA_"~"
83 ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
84 .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
85 .... S $P(PDATA,U,KND)=TDATA
86 .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
87 . I DDATA("PFAC",0)=1 D
88 ..;DBIA #1850
89 .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
90 .. I TDATA="" S TDATA="NONE"
91 .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
92 . I GETADD D
93 .. N VAPA
94 .. D ADD^VADPT
95 .. F IND=1:1:DDATA("ADD","LEN") D
96 ... S JND=$P(DDATA("ADD"),",",IND)
97 ... S KND=0
98 ... F S KND=$O(DDATA("ADD",JND,KND)) Q:KND="" D
99 .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
100 .... S TDATA=$P(VAPA(KND),U,PIECE)
101 .... S $P(PDATA,U,KND)=TDATA
102 .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
103 . I GETINP D
104 .. N VAIP
105 .. D INP^VADPT
106 .. F IND=1:1:DDATA("INP","LEN") D
107 ... S JND=$P(DDATA("INP"),",",IND)
108 ... S KND=0
109 ... F S KND=$O(DDATA("INP",JND,KND)) Q:KND="" D
110 .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
111 .... S TDATA=$P(VAIN(KND),U,PIECE)
112 .... S $P(PDATA,U,KND)=TDATA
113 .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
114 . I GETELIG D
115 .. N VAEL
116 .. D ELIG^VADPT
117 .. F IND=1:1:DDATA("ELIG","LEN") D
118 ... S JND=$P(DDATA("ELIG"),",",IND)
119 ... S KND=0
120 ... F S KND=$O(DDATA("ELIG",JND,KND)) Q:KND="" D
121 .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
122 .... S TDATA=$P(VAEL(KND),U,PIECE)
123 .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
124 .... S $P(PDATA,U,KND)=TDATA
125 .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
126 . D KVA^VADPT
127 . I GETREM D
128 .. S IND=0
129 .. F S IND=$O(DDATA("REM","IEN",IND)) Q:IND="" D
130 ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
131 ... I PDATA="" Q
132 ... S RIEN=$P(PDATA,U,1)
133 ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
134 . I GETFIND D
135 .. N DL
136 .. F IND=1:1:DDATA("FIND","LEN") D
137 ... S JND=$P(DDATA("FIND"),",",IND)
138 ... S DTYPE=DDATA("FIND",JND,JND)
139 ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
140 ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
141 ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
142 ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
143 ;Get appointment data for all patients on the list.
144 I GETAPP D
145 . N ARRAY,COUNT
146 . S ARRAY(1)=DT,ARRAY(3)="I;R"
147 . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")=""
148 . F IND=1:1:DDATA("APP","LEN") D
149 .. S JND=$P(DDATA("APP"),",",IND)
150 .. S KND=0
151 .. F S KND=$O(DDATA("APP",JND,KND)) Q:KND="" S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
152 . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
153 . S IND=0
154 . F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D
155 .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
156 .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
157 . S COUNT=$$SDAPI^SDAMA301(.ARRAY)
158 . I COUNT=-1 D Q
159 .. D APPERR^PXRMPDRS
160 .. S DDATA("APP","ERROR")=""
161 .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
162 . F IND=1:1:COUNT D
163 .. S DFN=""
164 .. F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D
165 ... S (JND,KND)=0
166 ... F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D
167 .... S DATE=0
168 .... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" D
169 ..... S KND=KND+1
170 ..... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
171 ..... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
172 ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
173 ..... S PDATA=PDATA_U_TDATA
174 ..... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
175 . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
176 I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
177 I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
178 Q
179 ;
180LENGTH(STR,STR1) ;
181 I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
182 E S STR=STR_U_STR1,STR1=""
183 Q
184 ;
185PAGE ;
186 I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
187 .S DIR(0)="E"
188 .W !
189 .D ^DIR K DIR
190 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
191 W:$D(IOF) @IOF
192 S PAGE=PAGE+1
193 I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
194 Q
195 ;
Note: See TracBrowser for help on using the repository browser.