source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT2.m@ 1361

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

initial load of WorldVistAEHR
File size: 9.1 KB
RevLine 
[613]1MAGQBUT2 ;WOIFO/SRR/RMP -IMAGE SITE PARAMETERS COMPANION [ 11/08/2001 17:18 ]
2 ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18VSTAV() ;
19 N VER,IEN,ARRAY,VALUE,LATEST
20 S VER=$$VERSION^XPDUTL("IMAGING")
21 S:$T(LAST^XPDUTL)]"" VER=VER_"^"_$$LAST^XPDUTL("IMAGING",VER)
22 Q VER
23IWSV(WSD,WSC,WSV,PLACE) ;IMAGE WORKSTATION VERSIONS
24 N IEN,NODE,RD,OS
25 S RD=$$FMADD^XLFDT($$NOW^XLFDT,-180,"","","")
26 S IEN=0
27 F S IEN=$O(^MAG(2006.81,"C",PLACE,IEN)) Q:IEN'?1N.N D
28 . S NODE=^MAG(2006.81,IEN,0)
29 . Q:($P(NODE,U,3)<RD)
30 . S OS=$P($G(^MAG(2006.81,IEN,1)),U,2)
31 . I $P(NODE,"^",9)'="" D
32 . . S INDEX=$P(NODE,"^",9),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
33 . . S WSD(INDEX)=$G(WSD(INDEX))+1
34 . I $P(NODE,"^",13)'="" D
35 . . S INDEX=$P(NODE,"^",13),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
36 . . S WSC(INDEX)=$G(WSC(INDEX))+1
37 . I $P(NODE,"^",15)'="" D
38 . . S INDEX=$P(NODE,"^",15),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
39 . . S WSV(INDEX)=$G(WSV(INDEX))+1
40 Q
41DICOMV(DCMG) ;Version of DICOM
42 N X,ARRAY,IEN,NAME
43 S X=""
44 F S X=$O(^MAG(2006.83,"B",X)) Q:X="" D
45 . S IEN=$O(^MAG(2006.83,"B",X,"")) Q:IEN'?1N.N
46 . S DCMG($P(^MAG(2006.83,IEN,0),U,3))=$G(DCMG($P(^MAG(2006.83,IEN,0),U,3)))+1
47 Q $S($D(DCMG):1,1:0)
48VISTARV() ;
49 Q $$VERSION^XPDUTL("MAGJ RADIOLOGY")
50MAGSYS(LIST) ;
51 N VAIEN,NODE,MGIEN,UNAME,TDATE
52 S MGIEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
53 S VAIEN=0
54 F S VAIEN=$O(^XUSEC("MAG SYSTEM",VAIEN)) Q:VAIEN'?1N.N D
55 . S UNAME=$$GET1^DIQ(200,VAIEN,.01)
56 . Q:UNAME=""
57 . ;CHECK FOR TERMINATION DATE
58 . S TDATE=$$GET1^DIQ(200,VAIEN,9.2)
59 . Q:((TDATE'="")&(TDATE<$$NOW^XLFDT))
60 . ;the next line screens existing 'MAG SERVER' members
61 . I MGIEN?1N.N,$$FIND1^DIC(3.81,","_MGIEN_",","QA",VAIEN,"","","ERR") Q
62 . S LIST(VAIEN)=VAIEN_"^"_UNAME
63 Q
64IMPAR(RESULT,QIEN) ;
65 N INDX,CNT
66 S (INDX,CNT)=0
67 F S INDX=$O(^MAG(2006.034,QIEN,1,INDX)) Q:INDX'?1N.N D
68 . S CNT=CNT+1
69 . S RESULT(CNT)=$G(^MAG(2006.034,QIEN,1,INDX,0))
70 I CNT<1 S RESULT(0)="0^Corrupted Import Array"
71 E S RESULT(0)="1"
72 Q
73SNS(PLACE) ;
74 N RESULT,INDEX
75 S INDEX=0
76 S RESULT=$P(^MAG(2006.1,PLACE,0),U,2)
77 F S INDEX=$O(^MAG(2006.1,PLACE,4,INDEX)) Q:INDEX'?1N.N D
78 . S RESULT=RESULT_U_$P($G(^MAG(2006.1,PLACE,4,INDEX,0)),U)
79 Q RESULT
80CHKIMG(IEN) ;
81 ; Given an Image IEN, return:
82 ; 1: Case # or accession #
83 ; 2: Parent application~IEN
84 ; 3: Application DFN
85 ; 4: Image DFN
86 ; 5: Flag: true = all DFNs in images in same parent group are identical
87 ; 6: Image object Class
88 ;
89 ; PF: Parent Data file number
90 ; PT(): Parent file data dictionary
91 ; PD0: Parent (Global root) IEN (D0)
92 ; PD1: Lab Parent Global Root (D1)
93 ; PD2: Parent Data File Image Pointer
94 ; T(): Error types
95 ; IDFN: Image file entry DFN
96 ; PDFN: Parent file DFN
97 ; GRG: virtual Parent File Image Multiple
98 ; IOR: Image Object Referenced (by parent)
99 N GF,GP,G0,GR,GRD,GRG,GR0,IDFN,IENV,P0,PD0,PD1,PD2,PF,PT,X0,X2,N0,N1,R,T,GPDFN,PACS,IOR,APR,I,PDFN
100 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
101 S R="^^^^^"
102 S T(1)="No Image ptr in AP"
103 S T(2)="GP has no Images"
104 S T(3)="Conflicting AP & Image DFNs"
105 S T(4)="Invalid Image Ptr to AP"
106 S T(5)="Conflicting GP and GO DFN"
107 S T(6)="GP & GO AP Mismatch"
108 S T(7)="GP Missing GO ptr"
109 S T(8)="No AP Ptr"
110 S T(9)="No AP Entry ptr"
111 S T(10)="No AP Mult ptr"
112 S T(11)="GO DFN mismatches"
113 S T(12)="Null Image Ptr"
114 S T(13)="Invalid Image Ptr"
115 S T(14)="Invalid Image Ptr to AP"
116 S T(15)="Image Entry is structurally abnormal"
117 S T(16)="Missing Group Objects"
118 S T(21)="DFN Mismatches in AP Image Mult"
119 I IEN="" S $P(R,"^",5)=T(12)_"~1" Q R
120 S X0=$G(^MAG(2005,IEN,0))
121 I X0="" S $P(R,"^",5)=T(13)_"~1" Q R
122 S IDFN=$P(X0,"^",7),$P(R,"^",4)=IDFN
123 S PT(3.9)="^XMB(3.9,PD0,|Mail message||2|^XMB(3.9,PD0,2005,|MAIL"
124 S PT(63)="^LR(PD0,GF,PD1,|Autopsy (microscopic)|AY|1|^LR(PD0,GF,PD1,2005,|AUM"
125 S PT(63.02)="^LR(PD0,GF,PD1,|Electron microscopy|EM|1|^LR(PD0,GF,PD1,2005,|EM"
126 S PT(63.08)="^LR(PD0,GF,PD1,|Surgical pathology|SP|1|^LR(PD0,GF,PD1,2005,|SP"
127 S PT(63.09)="^LR(PD0,GF,PD1,|Cytology|CY|1|^LR(PD0,GF,PD1,2005,|CY|"
128 S PT(63.2)="^LR(PD0,GF,PD1,|Autopsy (gross)|AU|1|^LR(PD0,GF,PD1,2005,|AUG"
129 S PT(70)="^RADPT(PDFN,|Radiology Patient||1|"
130 S PT(74)="^RARPT(PD0,|Radiology||2|^RARPT(PD0,2005,|RAD"
131 S PT(130)="^SRF(PD0,|Surgery||1|^SRF(PD0,2005,|SUR"
132 S PT(691)="^MCAR(691,PD0,|Echocardiogram||2|^MCAR(691,PD0,2005,|ECHO"
133 S PT(691.1)="^MCAR(691.1,PD0,|Cardiac catheterization||2|^MCAR(691.1,PD0,2005,|CATH"
134 S PT(691.5)="^MCAR(691.5,PD0,|Electrocardiography||2|^MCAR(691.5,PD0,2005,|ECG"
135 S PT(694)="^MCAR(694,PD0,|Hematology||2|^MCAR(694,PD0,2005,|HEM"
136 S PT(699)="^MCAR(699,PD0,|Endoscopy||2|^MCAR(699,PD0,2005,|ENDO"
137 S PT(699.5)="^MCAR(699.5,PD0,|Medicine||2|^MCAR(699.5,PD0,2005,|GEN"
138 S PT(8925)="^TIU(8925,PD0,|TIU||2|^TIU(8925.91,""ADI"",PD0,|TIU"
139 S IC=$$IC(IEN,.N0,.N2,.GPDFN),$P(R,U,6)=IC
140 I IC="ER" S $P(R,U,5)=T(15)_"~1" Q R
141 I IC["GP",'$O(^MAG(2005,IEN,1,0)) S $P(R,U,5)=T(2)_"~1" Q R
142 D PF(IEN,IC,N0,.PF,.PD0,.PD1,.PD2,.PACS,.IOR,.APR)
143 I "GP^GO"[IC D Q:$P(R,U,5)'="" R
144 . S I=0
145 . F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N D
146 . . I '$D(^MAG(2005,$P($G(^MAG(2005,IOR,1,I,0)),U),0)) S $P(R,U,5)=T(16)_$S(IC="GO":"~2",1:"~1")
147 . . Q
148 I IC["GO" S $P(R,U,6)=$P(R,U,6)_"~"_IOR
149 I PD2'?1N.N,(('PACS)&(PD0?1N.N)) S $P(R,U,5)=T(10)_$S(IC["GO":"~2",1:"~1") Q R
150 I IC["GO" D Q:$P(R,U,5)'="" R
151 . N I,J
152 . S (I,J)=0
153 . F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N S:IEN=$P($G(^MAG(2005,IOR,1,I,0)),U,1) J=1
154 . S:J=0 $P(R,U,5)=T(7)_"~2"
155 . Q
156 I IC["GO",IDFN'=GPDFN S $P(R,U,5)=T(5)_"~1",$P(R,U,3)=GPDFN Q R
157 I IC["GO" D Q:$P(R,U,5)'="" R
158 . N I,J
159 . S I=0
160 . F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N D Q:$P(R,U,5)'=""
161 . . S J=$P($G(^MAG(2005,IOR,1,I,0)),U)
162 . . I $P($G(^MAG(2005,J,0)),U,7)'=IDFN S $P(R,U,5)=T(11)_"~2",$P(R,U,3)=$P($G(^MAG(2005,J,0)),U,7)
163 . . Q
164 I IC["GO",PACS,(($P(N2,U,6,7)'="")&($P(N2,U,6,7)'="^")),$P(N2,U,6,7)'=$P($G(^MAG(2005,$P(N0,U,10),2)),U,6,7) D Q R
165 . S $P(R,U,5)=T(6)_"~1",$P(R,U,3)=$P(^MAG(2005,IOR,0),U,7) Q
166 I (PF\1=63),PD1'?1N.N,PD1'?1N.N1"."1N.N Q R
167 I PF?1N.E,$D(PT(+PF)),PD0?1N.N D
168 . S $P(R,"^",2)=$P(PT(PF),"|",6)_"~"_PD0
169 . S GR=$P(PT(PF),"|",1),GR0=GR_"0)"
170 . S GF=$P(PT(PF),"|",3),GP=$P(PT(PF),"|",4)
171 . S T=$P(PT(PF),"|",5),GRD=T_"G0,0)",GRG=T_"G0)"
172 E D Q R
173 . S:((IC["GP")&($P(R,U,5)="")) $P(R,U,5)="1"
174 S P0=$G(@GR0)
175 I P0="" S $P(R,"^",5)=T(4)_$S((('PACS)&(IC["GO")):"~2",1:"~1") Q R
176 S PDFN=$S(PF\1=63:$P(^LR(PD0,0),U,3),$P(P0,"^",GP)'="":$P(P0,"^",GP),1:PDFN)
177 I 'PDFN,$P($G(^VA(200,IDFN,0)),"^",1)=PDFN S PDFN=IDFN
178 S $P(R,"^",3)=PDFN
179 I PDFN'=IDFN S $P(R,U,5)=T(3)_$S((('PACS)&(IC["GO")):"~2",1:"~1") Q R
180 I PF=74 D
181 . S GR=$P(PT(70),"|",1),GR0=GR_"0)"
182 . S GF=$P(PT(70),"|",3),GP=$P(PT(70),"|",4)
183 . S P0=$G(@GR0),$P(R,"^",3)=$P(R,"^",3)_"~"_$P(P0,"^",GP)
184 S T=1,G0=0,IENV=0
185 F S G0=$O(@GRG) Q:'G0 Q:$P(R,U,5)'="" D I 'T K PT Q
186 . I PF=8925 D Q
187 . . I '$D(^MAG(2005,+G0,0)) S $P(R,U,5)=T(14)_$S((('PACS)&(IC["GO")):"~2",1:"~1")
188 . . S:G0=IOR IENV=1
189 . . I $P($G(^MAG(2005,+G0,0)),"^",7)'=IDFN S $P(R,U,5)=T(21)_"~2",$P(R,U,3)=$P($G(^MAG(2005,+G0,0)),"^",7)
190 . . Q
191 . I '$D(^MAG(2005,+$P($G(@GRD),"^",1),0)) S $P(R,U,5)=T(14)_$S((('PACS)&(IC["GO")):"~2",1:"~1")
192 . I $P($G(^MAG(2005,+$P($G(@GRD),"^",1),0)),"^",7)'=IDFN D Q
193 . . S $P(R,U,5)=T(21)_"~2",$P(R,U,3)=$P($G(^MAG(2005,+$P($G(@GRD),"^",1),0)),"^",7) Q
194 . I PF=63 S:+$P($G(^LR(PD0,GF,PD1,2005.1,G0,0)),U)=IOR IENV=1
195 . I PF=63.2 S:+$P($G(^LR(PD0,GF,PD1,2005,G0,0)),U)=IOR IENV=1
196 . S:+$P($G(@GRD),"^",1)=IOR IENV=1
197 . Q
198 Q:$P(R,U,5)'="" R
199 I IC["GP" S $P(R,U,5)="1"
200 I IENV=0 S $P(R,U,5)=T(1)_"~1"
201 I PF=74 S $P(R,"^",1)=$P(P0,"^",1)
202 K PT
203 Q R
204IC(IEN,N0,N2,GPDFN) ;
205 S N0=$G(^MAG(2005,IEN,0))
206 S N1=$G(^MAG(2005,IEN,1,0))
207 S N2=$G(^MAG(2005,IEN,2))
208 I ($P(N0,U,2)="")&($P(N0,U,10)="")&($P(N1,U,4)>0) Q "GP"
209 I (($P(N0,U,2)'="")&($P(N0,U,10)?1N.N)&(N1="")) D Q "GO"
210 . S GPDFN=$P($G(^MAG(2005,$P(N0,U,10),0)),U,7) Q
211 I ($P(N0,U,2)'="")&($P(N0,U,10)'?1N.N)&(N1="") Q "NG"
212 Q "ER"
213PF(IEN,IC,N0,PF,PD0,PD1,PD2,PACS,IOR,APR) ;
214 N N2
215 S PACS=$S($D(^MAG(2005,IEN,"PACS")):1,1:0)
216 S IOR=$S(IC="GO":$P($G(N0),U,10),1:IEN)
217 I ((IC="GP")!(IC="NG")!((PACS)&(IC="GO"))) S N2=$G(^MAG(2005,IEN,2))
218 I ((IC="GO")&('PACS)) S N2=$G(^MAG(2005,IOR,2))
219 S PF=$P(N2,"^",6),PD0=$P(N2,"^",7),PD1=$P(N2,"^",10),PD2=$P(N2,"^",8)
220 I PACS S APR=$S(PD0?1N.N:1,1:0)
221 E S APR=$S(((PF'="")&(PD0?1N.N)):1,$P($G(^MAG(2005,IOR,100)),U)?1N.N:1,$P($G(^MAG(2005,IOR,0)),U,6)="18":1,1:0)
222 Q
Note: See TracBrowser for help on using the repository browser.