source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m@ 701

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

revised back to 6/30/08 version

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