MAGDRCU2 ;WOIFO/PMK - List entries in ^MAG(2006.5839) ; 10 May 2013 9:41 AM
;;3.0;IMAGING;**10,11,51,54,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
; This routine lists the entries in the temporary Imaging/CPRS Consult
; Request Tracking association file
;
; XXXX XXX X
; XX XX XX XX
; XX XXXX XX XXX XXXXXXX XX XXX XX XXXXX
; XX XX XX XXX XX XX XX XX XX XX
; XX X XX XX XX XX XXXXXXX XX XX XX XX
; XX XX XX XX XX XX XX XX XX XX XX XX
; XXXX XXXX XX XX XXXXXXX XXX XX XXXX XXX
;
; Routine 2/2 in for application
;
REPORT ; now scan the database and generate the report
N D0,DATE,DFN,DOB,EXAMDATE,GMRCDFN,GMRCIEN,I,LASTDFN,LASTEXAM
N MAGIEN,MAGIEN1,NOW,ORDRDATE,PAGE,PID,PNAME,REQTYPE
N SEX,STATUS,STOP,VA,VAERR,VADM,WRK,X,Y,Z
;
S WRK=$NA(^TMP("MAG",$J,"GMRC"))
S NOW=$$HTE^XLFDT($H,0)
K @WRK
;
S D0=0
I $E(IOST)="C" W !,"Building"
F S D0=$O(^MAG(2006.5839,D0)) Q:'D0 S X=^(D0,0) D
. I $P(X,"^",1)'="123" D
. . N MSG
. . S MSG(1)="Problem with Temporary Imaging/CPRS file"
. . S MSG(2)="Entry #"_D0_" in ^MAG(2006.5839) does not begin"
. . S MSG(3)="with 123 - it doesn't point to CPRS Consult Request Tracking"
. . S MSG(4)="Bad record: <<"_X_">>"
. . D ERROR(.MSG)
. . Q
. E D
. . S GMRCIEN=$P(X,"^",2),MAGIEN=$P(X,"^",3)
. . S DFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7)
. . S GMRCDFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
. . I DFN'=GMRCDFN D
. . . N MSG
. . . S MSG(1)="DICOM IMAGE PROCESSING ERROR - CONSULT/IMAGING PATIENT MISMATCH"
. . . S MSG(2)="The image and the consult point to different patients."
. . . S MSG(3)=""
. . . S MSG(4)="The Image points to PATIENT file internal entry number """_DFN_""""
. . . S MSG(5)=$$PATDEMO^MAGDIRVE(DFN)
. . . S MSG(6)=""
. . . S MSG(7)="The Consult points to PATIENT file internal entry number """_GMRCDFN_""""
. . . S MSG(8)=$$PATDEMO^MAGDIRVE(GMRCDFN)
. . . S MSG(9)=""
. . . D ERROR(.MSG)
. . . Q
. . E D
. . . ; check that this is a service of interest
. . . S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
. . . I '$D(SERVICE("S",SERVICE)) Q
. . . ; check cutoff date
. . . S I=$O(^MAG(2005,MAGIEN,1,0)),MAGIEN1=$P(^(I,0),"^",1)
. . . S EXAMDATE=$P(^MAG(2005,MAGIEN1,2),"^",1) I EXAMDATE>CUTOFF Q
. . . S ORDRDATE=$$GET1^DIQ(123,GMRCIEN,.01)
. . . S ORDRDATE=$P(ORDRDATE,",",1)_","_$E($P(ORDRDATE,",",2),4,5)
. . . S STATUS=$$GET1^DIQ(123,GMRCIEN,8,"I")
. . . I '$D(STATUS(STATUS)) D
. . . . S STATUS(STATUS)=$$GET1^DIQ(100.01,STATUS,.1)
. . . . Q
. . . S REQTYPE=$$GET1^DIQ(123,GMRCIEN,13,"I")
. . . D DEM^VADPT
. . . S PNAME=VADM(1),PID=VA("PID")
. . . S DOB=$P(VADM(3),"^",2),SEX=$P(VADM(5),"^",2)
. . . S (I,@WRK@(0))=$G(@WRK@(0))+1
. . . S Z=DFN_"^"_PNAME_"^"_PID_"^"_SEX_"^"_DOB
. . . S Z=Z_"^"_GMRCIEN_"^"_SERVICE_"^"_ORDRDATE_"^"_STATUS
. . . S Z=Z_"^"_REQTYPE_"^"_EXAMDATE
. . . S @WRK@(I)=Z
. . . S @WRK@("P",PNAME,DFN,I)=""
. . . S @WRK@("D",EXAMDATE\1,PNAME,DFN,I)=""
. . . I $E(IOST)="C" W:$X>79 ! W "."
. . . Q
. . Q
. Q
;
; output the report
;
U IO D HEADING
S STOP=0
;
I "Dd"[SORT D ; output sorted by examination date
. S DATE="" F S DATE=$O(@WRK@("D",DATE)) Q:DATE=""!STOP D
. . D NEWLINE(5)
. . K LASTDFN ; force output of name
. . S PNAME="" F S PNAME=$O(@WRK@("D",DATE,PNAME)) Q:PNAME=""!STOP D
. . . S DFN="" F S DFN=$O(@WRK@("D",DATE,PNAME,DFN)) Q:DFN=""!STOP D
. . . . S I="" F S I=$O(@WRK@("D",DATE,PNAME,DFN,I)) Q:I=""!STOP D
. . . . . D ONELINE
. . . . . Q
. . . . Q
. . . Q
. . Q
. Q
;
E D ; output sorted by name
. S PNAME="" F S PNAME=$O(@WRK@("P",PNAME)) Q:PNAME=""!STOP D
. . S DFN="" F S DFN=$O(@WRK@("P",PNAME,DFN)) Q:DFN=""!STOP D
. . . S I="" F S I=$O(@WRK@("P",PNAME,DFN,I)) Q:I=""!STOP D
. . . . K LASTEXAM ; force output of examination date
. . . . D ONELINE
. . . . Q
. . . Q
. . Q
. Q
;
D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" ; standard kernel exit
K @WRK
Q
;
ONELINE ; output one line of the report
S X=@WRK@(I)
I DFN'=$G(LASTDFN) D
. S PID=$P(X,"^",3),SEX=$P(X,"^",4),DOB=$P(X,"^",5)
. D NEWLINE(4),NEWLINE(3)
. W PNAME," ",PID," (",SEX,") ",DOB
. S LASTDFN=DFN
. Q
S GMRCIEN=$P(X,"^",6),SERVICE=$P(X,"^",7),ORDRDATE=$P(X,"^",8)
S STATUS=$P(X,"^",9),REQTYPE=$P(X,"^",10),EXAMDATE=$P(X,"^",11)
S REQTYPE=$S(REQTYPE="C":"Consult",REQTYPE="P":"Procedure",1:"Unknown")
D NEWLINE(1)
W " ",ORDRDATE," (",STATUS(STATUS),") ",$E(SERVICE("S",SERVICE),1,30)
W " ",REQTYPE," #",GMRCIEN
S Y=$$FMTE^XLFDT(EXAMDATE,1),EXAMDATE=$P(Y,",",1)_","_$E($P(Y,",",2),4,5)
I EXAMDATE'=$G(LASTEXAM) D
. W ?65,"Exam: ",EXAMDATE
. S LASTEXAM=EXAMDATE
. Q
Q
;
NEWLINE(J) ; output a <cr> <lf> with scrolling control or pagination
N I
W !
I $Y<(IOSL-J) Q ; nothing else to do
I $E(IOST)="C" D ; scrolling for a crt
. N I,X
. W "more..." R X:DTIME F I=1:1:$X W $C(8,32,8)
. S $Y=0 Q:X=""
. S:$TR(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^" STOP=1
. Q
E D ; pagination for a file or a printer
. F Y=$Y:1:(IOSL-1) W !
. S PAGE=$G(PAGE)+1 W ?IOM-10,"Page ",PAGE,!
. D HEADING
. Q
Q
;
HEADING ; print heading
W @IOF,TITLE,?IOM-$L(NOW),NOW,!
I ($L(SUBTITLE(1))+$L(SUBTITLE(2)))<(IOM-4) D
. W SUBTITLE(1)," -- ",SUBTITLE(2)
. Q
E D
. W SUBTITLE(1),!,SUBTITLE(2)
. Q
W !
Q
;
ERROR(MSG) ; Error Message
N I
W ! F I=1:1:80 W "*"
F I=1:1 Q:'$D(MSG(I)) W !,"*** ",MSG(I),?76," ***"
W ! F I=1:1:80 W "*"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRCU2 6732 printed Apr 09, 2024@21:06:42 Page 2
MAGDRCU2 ;WOIFO/PMK - List entries in ^MAG(2006.5839) ; 10 May 2013 9:41 AM
+1 ;;3.0;IMAGING;**10,11,51,54,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+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 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ; This routine lists the entries in the temporary Imaging/CPRS Consult
+18 ; Request Tracking association file
+19 ;
+20 ; XXXX XXX X
+21 ; XX XX XX XX
+22 ; XX XXXX XX XXX XXXXXXX XX XXX XX XXXXX
+23 ; XX XX XX XXX XX XX XX XX XX XX
+24 ; XX X XX XX XX XX XXXXXXX XX XX XX XX
+25 ; XX XX XX XX XX XX XX XX XX XX XX XX
+26 ; XXXX XXXX XX XX XXXXXXX XXX XX XXXX XXX
+27 ;
+28 ; Routine 2/2 in for application
+29 ;
REPORT ; now scan the database and generate the report
+1 NEW D0,DATE,DFN,DOB,EXAMDATE,GMRCDFN,GMRCIEN,I,LASTDFN,LASTEXAM
+2 NEW MAGIEN,MAGIEN1,NOW,ORDRDATE,PAGE,PID,PNAME,REQTYPE
+3 NEW SEX,STATUS,STOP,VA,VAERR,VADM,WRK,X,Y,Z
+4 ;
+5 SET WRK=$NAME(^TMP("MAG",$JOB,"GMRC"))
+6 SET NOW=$$HTE^XLFDT($HOROLOG,0)
+7 KILL @WRK
+8 ;
+9 SET D0=0
+10 IF $EXTRACT(IOST)="C"
WRITE !,"Building"
+11 FOR
SET D0=$ORDER(^MAG(2006.5839,D0))
if 'D0
QUIT
SET X=^(D0,0)
Begin DoDot:1
+12 IF $PIECE(X,"^",1)'="123"
Begin DoDot:2
+13 NEW MSG
+14 SET MSG(1)="Problem with Temporary Imaging/CPRS file"
+15 SET MSG(2)="Entry #"_D0_" in ^MAG(2006.5839) does not begin"
+16 SET MSG(3)="with 123 - it doesn't point to CPRS Consult Request Tracking"
+17 SET MSG(4)="Bad record: <<"_X_">>"
+18 DO ERROR(.MSG)
+19 QUIT
End DoDot:2
+20 IF '$TEST
Begin DoDot:2
+21 SET GMRCIEN=$PIECE(X,"^",2)
SET MAGIEN=$PIECE(X,"^",3)
+22 SET DFN=$PIECE($GET(^MAG(2005,MAGIEN,0)),"^",7)
+23 SET GMRCDFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
+24 IF DFN'=GMRCDFN
Begin DoDot:3
+25 NEW MSG
+26 SET MSG(1)="DICOM IMAGE PROCESSING ERROR - CONSULT/IMAGING PATIENT MISMATCH"
+27 SET MSG(2)="The image and the consult point to different patients."
+28 SET MSG(3)=""
+29 SET MSG(4)="The Image points to PATIENT file internal entry number """_DFN_""""
+30 SET MSG(5)=$$PATDEMO^MAGDIRVE(DFN)
+31 SET MSG(6)=""
+32 SET MSG(7)="The Consult points to PATIENT file internal entry number """_GMRCDFN_""""
+33 SET MSG(8)=$$PATDEMO^MAGDIRVE(GMRCDFN)
+34 SET MSG(9)=""
+35 DO ERROR(.MSG)
+36 QUIT
End DoDot:3
+37 IF '$TEST
Begin DoDot:3
+38 ; check that this is a service of interest
+39 SET SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
+40 IF '$DATA(SERVICE("S",SERVICE))
QUIT
+41 ; check cutoff date
+42 SET I=$ORDER(^MAG(2005,MAGIEN,1,0))
SET MAGIEN1=$PIECE(^(I,0),"^",1)
+43 SET EXAMDATE=$PIECE(^MAG(2005,MAGIEN1,2),"^",1)
IF EXAMDATE>CUTOFF
QUIT
+44 SET ORDRDATE=$$GET1^DIQ(123,GMRCIEN,.01)
+45 SET ORDRDATE=$PIECE(ORDRDATE,",",1)_","_$EXTRACT($PIECE(ORDRDATE,",",2),4,5)
+46 SET STATUS=$$GET1^DIQ(123,GMRCIEN,8,"I")
+47 IF '$DATA(STATUS(STATUS))
Begin DoDot:4
+48 SET STATUS(STATUS)=$$GET1^DIQ(100.01,STATUS,.1)
+49 QUIT
End DoDot:4
+50 SET REQTYPE=$$GET1^DIQ(123,GMRCIEN,13,"I")
+51 DO DEM^VADPT
+52 SET PNAME=VADM(1)
SET PID=VA("PID")
+53 SET DOB=$PIECE(VADM(3),"^",2)
SET SEX=$PIECE(VADM(5),"^",2)
+54 SET (I,@WRK@(0))=$GET(@WRK@(0))+1
+55 SET Z=DFN_"^"_PNAME_"^"_PID_"^"_SEX_"^"_DOB
+56 SET Z=Z_"^"_GMRCIEN_"^"_SERVICE_"^"_ORDRDATE_"^"_STATUS
+57 SET Z=Z_"^"_REQTYPE_"^"_EXAMDATE
+58 SET @WRK@(I)=Z
+59 SET @WRK@("P",PNAME,DFN,I)=""
+60 SET @WRK@("D",EXAMDATE\1,PNAME,DFN,I)=""
+61 IF $EXTRACT(IOST)="C"
if $X>79
WRITE !
WRITE "."
+62 QUIT
End DoDot:3
+63 QUIT
End DoDot:2
+64 QUIT
End DoDot:1
+65 ;
+66 ; output the report
+67 ;
+68 USE IO
DO HEADING
+69 SET STOP=0
+70 ;
+71 ; output sorted by examination date
IF "Dd"[SORT
Begin DoDot:1
+72 SET DATE=""
FOR
SET DATE=$ORDER(@WRK@("D",DATE))
if DATE=""!STOP
QUIT
Begin DoDot:2
+73 DO NEWLINE(5)
+74 ; force output of name
KILL LASTDFN
+75 SET PNAME=""
FOR
SET PNAME=$ORDER(@WRK@("D",DATE,PNAME))
if PNAME=""!STOP
QUIT
Begin DoDot:3
+76 SET DFN=""
FOR
SET DFN=$ORDER(@WRK@("D",DATE,PNAME,DFN))
if DFN=""!STOP
QUIT
Begin DoDot:4
+77 SET I=""
FOR
SET I=$ORDER(@WRK@("D",DATE,PNAME,DFN,I))
if I=""!STOP
QUIT
Begin DoDot:5
+78 DO ONELINE
+79 QUIT
End DoDot:5
+80 QUIT
End DoDot:4
+81 QUIT
End DoDot:3
+82 QUIT
End DoDot:2
+83 QUIT
End DoDot:1
+84 ;
+85 ; output sorted by name
IF '$TEST
Begin DoDot:1
+86 SET PNAME=""
FOR
SET PNAME=$ORDER(@WRK@("P",PNAME))
if PNAME=""!STOP
QUIT
Begin DoDot:2
+87 SET DFN=""
FOR
SET DFN=$ORDER(@WRK@("P",PNAME,DFN))
if DFN=""!STOP
QUIT
Begin DoDot:3
+88 SET I=""
FOR
SET I=$ORDER(@WRK@("P",PNAME,DFN,I))
if I=""!STOP
QUIT
Begin DoDot:4
+89 ; force output of examination date
KILL LASTEXAM
+90 DO ONELINE
+91 QUIT
End DoDot:4
+92 QUIT
End DoDot:3
+93 QUIT
End DoDot:2
+94 QUIT
End DoDot:1
+95 ;
+96 ; standard kernel exit
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+97 KILL @WRK
+98 QUIT
+99 ;
ONELINE ; output one line of the report
+1 SET X=@WRK@(I)
+2 IF DFN'=$GET(LASTDFN)
Begin DoDot:1
+3 SET PID=$PIECE(X,"^",3)
SET SEX=$PIECE(X,"^",4)
SET DOB=$PIECE(X,"^",5)
+4 DO NEWLINE(4)
DO NEWLINE(3)
+5 WRITE PNAME," ",PID," (",SEX,") ",DOB
+6 SET LASTDFN=DFN
+7 QUIT
End DoDot:1
+8 SET GMRCIEN=$PIECE(X,"^",6)
SET SERVICE=$PIECE(X,"^",7)
SET ORDRDATE=$PIECE(X,"^",8)
+9 SET STATUS=$PIECE(X,"^",9)
SET REQTYPE=$PIECE(X,"^",10)
SET EXAMDATE=$PIECE(X,"^",11)
+10 SET REQTYPE=$SELECT(REQTYPE="C":"Consult",REQTYPE="P":"Procedure",1:"Unknown")
+11 DO NEWLINE(1)
+12 WRITE " ",ORDRDATE," (",STATUS(STATUS),") ",$EXTRACT(SERVICE("S",SERVICE),1,30)
+13 WRITE " ",REQTYPE," #",GMRCIEN
+14 SET Y=$$FMTE^XLFDT(EXAMDATE,1)
SET EXAMDATE=$PIECE(Y,",",1)_","_$EXTRACT($PIECE(Y,",",2),4,5)
+15 IF EXAMDATE'=$GET(LASTEXAM)
Begin DoDot:1
+16 WRITE ?65,"Exam: ",EXAMDATE
+17 SET LASTEXAM=EXAMDATE
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
NEWLINE(J) ; output a <cr> <lf> with scrolling control or pagination
+1 NEW I
+2 WRITE !
+3 ; nothing else to do
IF $Y<(IOSL-J)
QUIT
+4 ; scrolling for a crt
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+5 NEW I,X
+6 WRITE "more..."
READ X:DTIME
FOR I=1:1:$X
WRITE $CHAR(8,32,8)
+7 SET $Y=0
if X=""
QUIT
+8 if $TRANSLATE(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^"
SET STOP=1
+9 QUIT
End DoDot:1
+10 ; pagination for a file or a printer
IF '$TEST
Begin DoDot:1
+11 FOR Y=$Y:1:(IOSL-1)
WRITE !
+12 SET PAGE=$GET(PAGE)+1
WRITE ?IOM-10,"Page ",PAGE,!
+13 DO HEADING
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
HEADING ; print heading
+1 WRITE @IOF,TITLE,?IOM-$LENGTH(NOW),NOW,!
+2 IF ($LENGTH(SUBTITLE(1))+$LENGTH(SUBTITLE(2)))<(IOM-4)
Begin DoDot:1
+3 WRITE SUBTITLE(1)," -- ",SUBTITLE(2)
+4 QUIT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 WRITE SUBTITLE(1),!,SUBTITLE(2)
+7 QUIT
End DoDot:1
+8 WRITE !
+9 QUIT
+10 ;
ERROR(MSG) ; Error Message
+1 NEW I
+2 WRITE !
FOR I=1:1:80
WRITE "*"
+3 FOR I=1:1
if '$DATA(MSG(I))
QUIT
WRITE !,"*** ",MSG(I),?76," ***"
+4 WRITE !
FOR I=1:1:80
WRITE "*"
+5 QUIT
+6 ;
