source: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDCCS.m@ 1154

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

initial load of FOIAVistA 6/30/08 version

File size: 8.4 KB
Line 
1MAGDCCS ;WOIFO/MLH - DICOM Correct - Clinical Specialties ; 12/15/2006 13:50
2 ;;3.0;IMAGING;**10,11,85**;16-March-2007;;Build 1039
3 ;; Per VHA Directive 2004-038, this routine should not be modified.
4 ;; +---------------------------------------------------------------+
5 ;; | Property of the US Government. |
6 ;; | No permission to copy or redistribute this software is given. |
7 ;; | Use of unreleased versions of this software requires the user |
8 ;; | to execute a written test agreement with the VistA Imaging |
9 ;; | Development Office of the Department of Veterans Affairs, |
10 ;; | telephone (301) 734-0100. |
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
19L ;Loop thru the entire file for entries that need processing
20 ;The "F" xref is set for unique Study UIDs. The entry setting this xref
21 ;will also have a "RLATE" node with all the Xray images associated with
22 ;that unique Study UID.
23 N ANS,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
24 N MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP
25 N MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC
26 N NEWSSN,OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,STUDYUID,WHY,MAGFIX
27 N KFIXALL ; --- does user hold MAGDFIX ALL key
28 N GWLOC ; -- gateway site
29 ;
30 S KFIXALL=$$SECKEY^MAGDLB12()
31 I '$D(^MAGD(2006.575,"F")) W !,"Nothing to process!" Q
32 S (OOUT,OUT,PREV,FIRST)=0
33 S GWLOC=0
34 F S GWLOC=$O(^MAGD(2006.575,"F",GWLOC)) Q:'GWLOC D
35 . S SUID=""
36 . F S SUID=$O(^MAGD(2006.575,"F",GWLOC,SUID)) Q:SUID=""!(OOUT) D
37 . . S MAGIEN=$O(^MAGD(2006.575,"F",GWLOC,SUID,0)) Q:'MAGIEN
38 . . ; if no main failed image rec, there's a xref prob, so bail
39 . . I '$D(^MAGD(2006.575,MAGIEN,0)) D Q ; clean up xref
40 . . . K ^MAGD(2006.575,"F",GWLOC,SUID,MAGIEN)
41 . . . Q
42 . . ;Only process clinical specialties images... radiology and medicine images done by other rtns.
43 . . S MAGTYPE=$P($G(^MAGD(2006.575,MAGIEN,"TYPE")),"^") I MAGTYPE'="CON" Q
44 . . I $D(^MAGD(2006.575,MAGIEN,"FIXD")),$P(^MAGD(2006.575,MAGIEN,"FIXD"),"^") Q
45 . . I 'FIRST S PREV=MAGIEN,PREVS=SUID,FIRST=MAGIEN
46 . . D SET
47 . Q
48 Q
49DISPLAY ;
50 S OUT=0
51 W !,"**************Processing entry**********"
52 W !!,?2,"PATIENT: ",PAT,?50,"SSN: ",PID,!,"Request/Consultation #: ",CASENO
53 W !,?2,"Equipment: ",MOD,?50,"Model: ",MODEL
54 W !,?2,"Date Processed: ",DATE,?50,"Problem with: ",REASON
55 W !,?2,"Comment: ",COMNT1
56 W !,?2,"Correcting file on server ID: ",MACHID,!,?5,FILE
57 S MSG="Do you want to Correct this entry? "
58 Q
59NEWCASE ;
60 S NEWDFN=$P(MAGDY,"^"),NEWNME=$P(MAGDY,"^",2),NEWSSN=$P(MAGDY,"^",3)
61 S NEWCAS=$P(MAGDY,"^",4),NEWPROC=$P(MAGDY,"^",5),NEWDTI=$P(MAGDY,"^",6)
62 S NEWMUL=$P(MAGDY,"^",7),NEWPIEN=$P(MAGDY,"^",8),PP=$P(MAGDY,"^",9)
63 Q
64ASK() ;
65 N ANS,ASK
66ASK1 S ASK="Y/N/D/Q"
67 I $G(PREV)'=$G(MAGIEN),MAGTYPE="CON" S ASK=ASK_"/P"
68 W !,$G(MSG),"("_ASK_")// " R ANS:600
69 I '$T!(ANS["^") Q "^"
70 I ANS="" Q "N"
71 I "YNDPQyndpq"'[$E(ANS) D G ASK1
72 . W !,"Please respond with one of the following codes."
73 . W !,"Legend: Y=yes, N=no, D=delete, P=Previous entry, and Q=quit",!
74 S ANS=$TR(ANS,"yndpq","YNDPQ")
75 Q $E(ANS)
76CHK ;remove any punctuation before doing comparison on SSN
77 ;stop on 1st check.
78 N OLD,I
79 S OLD="" F I=1:1:$L(PID) I $E(PID,I)?1AN S OLD=OLD_$E(PID,I)
80 I NEWSSN'=OLD D Q
81 . S MSG="Social Security numbers do not match. Update? "
82 I NEWNME'=PAT D Q
83 . S MSG="Patient names do not match. Update? "
84 ;Finally the problem is with the case number...either no longer in "C"
85 ;xref or invalid number provided
86 S MSG="Accession number different. Update? "
87 Q
88NEWDIS ;
89 W !,?2,"****Please review the following: *****"
90 W !,?2,"Previous name: ",PAT,!,?2," New name: ",NEWNME
91 W !,?2,"Previous ssn: ",PID,!,?2," New ssn: ",NEWSSN
92 W !,?2,"Previous request/consultation #: ",CASENO,!,?2," New request/consultation #: ",NEWCAS
93 ; Variable PP already has text message about being part of printset.
94 Q
95UPDT ;
96 N GWLOC ; -- gateway location
97 W !,"Will change the following: " D NEWDIS
98 W !,"Are you sure you want to correct this entry? " S %=2 D YN^DICN
99 I %=-1!(%=2) S OUT=1 Q
100 W !,"Updating the file."
101 S NEWDTIM=$TR(NEWDTI,"0123456789","9876543210")
102 S ^MAGD(2006.575,MAGIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWSSN_"^"_NEWCAS_"^"_NEWDTI_"^"_NEWMUL_"^"_NEWDTIM W "."
103 S ^MAGD(2006.575,MAGIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC W "."
104 ;Same as ^radpt(newdfn,"DT",newdti,"P",newmul,0) & ^RAMIS(71,newpien,0)
105 S GWLOC=$P($G(^MAGD(2006.575,MAGIEN,1)),"^",5)
106 S MACHID=$S(MACHID="":"A",1:MACHID) ; server ID
107 I GWLOC S ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)="" W "."
108 E W !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
109 ;Xref to loop & process entries; processing will be minimal.
110 S MAGFIX(MAGIEN)="F"
111 Q
112SETDEL ;Entry to be deleted
113 N GWLOC ; -- gateway location
114 D LOGERR I ANS="^" S OUT=1 Q
115 S GWLOC=$P($G(^MAGD(2006.575,MAGIEN,1)),"^",5)
116 I GWLOC S ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)="D" W "."
117 E W !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
118 S $P(^MAGD(2006.575,MAGIEN,0),"^",6)="1"
119 S ^MAGD(2006.575,MAGIEN,"FIXD")=1
120 S MAGFIX(MAGIEN)="D"
121 Q
122LOGERR ;Need to record error
123 N DIR,DIRUT,DTOUT,ENTRY,I,MAGERR,MAGOUT,X,Y,WHY,WHO
124 W !! F I=1:1:80 W "*"
125 W !,"*** Will log in error log (file 2006.599). ****"
126 D NOW^%DTC
127 S DIR(0)="F^3:30"
128 S DIR("A")="Reason for deletion"
129 S DIR("A",1)="Please enter a reason for deleting."
130 S DIR("A",2)="For example: TEST PATIENT"
131 D ^DIR
132 I $D(DIRUT)!($D(DTOUT))!(Y="") D S ANS="^" Q
133 . W !,"Can not delete if a reason is not provided."
134 . Q
135 S WHY=Y,WHO=$G(DUZ)
136 I WHO D
137 . D GETS^DIQ(200,DUZ,".01","E","MAGOUT","MAGERR")
138 . Q:$D(MAGERR("DIERR"))
139 . S WHO=$G(MAGOUT(200,DUZ_",",.01,"E"))
140 I WHO="" S WHO="UNKNOWN"
141 I '$D(^MAGD(2006.599,0)) D
142 . S ^MAGD(2006.599,0)="Dicom Error Log^2006.599^^"
143 . Q
144 S ENTRY=$P(^MAGD(2006.599,0),"^",3)+1
145 S $P(^MAGD(2006.599,0),"^",3)=ENTRY
146 S $P(^MAGD(2006.599,0),"^",4)=$P(^MAGD(2006.599,0),"^",4)+1
147 S ^MAGD(2006.599,ENTRY,0)=%_"^"_WHY_"^"_FILE_"^"_MODEL
148 S ^MAGD(2006.599,ENTRY,1)=WHO_"^"_PAT_"^"_PID_"^"_CASENO_"^"_MACHID
149 S ^MAGD(2006.599,"B",%,ENTRY)=""
150 Q
151SET ;
152 S MAGTYPE=$P(^MAGD(2006.575,MAGIEN,"TYPE"),"^")
153 Q:$P($G(^MAGD(2006.575,MAGIEN,"FIXD")),"^") ;Already fixed.
154 ;Only process Clinical Specialties images...radiology & medicine images done by other rtns.
155 I $E(MAGTYPE,1,3)'="CON" Q
156 S DATA=^MAGD(2006.575,MAGIEN,0)
157 S FILE=$P(^MAGD(2006.575,MAGIEN,0),"^")
158 S DATA1=^MAGD(2006.575,MAGIEN,1) ;Case no. info
159 S DATA2=^MAGD(2006.575,MAGIEN,"AMFG") ;Modality info
160 S PAT=$P(DATA,"^",4),PID=$P(DATA,"^",3),REASON=$P(DATA,"^",2)
161 S MOD=$P(DATA2,"^"),MODEL=$P(DATA2,"^",6)
162 S CASENO=$P(DATA1,"^",2),MACHID=$P(DATA1,"^",4)
163 S Y=$P(DATA1,"^",3) X ^DD("DD") S DATE=Y
164 S COMNT1=$G(^MAGD(2006.575,MAGIEN,"ACSTXT")) ;1st line comment.
165 S MACHID=$P(DATA1,"^",4)
166 S ANS="" D DISPLAY S ANS=$$ASK
167 I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 D SETPREV Q
168 I ANS="N" S OUT=1 D SETPREV Q
169 I ANS="P" D CHKPREV Q
170 I ANS="D" D SETDEL,SETPREV Q
171 Q:OUT
172 K MAGDY W !," Lookup by case number or patient name"
173LOOK ;
174 ;D ^MAGDLB2 Q:'$D(MAGDY) Q:MAGDY'[""
175 D EN^MAGDCCS2 Q:'$D(MAGDY) Q:MAGDY'[""
176 D NEWCASE,CHK,NEWDIS S ANS=$$ASK
177 ;W !,"Sorry, under construction (",$T(+0),")... please try again later.",! Q
178 I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 D SETPREV Q
179 I ANS="D" D SETDEL,SETPREV Q
180 I ANS="P" D CHKPREV Q
181 I ANS="N" S OUT=1 D SETPREV Q
182 Q:OUT
183 D UPDT
184 I ANS="P" D CHKPREV Q
185 D SETMAG
186 Q
187DATELOOP(START,STOP) ;Loop thru the "AD" cross reference
188 N MAGIEN,SUID,THEDT,FIRST,OOUT,MAGFIX
189 S THEDT=START-.1,(OOUT,FIRST)=0
190 F S THEDT=$O(^MAGD(2006.575,"AD",THEDT)) Q:'THEDT!(THEDT>STOP)!(OOUT) D
191 . S MAGIEN=0
192 . F S MAGIEN=$O(^MAGD(2006.575,"AD",THEDT,MAGIEN)) Q:'MAGIEN D
193 . . I '$D(^MAGD(2006.575,MAGIEN,0)) K ^MAGD(2006.575,"AD",THEDT,MAGIEN)
194 . . I $D(^MAGD(2006.575,MAGIEN,"TYPE")),$E($P(^MAGD(2006.575,MAGIEN,"TYPE"),"^"),1,3)'="CON" Q
195 . . I 'FIRST S PREV=MAGIEN,FIRST=1
196 . . D SET
197 . . Q
198 . Q
199 Q
200SETPREV ;
201 S PREV=MAGIEN,PREVS=$G(SUID)
202 Q
203SETMAG ;
204 S FIRST=MAGIEN,FIRSTS=$G(SUID),MAGIEN=PREV,SUID=$G(PREVS)
205 S PREV=FIRST,PREVS=FIRSTS
206 Q
207CHKPREV ;
208 S OUT=1 N STATUS
209 I '$D(MAGFIX(PREV)) D SETMAG G SET
210 S STATUS=$S($G(MAGFIX(PREV))="D":"deleted",1:"corrected")
211 W !,"Previous entry has been "_STATUS_".",$C(7)
212 G SET
213 Q
Note: See TracBrowser for help on using the repository browser.