source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGDRPC9.m@ 1147

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

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1MAGDRPC9 ;WOIFO/EdM - Imaging RPCs ; 11/03/2005 14:48
2 ;;3.0;IMAGING;**50**;26-May-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 ;;
18 Q
19 ;
20NEWUID(OUT,OLD,NEW,IMAGE) ; RPC = MAG NEW SOP INSTANCE UID
21 N D0,L,X
22 S IMAGE=+$G(IMAGE),OLD=$G(OLD)
23 S:$G(NEW)="" NEW=OLD
24 S D0=0 S:OLD'="" D0=$O(^MAG(2005,"P",OLD,""))
25 I IMAGE,D0,IMAGE'=D0 S OUT="-1,UID cannot belong to multiple images ("_IMAGE_"/"_D0_")" Q
26 I IMAGE,'D0 S D0=IMAGE
27 I 'D0 S OUT="-2,Cannot find image with UID "_OLD Q
28 S OUT=$P($G(^MAG(2005,D0,"SOP")),"^",2) Q:OUT'=""
29 S L=$L(NEW,".")-1,X=$P(NEW,".",L+1),L=$P(NEW,".",1,L)_"."
30 L +^MAG(2005,"P"):1E9 ; Background process MUST wait
31 S OUT="" F D Q:OUT'=""
32 . S OUT=L_X
33 . I $L(OUT)>64 S OUT="-3,Cannot use "_NEW_" to create valid UID" Q
34 . I $D(^MAG(2005,"P",OUT)) S OUT="",X=X+1 Q
35 . S $P(^MAG(2005,D0,"SOP"),"^",2)=OUT
36 . S ^MAG(2005,"P",OUT,D0)=1
37 . Q
38 L -^MAG(2005,"P")
39 Q
40 ;
41NEXT(OUT,SEED,DIR) ; RPC = MAG RAD GET NEXT RPT BY DATE
42 N D2,DFN,EXAMDATE,NAME
43 ;
44 ; ^RADPT(DFN,"DT",D1,"P",D2,0) = Data, $P(17) = pointer to report
45 ; ^RADPT("AR",9999999.9999-D1,DFN,D1)="" ; IA # 65
46 ;
47 ; OUT = report_pointer ^ ExamDate ^ Patient ^ D2
48 ;
49 S SEED=$G(SEED),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order
50 S EXAMDATE=$P(SEED,"^",1),DFN=$P(SEED,"^",2),D2=$P(SEED,"^",3)
51 S OUT=0 F D Q:OUT
52 . I EXAMDATE="" S EXAMDATE=$O(^RADPT("AR",""),DIR),DFN="" ; IA # 65
53 . I EXAMDATE="" S OUT=-1 Q
54 . I DFN="" S DFN=$O(^RADPT("AR",EXAMDATE,""),DIR) ; IA # 65
55 . I DFN="" S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),D2="" Q ; IA # 65
56 . S:'D2 D2=$S(DIR>0:0,1:" ")
57 . S D2=$O(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2),DIR) ; IA # 1172
58 . I 'D2 D Q
59 . . S DFN=$O(^RADPT("AR",EXAMDATE,DFN),DIR),D2="" ; IA # 65
60 . . I 'DFN D
61 . . . S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),DFN="" ; IA # 65
62 . . . I EXAMDATE="" S OUT=-1
63 . . . Q
64 . . Q
65 . S OUT=$P($G(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2,0)),"^",17) ; IA # 1172
66 . S:OUT OUT=OUT_"^"_EXAMDATE_"^"_DFN_"^"_D2
67 . Q
68 Q
69 ;
70NXTPTRPT(OUT,DFN,RARPT1,DIR) ; RPC = MAG RAD GET NEXT RPT BY PT
71 S DFN=$G(DFN)
72 I 'DFN S OUT="-1,Patient DFN not passed" Q
73 I '$D(^RARPT("C",DFN)) S OUT="-2,Patient does not have any radiology reports" Q ; IA # 2442
74 S RARPT1=$G(RARPT1),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order
75 S OUT=$O(^RARPT("C",DFN,RARPT1),DIR) ; IA # 2442
76 Q
77 ;
78GETICN(OUT,DFN) ; RPC = MAG DICOM GET ICN
79 S OUT=$$GETICN^MPIF001(DFN)
80 Q
81 ;
82CLEAN ; Overflow from MAGDRPC4
83 N STUID
84 S S0=$P(SENT(I),"^",1),S1=$P(SENT(I),"^",2)
85 Q:'$D(^MAGDOUTP(2006.574,S0,1,S1))
86 L +^MAGDOUTP(2006.574,S0,1,0):1E9 ; Background process MUST wait
87 S X=$G(^MAGDOUTP(2006.574,S0,0)),LOC=$P(X,"^",4),PRI=+$P(X,"^",5)
88 S STS=$P($G(^MAGDOUTP(2006.574,S0,1,S1,0)),"^",2)
89 K ^MAGDOUTP(2006.574,S0,1,S1)
90 I LOC'="",STS'="" K ^MAGDOUTP(2006.574,"STS",LOC,PRI,STS,S0,S1)
91 S X=$G(^MAGDOUTP(2006.574,S0,1,0))
92 S $P(X,"^",4)=$P(X,"^",4)-1
93 S ^MAGDOUTP(2006.574,S0,1,0)=X
94 L -^MAGDOUTP(2006.574,S0,1,0)
95 Q:$O(^MAGDOUTP(2006.574,S0,1,0))
96 L +^MAGDOUTP(2006.574,0):1E9 ; Background process MUST wait
97 S STUID=$G(^MAGDOUTP(2006.574,S0,2))
98 K ^MAGDOUTP(2006.574,S0)
99 K:STUID'="" ^MAGDOUTP(2006.574,"STUDY",STUID)
100 S X=$G(^MAGDOUTP(2006.574,0))
101 S $P(X,"^",4)=$P(X,"^",4)-1
102 S ^MAGDOUTP(2006.574,0)=X
103 L -^MAGDOUTP(2006.574,0)
104 Q
105 ;
106IENLOOK ; Overflow from MAGDRPC4
107 ; lookup image by the IEN
108 N D0,GROUPIEN,P,X
109 S NUMBER=+$P(NUMBER,"`",2)
110 ; patient safety checks
111 D CHK^MAGGSQI(.X,NUMBER) I +$G(X(0))'=1 D Q
112 . S OUT(1)="-9,"_$P(X(0),"^",2,999)
113 . Q
114 S GROUPIEN=$P($G(^MAG(2005,NUMBER,0)),"^",10)
115 I GROUPIEN D CHK^MAGGSQI(.X,GROUPIEN) I +$G(X(0))'=1 D Q
116 . S OUT(1)="-10,Group #"_GROUPIEN_": "_$P(X(0),"^",2,999)
117 . Q
118 ;
119 S X=$G(^MAG(2005,NUMBER,2)),P=$P(X,"^",6),D0=$P(X,"^",7)
120 I 'P!'D0 D ; get parent from group
121 . S:GROUPIEN X=$G(^MAG(2005,GROUPIEN,2)),P=$P(X,"^",6),D0=$P(X,"^",7)
122 . Q
123 ;
124 S OUT(2)=P_"^"_D0_"^"_NUMBER_"^" ; result w/o Accession Number
125 I 'P!'D0 S OUT(1)="-6,Warning - Parent file entry is not present - no Accession Number."
126 E I P=74 D
127 . S X=P_"^"_D0_"^"_NUMBER_"^"_$P($G(^RARPT(D0,0)),"^",1) ; IA # 1171
128 . S OUT(1)=1,OUT(2)=X
129 . Q
130 E I P=8925 D
131 . ; get pointer from TIU to consult request
132 . S X=$$GET1^DIQ(8925,D0,1405,"I") ; IA ???
133 . I $P(X,";",2)="GMR(123," D
134 . . S X=P_"^"_D0_"^"_NUMBER_"^GMRC-"_$P(X,";")
135 . . S OUT(1)=1,OUT(2)=X
136 . . Q
137 . E S OUT(1)="-8,Problem with parent file "_P_", internal entry number "_D0_" - no Accession Number."
138 . Q
139 E S OUT(1)="-7,Parent file "_P_" not yet supported - no Accession Number."
140 Q
141 ;
Note: See TracBrowser for help on using the repository browser.