Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDRCU2

MAGDRCU2.m

Go to the documentation of this file. 
  1. 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
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  ; This routine lists the entries in the temporary Imaging/CPRS Consult
  1.  ; Request Tracking association file
  1.  ;
  1.  ;     XXXX                                         XXX       X
  1.  ;    XX  XX                                         XX      XX
  1.  ;   XX         XXXX    XX XXX  XXXXXXX  XX  XXX     XX     XXXXX
  1.  ;   XX        XX  XX   XXX XX  XX       XX  XX      XX      XX
  1.  ;   XX    X   XX  XX   XX  XX  XXXXXXX  XX  XX      XX      XX
  1.  ;    XX  XX   XX  XX   XX  XX       XX  XX  XX      XX      XX XX
  1.  ;     XXXX     XXXX    XX  XX  XXXXXXX   XXX XX    XXXX      XXX
  1.  ;
  1.  ; Routine 2/2 in for application
  1.  ;
  1. REPORT ; now scan the database and generate the report
  1.  N D0,DATE,DFN,DOB,EXAMDATE,GMRCDFN,GMRCIEN,I,LASTDFN,LASTEXAM
  1.  N MAGIEN,MAGIEN1,NOW,ORDRDATE,PAGE,PID,PNAME,REQTYPE
  1.  N SEX,STATUS,STOP,VA,VAERR,VADM,WRK,X,Y,Z
  1.  ;
  1.  S WRK=$NA(^TMP("MAG",$J,"GMRC"))
  1.  S NOW=$$HTE^XLFDT($H,0)
  1.  K @WRK
  1.  ;
  1.  S D0=0
  1.  I $E(IOST)="C" W !,"Building"
  1.  F  S D0=$O(^MAG(2006.5839,D0)) Q:'D0  S X=^(D0,0) D
  1.  . I $P(X,"^",1)'="123" D
  1.  . . N MSG
  1.  . . S MSG(1)="Problem with Temporary Imaging/CPRS file"
  1.  . . S MSG(2)="Entry #"_D0_" in ^MAG(2006.5839) does not begin"
  1.  . . S MSG(3)="with 123 - it doesn't point to CPRS Consult Request Tracking"
  1.  . . S MSG(4)="Bad record: <<"_X_">>"
  1.  . . D ERROR(.MSG)
  1.  . . Q
  1.  . E  D
  1.  . . S GMRCIEN=$P(X,"^",2),MAGIEN=$P(X,"^",3)
  1.  . . S DFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7)
  1.  . . S GMRCDFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
  1.  . . I DFN'=GMRCDFN D
  1.  . . . N MSG
  1.  . . . S MSG(1)="DICOM IMAGE PROCESSING ERROR - CONSULT/IMAGING PATIENT MISMATCH"
  1.  . . . S MSG(2)="The image and the consult point to different patients."
  1.  . . . S MSG(3)=""
  1.  . . . S MSG(4)="The Image points to PATIENT file internal entry number """_DFN_""""
  1.  . . . S MSG(5)=$$PATDEMO^MAGDIRVE(DFN)
  1.  . . . S MSG(6)=""
  1.  . . . S MSG(7)="The Consult points to PATIENT file internal entry number """_GMRCDFN_""""
  1.  . . . S MSG(8)=$$PATDEMO^MAGDIRVE(GMRCDFN)
  1.  . . . S MSG(9)=""
  1.  . . . D ERROR(.MSG)
  1.  . . . Q
  1.  . . E  D
  1.  . . . ; check that this is a service of interest
  1.  . . . S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
  1.  . . . I '$D(SERVICE("S",SERVICE)) Q
  1.  . . . ; check cutoff date
  1.  . . . S I=$O(^MAG(2005,MAGIEN,1,0)),MAGIEN1=$P(^(I,0),"^",1)
  1.  . . . S EXAMDATE=$P(^MAG(2005,MAGIEN1,2),"^",1) I EXAMDATE>CUTOFF Q
  1.  . . . S ORDRDATE=$$GET1^DIQ(123,GMRCIEN,.01)
  1.  . . . S ORDRDATE=$P(ORDRDATE,",",1)_","_$E($P(ORDRDATE,",",2),4,5)
  1.  . . . S STATUS=$$GET1^DIQ(123,GMRCIEN,8,"I")
  1.  . . . I '$D(STATUS(STATUS)) D
  1.  . . . . S STATUS(STATUS)=$$GET1^DIQ(100.01,STATUS,.1)
  1.  . . . . Q
  1.  . . . S REQTYPE=$$GET1^DIQ(123,GMRCIEN,13,"I")
  1.  . . . D DEM^VADPT
  1.  . . . S PNAME=VADM(1),PID=VA("PID")
  1.  . . . S DOB=$P(VADM(3),"^",2),SEX=$P(VADM(5),"^",2)
  1.  . . . S (I,@WRK@(0))=$G(@WRK@(0))+1
  1.  . . . S Z=DFN_"^"_PNAME_"^"_PID_"^"_SEX_"^"_DOB
  1.  . . . S Z=Z_"^"_GMRCIEN_"^"_SERVICE_"^"_ORDRDATE_"^"_STATUS
  1.  . . . S Z=Z_"^"_REQTYPE_"^"_EXAMDATE
  1.  . . . S @WRK@(I)=Z
  1.  . . . S @WRK@("P",PNAME,DFN,I)=""
  1.  . . . S @WRK@("D",EXAMDATE\1,PNAME,DFN,I)=""
  1.  . . . I $E(IOST)="C" W:$X>79 ! W "."
  1.  . . . Q
  1.  . . Q
  1.  . Q
  1.  ;
  1.  ; output the report
  1.  ;
  1.  U IO D HEADING
  1.  S STOP=0
  1.  ;
  1.  I "Dd"[SORT D  ; output sorted by examination date
  1.  . S DATE="" F  S DATE=$O(@WRK@("D",DATE)) Q:DATE=""!STOP  D
  1.  . . D NEWLINE(5)
  1.  . . K LASTDFN ; force output of name
  1.  . . S PNAME="" F  S PNAME=$O(@WRK@("D",DATE,PNAME)) Q:PNAME=""!STOP  D
  1.  . . . S DFN="" F  S DFN=$O(@WRK@("D",DATE,PNAME,DFN)) Q:DFN=""!STOP  D
  1.  . . . . S I="" F  S I=$O(@WRK@("D",DATE,PNAME,DFN,I)) Q:I=""!STOP  D
  1.  . . . . . D ONELINE
  1.  . . . . . Q
  1.  . . . . Q
  1.  . . . Q
  1.  . . Q
  1.  . Q
  1.  ;
  1.  E  D  ; output sorted by name
  1.  . S PNAME="" F  S PNAME=$O(@WRK@("P",PNAME)) Q:PNAME=""!STOP  D
  1.  . . S DFN="" F  S DFN=$O(@WRK@("P",PNAME,DFN)) Q:DFN=""!STOP  D
  1.  . . . S I="" F  S I=$O(@WRK@("P",PNAME,DFN,I)) Q:I=""!STOP  D
  1.  . . . . K LASTEXAM ; force output of examination date
  1.  . . . . D ONELINE
  1.  . . . . Q
  1.  . . . Q
  1.  . . Q
  1.  . Q
  1.  ;
  1.  D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" ; standard kernel exit
  1.  K @WRK
  1.  Q
  1.  ;
  1. ONELINE ; output one line of the report
  1.  S X=@WRK@(I)
  1.  I DFN'=$G(LASTDFN) D
  1.  . S PID=$P(X,"^",3),SEX=$P(X,"^",4),DOB=$P(X,"^",5)
  1.  . D NEWLINE(4),NEWLINE(3)
  1.  . W PNAME,"   ",PID,"   (",SEX,")   ",DOB
  1.  . S LASTDFN=DFN
  1.  . Q
  1.  S GMRCIEN=$P(X,"^",6),SERVICE=$P(X,"^",7),ORDRDATE=$P(X,"^",8)
  1.  S STATUS=$P(X,"^",9),REQTYPE=$P(X,"^",10),EXAMDATE=$P(X,"^",11)
  1.  S REQTYPE=$S(REQTYPE="C":"Consult",REQTYPE="P":"Procedure",1:"Unknown")
  1.  D NEWLINE(1)
  1.  W "  ",ORDRDATE," (",STATUS(STATUS),") ",$E(SERVICE("S",SERVICE),1,30)
  1.  W "  ",REQTYPE," #",GMRCIEN
  1.  S Y=$$FMTE^XLFDT(EXAMDATE,1),EXAMDATE=$P(Y,",",1)_","_$E($P(Y,",",2),4,5)
  1.  I EXAMDATE'=$G(LASTEXAM) D
  1.  . W ?65,"Exam: ",EXAMDATE
  1.  . S LASTEXAM=EXAMDATE
  1.  . Q
  1.  Q
  1.  ;
  1. NEWLINE(J) ; output a <cr> <lf> with scrolling control or pagination
  1.  N I
  1.  W !
  1.  I $Y<(IOSL-J) Q  ; nothing else to do
  1.  I $E(IOST)="C" D  ; scrolling for a crt
  1.  . N I,X
  1.  . W "more..." R X:DTIME F I=1:1:$X W $C(8,32,8)
  1.  . S $Y=0 Q:X=""
  1.  . S:$TR(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^" STOP=1
  1.  . Q
  1.  E  D  ; pagination for a file or a printer
  1.  . F Y=$Y:1:(IOSL-1) W !
  1.  . S PAGE=$G(PAGE)+1 W ?IOM-10,"Page ",PAGE,!
  1.  . D HEADING
  1.  . Q
  1.  Q
  1.  ;
  1. HEADING ; print heading
  1.  W @IOF,TITLE,?IOM-$L(NOW),NOW,!
  1.  I ($L(SUBTITLE(1))+$L(SUBTITLE(2)))<(IOM-4) D
  1.  . W SUBTITLE(1)," -- ",SUBTITLE(2)
  1.  . Q
  1.  E  D
  1.  . W SUBTITLE(1),!,SUBTITLE(2)
  1.  . Q
  1.  W !
  1.  Q
  1.  ;
  1. ERROR(MSG) ; Error Message
  1.  N I
  1.  W ! F I=1:1:80 W "*"
  1.  F I=1:1 Q:'$D(MSG(I))  W !,"*** ",MSG(I),?76," ***"
  1.  W ! F I=1:1:80 W "*"
  1.  Q
  1.  ;