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

MAGTP003.m

Go to the documentation of this file.
  1. MAGTP003 ;WOIFO/FG,MLH,JSL - TELEPATHOLOGY RPCS ; 25 Jul 2013 5:38 PM
  1. ;;3.0;IMAGING;**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. Q ;
  1. ;
  1. ;***** SET/UNSET A LOGICAL LOCK ON A RECORD FOR CASE RESERVATION
  1. ; RPC: MAGTP RESERVE CASE
  1. ;
  1. ; .MAGRY Reference to a local variable where the results
  1. ; are returned to.
  1. ;
  1. ; LFLAG Flag that controls whether to lock or unlock
  1. ; (0:Unlocked, 1:Locked)
  1. ;
  1. ; LRSS AP Section
  1. ;
  1. ; YEAR Accession Year (Two figures)
  1. ;
  1. ; LRAN Accession Number
  1. ;
  1. ; Return Values
  1. ; =============
  1. ;
  1. ; If MAGRY(0) 1st '^'-piece is < 0, then an error
  1. ; occurred during execution of the procedure: <code>^0^ ERROR explanation
  1. ;
  1. ; Otherwise, the output array is as follows:
  1. ;
  1. ; MAGRY(0) Description
  1. ; ^01: 0
  1. ; ^02: 0 if case record is unlocked, 1 if case record is locked
  1. ; ^03: "Reservation ended" if case record is unlocked
  1. ; "Case reserved" if case record is locked
  1. ;
  1. LOCKR(MAGRY,LFLAG,LRSS,YEAR,LRAN) ; RPC [MAGTP RESERVE CASE]
  1. K MAGRY
  1. N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGUTERR"
  1. D Q:$G(MAGRY(0)) ; validate inputs
  1. . I $G(LRSS)="" S MAGRY(0)="-2^^ERROR: AP subsection not specified" Q
  1. . I $G(YEAR)="" S MAGRY(0)="-3^^ERROR: Year not specified" Q
  1. . I $G(LRAN)="" S MAGRY(0)="-4^^ERROR: Accession index not specified" Q
  1. . Q
  1. N INPUT
  1. D Q:$G(MAGRY(0)) ; validate context
  1. . N OUT
  1. . S INPUT=$$CONTEXT^MAGTP006(.OUT,LRSS,YEAR,LRAN)
  1. . D:'$G(OUT(0)) ; context not OK
  1. . . S MAGRY(0)="-5^^ERROR: Invalid context - "
  1. . . S MAGRY(0)=MAGRY(0)_$P(OUT(0),"^",3)
  1. . . Q
  1. . Q
  1. N MAGFDA,MAGERR
  1. N LRSF,IEN,LRAC,REC,ISLOCK
  1. N LDT,LDUZ,LUSER,TEXT,LRAA,YR
  1. S LRSF=$P(INPUT,","),IEN=$P(INPUT,",",2,4)
  1. S LRAC=$$GET1^DIQ(LRSF,IEN,.06) ; Accession code
  1. D:LRAC="" ;try new style (LEDI)
  1. . S LRAA=$O(^LRO(68,"B",LRSS,0)) ;new style cases
  1. . S YR=$S($L(YEAR)=2:300+YEAR*10000,1:YEAR) ;try 2000
  1. . I +$P($G(^LRO(68,LRAA,1,YR,1,LRAN,0)),"^",1) S LRAC=$G(^LRO(68,LRAA,1,YR,1,LRAN,.2)) Q:LRAC]""
  1. . S YR=$S($L(YEAR)=2:200+YEAR*10000,1:YEAR) ;try 1900
  1. . I +$P($G(^LRO(68,LRAA,1,YR,1,LRAN,0)),"^",1) S LRAC=$G(^LRO(68,LRAA,1,YR,1,LRAN,.2))
  1. . Q
  1. I LRAC="" S MAGRY(0)="-6^^ERROR: No Accession Code for this case " Q
  1. S REC=$O(^MAG(2005.42,"B",LRAC,""))_"," ; Record number
  1. ;
  1. ; Update lock record with present user's data (or clear lock)
  1. ;
  1. S MAGFDA(2005.42,REC,1)=LFLAG
  1. S MAGFDA(2005.42,REC,1.1)=$S(LFLAG:$$NOW^XLFDT,1:"")
  1. S MAGFDA(2005.42,REC,1.2)=$S(LFLAG:DUZ,1:"")
  1. D UPDATE^DIE("","MAGFDA","","MAGERR") ; Update lock record
  1. I $D(MAGERR) S MAGRY(0)="-7^^ERROR: Update error - "_MAGERR("DIERR",1,"TEXT",1) Q
  1. ;
  1. S TEXT=$S(LFLAG:"1^Case reserved",1:"0^Reservation ended")
  1. S MAGRY(0)="0^"_TEXT
  1. Q ;