source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXT.m@ 767

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1PXRMXT ; SLC/PJH - Reminder Reports Template Load ;11/21/2005
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ; Called from PXRMYD,PXRMXD
5 ;
6 ;Select Template
7 ;---------------
8START N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG
9 K DIROUT,DIRUT,DTOUT,DUOUT
10 S PXRMTMP="",FOUND=0
11 ;
12 ;Check if any templates exist for this report type
13 Q:'$$FIND(PXRMTYP)
14 ;
15 ;Select template required
16 W !
17 S CNT=0,DIC=810.1,DIC(0)="AEQMZ"
18 S DIC("A")="Select an existing REPORT TEMPLATE or return to continue: "
19 S DIC("S")="I $P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP"
20 D ^DIC
21 I X=(U_U) S DTOUT=1
22 I '$D(DTOUT),('$D(DUOUT)) D
23 .I +Y'=-1 D Q
24 ..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
25 K DIC
26 ;
27 ;Load template into local array
28 I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D
29 .L +^PXRMPT(810.1,$P(Y,U)):0
30 .E W !!?5,"Another user is editing this entry." S DUOUT=1 Q
31 .;Load template into an array
32 .S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD
33 .L -^PXRMPT(810.1,$P(PXRMTMP,U))
34 .;Exit if problem loading template
35 .I $D(MSG) S DTOUT=1 Q
36 .;Display Template information
37 .D:'$D(MSG) ^PXRMXTD
38 ;
39EXIT Q
40 ;
41 ;Check if any templates exist for this report type
42 ;-------------------------------------------------
43FIND(TYP) ;
44 N SUB,FOUND
45 S SUB=0,FOUND=0
46 F S SUB=$O(^PXRMPT(810.1,SUB)) Q:'SUB D Q:FOUND
47 .I $P($G(^PXRMPT(810.1,SUB,0)),U,3)=TYP S FOUND=1
48 Q FOUND
49 ;
50 ;
51 ;Load variables from report template (both INT and EXT)
52 ;------------------------------------------------------
53LOAD N ARRAY
54 D GETS^DIQ(810.1,$P(PXRMTMP,U),"**","IE","ARRAY","MSG")
55 I $D(MSG) D Q
56 .W !!,"File read failed, GETS^DIQ returned the following error message:"
57 .N IC S IC="MSG"
58 .F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC
59 .W !,"Examine the above error message for the reason.",!
60 .H 2
61 ;
62 N MREF,ORDER,ORDERC,SUB,SUB1,XREF
63 ;
64 S SUB1=$O(ARRAY(810.1,""))
65 D XREF^PXRMXTB
66 S SUB="" F S SUB=$O(XREF(SUB)) Q:SUB="" D
67 .S @SUB=$G(ARRAY(810.1,SUB1,XREF(SUB),"I"))
68 ;
69 S PXRMFLD=$G(ARRAY(810.1,SUB1,XREF("PXRMSEL"),"E"))
70 S RUN=$G(ARRAY(810.1,SUB1,XREF("RUN"),"E"))
71 ;Update name if template has been renamed
72 S $P(PXRMTMP,U,2)=$G(ARRAY(810.1,SUB1,XREF("NAME"),"E"))
73 S TITLE=$G(ARRAY(810.1,SUB1,XREF("TITLE"),"E")),$P(PXRMTMP,U,3)=TITLE
74 ;
75MULT ;Clear multiple field arrays
76 K PXRMREM,PXRMPAT,PXRMPRV,PXRMOTM,PXRMFAC,PXRMLCHL,PXRMCS,PXRMCGRP
77 K PXRMFACN,PXRMCSN,PXRMCGRN,PXRMRCAT,REMINDER
78 ;
79 ;Load Multiple fields
80 D SUB(.PXRMREM,810.12,"REMINDER",1)
81 ;Load Patients
82 D SUB(.PXRMPAT,810.16,"PATIENT",1)
83 ;Load Providers
84 D SUB(.PXRMPRV,810.14,"PROVIDER",1)
85 ;Load OE/RR Teams
86 D SUB(.PXRMOTM,810.17,"OERR TEAM",1)
87 ;Load PCMM Teams
88 D SUB(.PXRMPCM,810.18,"PCMM TEAM",1)
89 ;Load Facility codes
90 D SUB(.PXRMFAC,810.13,"FACILITY",1)
91 ;Load Hospital Location codes
92 D SUB(.PXRMLCHL,810.11,"LOCATION",2)
93 ;Load Clinic Stop codes
94 D SUB(.PXRMCS,810.111,"STOP CODE",2)
95 ;Load Clinic Groups
96 D SUB(.PXRMCGRP,810.112,"CLINIC GROUP",1)
97 ;Load Reminder Categories
98 D SUB(.PXRMRCAT,810.113,"REMINDER CATEGORY",1)
99 ;Load Patient lists
100 D SUB(.PXRMLIST,810.114,"PXRMLIST",1)
101 ;
102 ;Build PXRMFACN/PXRMLOCN array IEN's and counters NHL/NFAC
103 D NUM
104 ;
105 ;Build Service Category array
106 I $L(PXRMSCAT)>0 F IC=1:1:$L(PXRMSCAT,",") S PXRMSCAT($P(PXRMSCAT,",",IC))=""
107 ;
108 ;Add Descriptions for Reminders
109 D DES(.PXRMREM,"^PXD(811.9",4)
110 ;Add Descriptions for Reminder Categories
111 D DES(.PXRMRCAT,"^PXRMD(811.7",4)
112 ;Add Descriptions for Teams
113 D DES(.PXRMOTM,"^OR(100.21",3)
114 ;Add Display Codes for Stops
115 D CODE(.PXRMCS,"^DIC(40.7",3)
116 ;
117 ;Sort Reminders into display order
118 D SORT(.PXRMREM,.ORDER)
119 ;Sort Reminders categories into display order
120 D SORT(.PXRMRCAT,.ORDERC)
121 ;
122 ;Combine individual reminders and category reminders
123 D MERGE^PXRMXS1
124 Q
125 ;
126 ;
127 ;Extract INTernal and EXTernal format from ARRAY
128 ;-----------------------------------------------
129SUB(OUTPUT,SUB,VAR,ORD) ;
130 K OUTPUT
131 N IC,INT,EXT,SUB1,DISP
132 S SUB1="",IC=0
133 F S SUB1=$O(ARRAY(SUB,SUB1)) Q:SUB1="" D
134 .S INT=$P($G(ARRAY(SUB,SUB1,MREF(VAR),"I")),";")
135 .S EXT=$G(ARRAY(SUB,SUB1,MREF(VAR),"E"))
136 .S IC=IC+1
137 .I ORD=1 S OUTPUT(IC)=INT_U_EXT
138 .I ORD'=1 S OUTPUT(IC)=EXT_U_INT
139 .I (VAR'="REMINDER")&(VAR'="REMINDER CATEGORY") Q
140 .;Get display order
141 .S DISP=$G(ARRAY(SUB,SUB1,MREF("DISPLAY ORDER"),"I"))
142 .;Store in PXRMREM for display
143 .S OUTPUT(IC)=OUTPUT(IC)_U_DISP
144 .;Put reminders with no sequence number last
145 .I DISP="" S DISP=99
146 .;Create order array for sorting entries later
147 .I VAR="REMINDER" S ORDER(DISP,IC)=""
148 .I VAR="REMINDER CATEGORY" S ORDERC(DISP,IC)=""
149 Q
150 ;
151 ;Build array PXRMFACN and NFAC
152 ;-----------------------------
153NUM N IC,FACN,FACNAM
154 K PXRMLOCN,PXRMCSN,PXRMCGRN,PXRMFACN
155 S IC=""
156 F S IC=$O(PXRMFAC(IC)) Q:IC="" D
157 .S FACN=$P(PXRMFAC(IC),U),FACNAM=$P(PXRMFAC(IC),U,2)
158 .S PXRMFACN(FACN)=FACNAM_U_FACN,NFAC=IC
159 ; Build Array PXRMLOCN and NHL
160 N LOCN
161 F S IC=$O(PXRMLCHL(IC)) Q:IC="" D
162 .S LOCN=$P(PXRMLCHL(IC),U,2)
163 .S PXRMLOCN(LOCN)=IC,NHL=IC
164 ; Build Array PXRMCSN and NCS
165 N CSN
166 F S IC=$O(PXRMCS(IC)) Q:IC="" D
167 .S CSN=$P(PXRMCS(IC),U,2)
168 .S PXRMCSN(CSN)=IC,NCS=IC
169 ; Build Array PXRMCGRN and NCGRP
170 N GRPN
171 F S IC=$O(PXRMCGRP(IC)) Q:IC="" D
172 .S GRPN=$P(PXRMCGRP(IC),U,1)
173 .S PXRMCGRN(GRPN)=IC,NCGRP=IC
174 Q
175 ;
176 ;Add print name to OUTPUT array
177 ;-------------------------------
178DES(OUTPUT,GLOB,POSN) ;
179 N IC,IEN,DES
180 S IC=""
181 F S IC=$O(OUTPUT(IC)) Q:IC="" D
182 .S IEN=$P(OUTPUT(IC),U,1)
183 .X "S DES=$P($G("_GLOB_",IEN,0)),U,3)"
184 .S $P(OUTPUT(IC),U,POSN)=DES
185 Q
186 ;
187 ;Add stop code to OUTPUT array
188 ;-------------------------------
189CODE(OUTPUT,GLOB,POSN) ;
190 N IC,IEN,CODE
191 S IC=""
192 F S IC=$O(OUTPUT(IC)) Q:IC="" D
193 .S IEN=$P(OUTPUT(IC),U,2)
194 .X "S CODE=$P($G("_GLOB_",IEN,0)),U,2)"
195 .S $P(OUTPUT(IC),U,POSN)=CODE
196 Q
197 ;
198 ;Sort reminders into display order (allow for duplicates)
199 ;--------------------------------------------------------
200SORT(INPUT,ORDER) ;
201 N IC,DISP,OUTPUT,IC1
202 S DISP="",IC1=0
203 F S DISP=$O(ORDER(DISP)) Q:DISP="" D
204 .S IC=""
205 .F S IC=$O(ORDER(DISP,IC)) Q:IC="" D
206 ..S IC1=IC1+1,OUTPUT(IC1)=INPUT(IC)
207 ; Move results back
208 K INPUT M INPUT=OUTPUT
209 Q
Note: See TracBrowser for help on using the repository browser.