| 1 | MAGDRCU2 ;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 | ;
|
|---|
| 33 | REPORT ; 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 | ;
|
|---|
| 133 | ONELINE ; 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 | ;
|
|---|
| 154 | NEWLINE(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 | ;
|
|---|
| 171 | HEADING ; 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 | ;
|
|---|
| 182 | ERROR(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
|
|---|
