source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 9.2 KB
Line 
1ORWRP ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262**;Dec 17, 1997;Build 3
3 ;
4LABLIST(LST) ; -- report list for labs tab
5 ; RPC: ORWRP LAB REPORT LIST
6 N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD
7 S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0
8 D SETITEM(ROOT,"[LAB REPORT LIST]")
9 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST")
10 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D
11 . Q:$P(X0,"^",12)="L"
12 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
13 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
14 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
15 . D SETITEM(.ROOT,X)
16 D SETITEM(.ROOT,"$$END")
17 Q
18LIST(LST) ; -- report lists for reports tab
19 ; RPC: ORWRP REPORT LIST
20 N EOF,ROOT
21 S EOF="$$END",ROOT=$NA(LST)
22 K @ROOT
23 D GETRPTS(.ROOT,.EOF) ; -report list
24 D GETHS(.ROOT,.EOF) ; -health summary types
25 D GETDT(.ROOT,.EOF) ; -date ranges
26 Q
27GETCOL(ROOT,IFN) ; -- get Column headers for ListView
28 N I,J,X,VAL
29 Q:'$G(IFN)
30 S I=0,ROOT=$NA(ROOT)
31 F S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I D
32 . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0
33 . F S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D
34 .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I)
35 .. D SETITEM(.ROOT,X)
36 Q
37GETRPTS(ROOT,EOF) ; -- get report list
38 N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD
39 D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
40 S (CNT,I)=0
41 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D
42 . Q:$P(X0,"^",12)="L"
43 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
44 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
45 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
46 . D SETITEM(.ROOT,X)
47 D SETITEM(.ROOT,"$$END")
48 Q
49GETHS(ROOT,EOF) ; --get health summary types
50 N C,I,IFN,ORHSPARM,ORERR,X,T
51 K ^TMP("ORHSPARM",$J)
52 S ORHSROOT="^TMP(""ORHSPARM"",$J)"
53 I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D
54 . F S I=$O(^GMT(142,"B",I)) Q:I="" S IFN=$O(^(I,0)) Q:'IFN D
55 .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X)
56 .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1"
57 .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report"
58 I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D
59 . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR)
60 . Q:$G(ORERR)
61 . S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report"
62 D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
63 S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I D SETITEM(.ROOT,"h"_@ORHSROOT@(I))
64 D SETITEM(.ROOT,EOF)
65 Q
66GETDT(ROOT,EOF) ; -- get date range choices
67 N I,X
68 D SETITEM(.ROOT,"[DATE RANGES]")
69 F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF D SETITEM(.ROOT,"d"_X)
70 Q
71DTLIST ; -- list of date ranges
72 ;<number of days>^ <display text>
73 ;;S^Date Range...
74 ;;0^Today
75 ;;7^One Week Back
76 ;;14^Two Weeks Back
77 ;;30^One Month Back
78 ;;180^Six Months Back
79 ;;365^One Year Back
80 ;;$$END
81 ;
82SETITEM(ROOT,X) ; -- set item in list
83 S @ROOT@($O(@ROOT@(9999),-1)+1)=X
84 Q
85RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text
86 ;ROOT=Output in ^TMP("ORDATA",$J)
87 ;DFN=Patient DFN ; ICN for foriegn sites
88 ;RPTID=Unique id for the report_";"_Remote Id_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc)
89 ;HSTYPE=Health Sum Type
90 ;DTRANGE=# days back from today
91 ;EXAMID=Rad exam ID
92 ;ALPHA=Start date (lieu of DTRANGE)
93 ;OMEGA=End date (lieu of DTRANGE)
94 ; RPC: ORWRP REPORT TEXT
95 ;
96 N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT
97 K ^TMP("ORDATA",$J)
98 S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":")
99 I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls
100 S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
101 F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D
102 . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)="R" S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3)
103 I '$L(X0) D NOTYET(.ROOT) Q
104 S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6)
105 I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q
106 I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q
107 I $G(ALPHA) S X=ALPHA-$G(OMEGA) D
108 . I X<0 S X=X*(-1)
109 . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE=""
110 I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA=""
111 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959"
112 I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959"
113 ;S ID=$G(HSTAG),$P(ID,";",5,8)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)
114 S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE
115 I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4)
116 I $L($G(HSTYPE)) M ID=HSTYPE
117 I $L($G(EXAMID)) M ID=EXAMID
118 S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
119 I REMOTE S GO=0 D Q:'GO
120 . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q
121 . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN)
122 . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q
123 . S GO=+$P(X0,"^",3)
124 . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
125 S %ZIS="0N"
126 D @OUT
127 Q
128NOTYET(ROOT) ; -- not available
129 D SETITEM(.ROOT,"Report not available at this time.")
130 Q
131START(RM,GOTO,ORIOSL) ;
132 ;RM=Right margin
133 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS
134 S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP"
135 D HFSOPEN(ORHANDLE,ORHFS,"W")
136 I POP D Q
137 . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file")
138 D IOVAR(.ORIO,.RM,.ORIOSL)
139 N $ETRAP,$ESTACK
140 S $ETRAP="D ERR^ORWRP Q"
141 U IO
142 D @GOTO
143 D HFSCLOSE(ORHANDLE,ORHFS)
144 Q
145ERR ;Error trap
146 S $ETRAP="D UNWIND^ORWRP Q"
147 N %ZIS
148 S %ZIS="0N"
149 D @^%ZOSF("ERRTN") ;file error
150 I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE)
151 I $D(ORHFS) D
152 . N ORARR,OROK
153 . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file
154 S $ECODE=",UOR69 error during CPRS report build,"
155 Q
156UNWIND ;Unwind Error stack
157 Q:$ESTACK>1 ;pop stack
158 ;
159 Q
160HFS() ; -- get hfs file name
161 N H
162 S H=$H
163 Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
164HFSOPEN(HANDLE,ORHFS,ORMODE) ;
165 D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP
166 Q
167IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device
168 N IFN,IFN1
169 S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS")
170 I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN
171 I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^"))
172 I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3))
173 Q
174HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data
175 N ORDEL,X,%ZIS
176 S %ZIS="0N"
177 I IO[ORHFS D CLOSE^%ZISH(HANDLE)
178 S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)=""
179 K @ROOT
180 S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4)
181 D STRIP
182 S X=$$DEL^%ZISH(,$NA(ORDEL))
183 Q
184USEHFS ; -- use host file to build global array
185 N OROK,SECTION
186 S SECTION=0
187 D INIT
188 S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q
189 D STRIP
190 N ORARR S ORARR(ORHFS)=""
191 S OROK=$$DEL^%ZISH("",$NA(ORARR))
192 Q
193INIT ; -- initialize counts and global section
194 S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION))
195 K @ROOT
196 Q
197FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR
198 N I
199 F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION
200 Q
201STRIP ; -- strip off control chars
202 N I,X
203 S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D
204 . I X[$C(8) D ;BS
205 .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _
206 .. S (X,@ROOT@(I))=$TR(X,$C(8),"")
207 . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF
208 Q
209WINDFLT(ORY) ;Windows printer as default?
210 S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT")
211 Q
212GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user
213 N IEN,X0,ENT
214 S ENT="ALL"
215 I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC
216 I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q
217 S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0
218 Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0)
219 S Y=IEN_";"_$P(X0,U)
220 Q
221SAVDFPRT(Y,ORDEV) ; Save new default printer for user
222 N ORPAR,ORERR,ORWINDEF
223 Q:$L(ORDEV)=0
224 ; Reset Windows printer default to True/False
225 S ORPAR="ORWDP WINPRINT DEFAULT"
226 I ORDEV="WIN" S ORWINDEF="Y"
227 E S ORWINDEF="N"
228 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
229 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
230 Q:ORDEV="WIN"
231 ; If not Windows printer selected, save VistA default printer
232 S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV
233 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
234 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
235 Q
Note: See TracBrowser for help on using the repository browser.