source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGDRCU2.m@ 1697

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1MAGDRCU2 ;WOIFO/PMK - List entries in ^MAG(2006.5839) ; 06/06/2005 09:29
2 ;;3.0;IMAGING;**10,11,51**;26-August-2005
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 ; This routine lists the entries in the temporary Imaging/CPRS Consult
19 ; Request Tracking association file
20 ;
21 ;
22 ; XXXX XXX X
23 ; XX XX XX XX
24 ; XX XXXX XX XXX XXXXXXX XX XXX XX XXXXX
25 ; XX XX XX XXX XX XX XX XX XX XX
26 ; XX X XX XX XX XX XXXXXXX XX XX XX XX
27 ; XX XX XX XX XX XX XX XX XX XX XX XX
28 ; XXXX XXXX XX XX XXXXXXX XXX XX XXXX XXX
29 ;
30 ;
31 ; Routine 2/2 in for application
32 ;
33REPORT ; now scan the database and generate the report
34 N D0,DATE,DFN,DOB,EXAMDATE,GMRCDFN,GMRCIEN,I,LASTDFN,LASTEXAM
35 N MAGIEN,MAGIEN1,NOW,ORDRDATE,PAGE,PID,PNAME,REQTYPE
36 N SEX,STATUS,STOP,VA,VAERR,VADM,WRK,X,Y,Z
37 ;
38 S WRK=$NA(^TMP("MAG",$J,"GMRC"))
39 D NOW^%DTC,YX^%DTC S NOW=Y
40 K @WRK
41 ;
42 S D0=0
43 I $E(IOST)="C" W !,"Building"
44 F S D0=$O(^MAG(2006.5839,D0)) Q:'D0 S X=^(D0,0) D
45 . I $P(X,"^",1)'="123" D
46 . . N MSG
47 . . S MSG(1)="Problem with Temporary Imaging/CPRS file"
48 . . S MSG(2)="Entry #"_D0_" in ^MAG(2006.5839) does not begin"
49 . . S MSG(3)="with 123 - it doesn't point to CPRS Consult Request Tracking"
50 . . S MSG(4)="Bad record: <<"_X_">>"
51 . . D ERROR(.MSG)
52 . . Q
53 . E D
54 . . S GMRCIEN=$P(X,"^",2),MAGIEN=$P(X,"^",3)
55 . . S DFN=$P(^MAG(2005,MAGIEN,0),"^",7)
56 . . S GMRCDFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
57 . . I DFN'=GMRCDFN D
58 . . . N MSG
59 . . . S MSG(1)="DICOM IMAGE PROCESSING ERROR - CONSULT/IMAGING PATIENT MISMATCH"
60 . . . S MSG(2)="The image and the consult point to different patients."
61 . . . S MSG(3)=""
62 . . . S MSG(4)="The Image points to PATIENT file internal entry number "_DFN
63 . . . S MSG(5)=$$PATDEMO^MAGDIRVE(DFN)
64 . . . S MSG(6)=""
65 . . . S MSG(7)="The Consult points to PATIENT file internal entry number "_GMRCDFN
66 . . . S MSG(8)=$$PATDEMO^MAGDIRVE(GMRCDFN)
67 . . . S MSG(9)=""
68 . . . D ERROR(.MSG)
69 . . . Q
70 . . E D
71 . . . ; check that this is a service of interest
72 . . . S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
73 . . . I '$D(SERVICE("S",SERVICE)) Q
74 . . . ; check cutoff date
75 . . . S I=$O(^MAG(2005,MAGIEN,1,0)),MAGIEN1=$P(^(I,0),"^",1)
76 . . . S EXAMDATE=$P(^MAG(2005,MAGIEN1,2),"^",1) I EXAMDATE>CUTOFF Q
77 . . . S ORDRDATE=$$GET1^DIQ(123,GMRCIEN,.01)
78 . . . S ORDRDATE=$P(ORDRDATE,",",1)_","_$E($P(ORDRDATE,",",2),4,5)
79 . . . S STATUS=$$GET1^DIQ(123,GMRCIEN,8,"I")
80 . . . I '$D(STATUS(STATUS)) D
81 . . . . S STATUS(STATUS)=$$GET1^DIQ(100.01,STATUS,.1)
82 . . . . Q
83 . . . S REQTYPE=$$GET1^DIQ(123,GMRCIEN,13,"I")
84 . . . D DEM^VADPT
85 . . . S PNAME=VADM(1),PID=VA("PID")
86 . . . S DOB=$P(VADM(3),"^",2),SEX=$P(VADM(5),"^",2)
87 . . . S (I,@WRK@(0))=$G(@WRK@(0))+1
88 . . . S Z=DFN_"^"_PNAME_"^"_PID_"^"_SEX_"^"_DOB
89 . . . S Z=Z_"^"_GMRCIEN_"^"_SERVICE_"^"_ORDRDATE_"^"_STATUS
90 . . . S Z=Z_"^"_REQTYPE_"^"_EXAMDATE
91 . . . S @WRK@(I)=Z
92 . . . S @WRK@("P",PNAME,DFN,I)=""
93 . . . S @WRK@("D",EXAMDATE\1,PNAME,DFN,I)=""
94 . . . I $E(IOST)="C" W:$X>79 ! W "."
95 . . . Q
96 . . Q
97 . Q
98 ;
99 ; output the report
100 ;
101 U IO D HEADING
102 S STOP=0
103 ;
104 I "Dd"[SORT D ; output sorted by examination date
105 . S DATE="" F S DATE=$O(@WRK@("D",DATE)) Q:DATE=""!STOP D
106 . . D NEWLINE(5)
107 . . K LASTDFN ; force output of name
108 . . S PNAME="" F S PNAME=$O(@WRK@("D",DATE,PNAME)) Q:PNAME=""!STOP D
109 . . . S DFN="" F S DFN=$O(@WRK@("D",DATE,PNAME,DFN)) Q:DFN=""!STOP D
110 . . . . S I="" F S I=$O(@WRK@("D",DATE,PNAME,DFN,I)) Q:I=""!STOP D
111 . . . . . D ONELINE
112 . . . . . Q
113 . . . . Q
114 . . . Q
115 . . Q
116 . Q
117 ;
118 E D ; output sorted by name
119 . S PNAME="" F S PNAME=$O(@WRK@("P",PNAME)) Q:PNAME=""!STOP D
120 . . S DFN="" F S DFN=$O(@WRK@("P",PNAME,DFN)) Q:DFN=""!STOP D
121 . . . S I="" F S I=$O(@WRK@("P",PNAME,DFN,I)) Q:I=""!STOP D
122 . . . . K LASTEXAM ; force output of examination date
123 . . . . D ONELINE
124 . . . . Q
125 . . . Q
126 . . Q
127 . Q
128 ;
129 D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" ; standard kernel exit
130 K @WRK
131 Q
132 ;
133ONELINE ; output one line of the report
134 S X=@WRK@(I)
135 I DFN'=$G(LASTDFN) D
136 . S PID=$P(X,"^",3),SEX=$P(X,"^",4),DOB=$P(X,"^",5)
137 . D NEWLINE(4),NEWLINE(3)
138 . W PNAME," ",PID," (",SEX,") ",DOB
139 . S LASTDFN=DFN
140 . Q
141 S GMRCIEN=$P(X,"^",6),SERVICE=$P(X,"^",7),ORDRDATE=$P(X,"^",8)
142 S STATUS=$P(X,"^",9),REQTYPE=$P(X,"^",10),EXAMDATE=$P(X,"^",11)
143 S REQTYPE=$S(REQTYPE="C":"Consult",REQTYPE="P":"Procedure",1:"Unknown")
144 D NEWLINE(1)
145 W " ",ORDRDATE," (",STATUS(STATUS),") ",$E(SERVICE("S",SERVICE),1,30)
146 W " ",REQTYPE," #",GMRCIEN
147 S Y=EXAMDATE D DD^%DT S EXAMDATE=$P(Y,",",1)_","_$E($P(Y,",",2),4,5)
148 I EXAMDATE'=$G(LASTEXAM) D
149 . W ?65,"Exam: ",EXAMDATE
150 . S LASTEXAM=EXAMDATE
151 . Q
152 Q
153 ;
154NEWLINE(J) ; output a <cr> <lf> with scrolling control or pagination
155 N I
156 W !
157 I $Y<(IOSL-J) Q ; nothing else to do
158 I $E(IOST)="C" D ; scrolling for a crt
159 . N I,X
160 . W "more..." R X:DTIME F I=1:1:$X W $C(8,32,8)
161 . S $Y=0 Q:X=""
162 . S:$TR(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^" STOP=1
163 . Q
164 E D ; pagination for a file or a printer
165 . F Y=$Y:1:(IOSL-1) W !
166 . S PAGE=$G(PAGE)+1 W ?IOM-10,"Page ",PAGE,!
167 . D HEADING
168 . Q
169 Q
170 ;
171HEADING ; print heading
172 W @IOF,TITLE,?IOM-$L(NOW),NOW,!
173 I ($L(SUBTITLE(1))+$L(SUBTITLE(2)))<(IOM-4) D
174 . W SUBTITLE(1)," -- ",SUBTITLE(2)
175 . Q
176 E D
177 . W SUBTITLE(1),!,SUBTITLE(2)
178 . Q
179 W !
180 Q
181 ;
182ERROR(MSG) ; Error Message
183 N I
184 W ! F I=1:1:80 W "*"
185 F I=1:1 Q:'$D(MSG(I)) W !,"*** ",MSG(I),?76," ***"
186 W ! F I=1:1:80 W "*"
187 Q
Note: See TracBrowser for help on using the repository browser.