source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDLB12.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1MAGDLB12 ;WOIFO/LB,MLH - Routine to fix failed DICOM entries ; 04/25/2005 07:46
2 ;;3.0;IMAGING;**11,51,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 Class II medical device. As such, it may not be changed |
13 ;; | in any way. Modifications to this software may result in an |
14 ;; | adulterated medical device under 21CFR820, the use of which |
15 ;; | is considered to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 Q
19LOOP ;
20 N ANS,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
21 N MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP,SUID
22 N MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC
23 N NEWSSN,OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,SITE,STUDYUID,WHY,MAGFIX
24 N KFIXALL ; -- does user hold MAGDFIX ALL security key?
25 ;
26 S KFIXALL=$$SECKEY()
27 S (OOUT,OUT,PREV,FIRST)=0
28 ; select a site - bail if no images to correct or no site selected
29 S STAT=$$SITE(.SITE) Q:'SITE
30 S SUID=0
31 F S SUID=$O(^MAGD(2006.575,"F",SITE,SUID)) Q:SUID=""!(OOUT) D
32 . S MAGIEN=$O(^MAGD(2006.575,"F",SITE,SUID,0)) Q:'MAGIEN
33 . ; if image isn't on file, clean up xrefs
34 . I '$D(^MAGD(2006.575,MAGIEN,0)) D Q
35 . . K ^MAGD(2006.575,"F",SITE,SUID,MAGIEN)
36 . . Q
37 . ; if gateway site isn't the user's site, bail unless the user holds
38 . ; the MAGDFIX ALL security key
39 . I $P($G(^MAGD(2006.575,MAGIEN,1)),U,5)'=DUZ(2),'KFIXALL Q
40 . ;Only process Radiology images...medicine images done by other rtns.
41 . S MAGTYPE=$P($G(^MAGD(2006.575,MAGIEN,"TYPE")),"^") I MAGTYPE'["RAD" Q
42 . I $D(^MAGD(2006.575,MAGIEN,"FIXD")),$P(^MAGD(2006.575,MAGIEN,"FIXD"),"^") Q
43 . I 'FIRST S PREV=MAGIEN,PREVS=SUID,FIRST=MAGIEN
44 . D SET^MAGDLB1
45 . Q
46 Q
47SITE(XSITE) ; select a site for which to process entries
48 ; input: none
49 ; output: .XSITE site number for which to process entries
50 ;
51 ; return: 0 always
52 ;
53 N CNT,KFIXALL,RESULT,SITES
54 S (CNT,XSITE)=0 F S XSITE=$O(^MAGD(2006.575,"F",XSITE)) Q:'XSITE D
55 . Q:'$$FIND1^DIC(4,"","","`"_XSITE)
56 . S CNT=CNT+1,SITES(CNT)=XSITE
57 . Q
58 Q:'CNT 0
59 ;
60 S KFIXALL=$$SECKEY I '$$MDIV S KFIXALL=1
61 ; If not multi-division set the KFIXALL - site should be able to correct any entry
62 I KFIXALL D FIX(.SITES,CNT) Q 0
63 I $D(DUZ(2)) D Q 0
64 . S XSITE=DUZ(2)
65 . I '$D(^MAGD(2006.575,"F",XSITE)) W !,"No entries for division "_$$GET1^DIQ(4,+XSITE,".01","E")
66 . Q
67 D LKUSR(.RESULT,DUZ)
68 I '$D(RESULT(0)) Q 0
69 I $P(RESULT(0),"^")=0 W !,$P(RESULT,"^",2) Q 0
70 ;
71 N EN,II,NSITE,MAGSITE,X
72 S (CNT,XSITE)=0
73 S X=0 F S X=$O(SITES(X)) Q:'X S II=$G(SITES(X)) I II S NSITE(II)=""
74 S II=0
75 F S II=$O(RESULT(II)) Q:'II S EN=$G(RESULT(II)) I $D(NSITE(EN)) S CNT=CNT+1,MAGSITE(CNT)=EN
76 I 'CNT Q 0 ;no matches
77 I CNT=1 S XSITE=$G(MAGSITE(1)) Q 0
78 D FIX(.MAGSITE,CNT) ; select a SITE to fix
79 Q 0
80 ;
81FIX(SITES,CNT) ;SUBROUTINE - Prepare to fix the entries for the user's division entries.
82 ; Multiple divisions have images to be corrected and user has appropriate security key.
83 N DIR,I,Y,X
84 I 'CNT Q
85 I CNT=1 S SITE=$G(SITES(CNT)) Q
86 S I=0 F S I=$O(SITES(I)) Q:'I D
87 . W !,I,") ",$G(SITES(I))," ",$$GET1^DIQ(4,+$G(SITES(I)),".01","E")
88 . Q
89 F D Q:Y'>CNT
90 . S DIR(0)="N:1:"_CNT
91 . S DIR("A",1)="There are images to be corrected for multiple divisions."
92 . S DIR("A")="Select by number (1-"_CNT_")"
93 . D ^DIR
94 . W:Y>CNT " ??"
95 . Q
96 S:Y SITE=$G(SITES(+Y))
97 Q
98 ;
99SECKEY() ;
100 N MAGKY,MAGRSLT
101 I '$D(DUZ) Q 0
102 S MAGKY("MAGDFIX ALL")="MAGDFIX ALL"
103 D OWNSKEY^XUSRB(.MAGRSLT,.MAGKY)
104 I +$G(MAGRSLT("MAGDFIX ALL")) Q 1
105 Q 0
106 ;
107MDIV() ;Multi-divisional flag
108 N CNT,I
109 S (CNT,I)=0
110 F S I=$O(^MAG(2006.1,I)) Q:'I S CNT=CNT+1
111 I CNT>1 Q 1
112 Q 0
113 ;
114LKUSR(RESULT,USER) ;
115 ;RETURNS: 0^Message for failure
116 ; IENs for Institution file entry^
117 ; If the user has more than one division and more than one match in the Imaging Site
118 ; Parameter file, then it returns the 1st matching division entry in the New Person file.
119 I $D(DUZ(2)) S RESULT(0)="1^Number of entries",RESULT(DUZ(2))=DUZ(2) Q
120 N MAGARRAY,CNT,MAGERR,MAGOUT,MAGDV,MAGX
121 S RESULT(0)="0^Your division entry is not part of the Imaging Site Parameter."
122 D GETS^DIQ(200,USER,"16*","I","MAGOUT")
123 ;MAGOUT(200.02,"institution entry,duz,",.01,"I")=institution entry
124 I $D(MAGOUT)=0 Q
125 S MAGX="",CNT=0
126 F S MAGX=$O(MAGOUT(200.02,MAGX)) Q:MAGX="" D
127 . S MAGDV=$P(MAGX,",") I $D(^MAG(2006.1,"B",MAGDV)) S CNT=CNT+1,MAGARRAY(CNT)=MAGDV
128 . Q
129 I 'CNT Q
130 S CNT=0
131 S X=0 F S X=$O(MAGARRAY(X)) Q:'X S CNT=CNT+1,RESULT(X)=$P(MAGARRAY(X),"^")
132 S RESULT(0)=CNT_"^Number of entries"
133 ; Get the 1st institution, the calling routine should check for keys.
134 Q
135 ;
Note: See TracBrowser for help on using the repository browser.