MAGGSIU1 ;WOIFO/GEK/NST - Utilities for Image Add/Modify ; 04 Mar 2010 4:04 PM
;;3.0;IMAGING;**7,8,108**;Mar 19, 2002;Build 1738;May 20, 2010
;; 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. |
;; +---------------------------------------------------------------+
;;
Q
;
; GEK 11/04/2002 Keep MAGGTU1 as utility for DA2NAME and DRIVE
;
MAKENAME(MAGGFDA) ; get info from the MAGGFDA array
; For all Images the Name (.01) is first 18 characters of patient name
; concatenated with SSN.
; If No patient name is sent, well make the name from the short desc.
; We were making name of :
; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE)
N ZDESC,X
S ZDESC=""
; If we don't have a patient name ( later) we set .01 to Short Desc
; if it exists.
I $D(MAGGFDA(2005,"+1,",10)) S ZDESC=$E(MAGGFDA(2005,"+1,",10),1,30)
; DFN
I $D(MAGGFDA(2005,"+1,",5)) D
. S X=MAGGFDA(2005,"+1,",5)
. ; NAME SSN
. S ZDESC=$E($P(^DPT(X,0),U),1,18)_" "_$P(^DPT(X,0),U,9)
;
Q ZDESC
MAKECLAS ; Patch 8: This call will attempt to compute an Image CLASS ^ (#41) CLASS [2P]
; from the TYPE Field (#42) TYPE [3P]
; Call assumes the FM FDA Array MAGGFDA exists.
;// Note : this is also called from MAGGTIA. TYPE may not exist.
; Calling RTN expects MAGERR to exist if error.
N TYPE,CLS
S TYPE=$G(MAGGFDA(2005,"+1,",42))
; Can't make Type required. yet.
;I TYPE="" S MAGERR="0^A Value for Field #42 (Image Type) is missing." Q
I TYPE="" Q
S CLS=$P(^MAG(2005.83,TYPE,0),U,2)
I 'CLS S MAGERR="0^Missing Class pointer for TYPE : "_$P(^MAG(2005.83,TYPE,0),U)_" ("_TYPE_")" Q
S MAGGFDA(2005,"+1,",41)=CLS
Q
MAKEPKG ;Patch 8 This call will attempt to compute the field (#40) PACKAGE INDEX [1S] from Patent Data File.
; Call assumes the FM FDA Array MAGGFDA exists.
N PARENT,PKG,PXIEN,MAGRY,OK,TYPE
S PARENT=$G(MAGGFDA(2005,"+1,",16))
S TYPE=$G(MAGGFDA(2005,"+1,",42))
I (PARENT="")&(TYPE=$$PHOTODA) D Q
. S MAGGFDA(2005,"+1,",40)="PHOTOID"
. ; Need next line, bacause the Method that returns Photo ID for a Pat.
. ; checks for PHOTO ID in the Cross Reference.
. S MAGGFDA(2005,"+1,",6)="PHOTO ID"
. Q
I PARENT="" S MAGGFDA(2005,"+1,",40)="NONE" Q ;MAGERR="0^Missing Parent Data File pointer" Q
I PARENT'=8925 S PKG=$P(^MAG(2005.03,PARENT,2),U) Q
S PXIEN=$G(MAGGFDA(2005,"+1,",17))
D DATA^MAGGNTI(.MAGRY,PXIEN)
D ISCP^TIUCP(.OK,$P(MAGRY,U,2)) I OK S MAGGFDA(2005,"+1,",40)="CP" Q
D ISCNSLT^TIUCNSLT(.OK,$P(MAGRY,U,2)) I OK S MAGGFDA(2005,"+1,",40)="CONS" Q
S MAGGFDA(2005,"+1,",40)="NOTE"
Q
MAKEPROC ; Patch 8: This call will attempt to compute PROCEDURE field ^ (#6) PROCEDURE [8F]
; from Fields: (#41) CLASS [2P] or PACKAGE field (#40) PACKAGE [1S]
; Call assumes the FM FDA Array MAGGFDA exists.
; We are here because TYPE INDEX, CLASS INDEX and PACKAGE INDEX exist but PROCEDURE doesn't
; Calling RTN expects MAGERR to exist if error. ;
N TYPE,CLS,PKG
I $G(MAGGFDA(2005,"+1,",40),"NONE")'="NONE" S MAGGFDA(2005,"+1,",6)=MAGGFDA(2005,"+1,",40) Q
S TYPE=$G(MAGGFDA(2005,"+1,",42))
; Can't make Type required. yet.
S CLS=$P(^MAG(2005.83,TYPE,0),U,2)
I 'CLS S MAGERR="0^Missing Class pointer for TYPE : "_$P(^MAG(2005.83,TYPE,0),U)_" ("_TYPE_")" Q
S MAGGFDA(2005,"+1,",6)=$P($$GET1^DIQ(2005.82,CLS,".01","E"),"/")
Q
MAKEORIG ; Patch 8: This call will default the Origin field #45 to "VA"
; We are here because TYPE exists in the Array but Origin doesn't
S MAGGFDA(2005,"+1,",45)="V" ; Patch 108: set to "V"
Q
KILLENT(MAGGDA) ; Delete the entry just created, because of Post processing Error
D CLEAN^DILF
S DA=MAGGDA,DIK="^MAG(2005," D ^DIK
K DA,DIC,DIK
Q
RTRNERR(ETXT,MAGGXE) ; There was error from UPDATE^DIE quit with error text
S ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1)
Q
PHOTODA() ;Return the DA from File IMAGE INDEX FOR TYPES that is the PhotoID entry.
Q $O(^MAG(2005.83,"B","PHOTO ID",""))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGGSIU1 4900 printed Oct 16, 2024@18:03:29 Page 2
MAGGSIU1 ;WOIFO/GEK/NST - Utilities for Image Add/Modify ; 04 Mar 2010 4:04 PM
+1 ;;3.0;IMAGING;**7,8,108**;Mar 19, 2002;Build 1738;May 20, 2010
+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 QUIT
+18 ;
+19 ; GEK 11/04/2002 Keep MAGGTU1 as utility for DA2NAME and DRIVE
+20 ;
MAKENAME(MAGGFDA) ; get info from the MAGGFDA array
+1 ; For all Images the Name (.01) is first 18 characters of patient name
+2 ; concatenated with SSN.
+3 ; If No patient name is sent, well make the name from the short desc.
+4 ; We were making name of :
+5 ; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE)
+6 NEW ZDESC,X
+7 SET ZDESC=""
+8 ; If we don't have a patient name ( later) we set .01 to Short Desc
+9 ; if it exists.
+10 IF $DATA(MAGGFDA(2005,"+1,",10))
SET ZDESC=$EXTRACT(MAGGFDA(2005,"+1,",10),1,30)
+11 ; DFN
+12 IF $DATA(MAGGFDA(2005,"+1,",5))
Begin DoDot:1
+13 SET X=MAGGFDA(2005,"+1,",5)
+14 ; NAME SSN
+15 SET ZDESC=$EXTRACT($PIECE(^DPT(X,0),U),1,18)_" "_$PIECE(^DPT(X,0),U,9)
End DoDot:1
+16 ;
+17 QUIT ZDESC
MAKECLAS ; Patch 8: This call will attempt to compute an Image CLASS ^ (#41) CLASS [2P]
+1 ; from the TYPE Field (#42) TYPE [3P]
+2 ; Call assumes the FM FDA Array MAGGFDA exists.
+3 ;// Note : this is also called from MAGGTIA. TYPE may not exist.
+4 ; Calling RTN expects MAGERR to exist if error.
+5 NEW TYPE,CLS
+6 SET TYPE=$GET(MAGGFDA(2005,"+1,",42))
+7 ; Can't make Type required. yet.
+8 ;I TYPE="" S MAGERR="0^A Value for Field #42 (Image Type) is missing." Q
+9 IF TYPE=""
QUIT
+10 SET CLS=$PIECE(^MAG(2005.83,TYPE,0),U,2)
+11 IF 'CLS
SET MAGERR="0^Missing Class pointer for TYPE : "_$PIECE(^MAG(2005.83,TYPE,0),U)_" ("_TYPE_")"
QUIT
+12 SET MAGGFDA(2005,"+1,",41)=CLS
+13 QUIT
MAKEPKG ;Patch 8 This call will attempt to compute the field (#40) PACKAGE INDEX [1S] from Patent Data File.
+1 ; Call assumes the FM FDA Array MAGGFDA exists.
+2 NEW PARENT,PKG,PXIEN,MAGRY,OK,TYPE
+3 SET PARENT=$GET(MAGGFDA(2005,"+1,",16))
+4 SET TYPE=$GET(MAGGFDA(2005,"+1,",42))
+5 IF (PARENT="")&(TYPE=$$PHOTODA)
Begin DoDot:1
+6 SET MAGGFDA(2005,"+1,",40)="PHOTOID"
+7 ; Need next line, bacause the Method that returns Photo ID for a Pat.
+8 ; checks for PHOTO ID in the Cross Reference.
+9 SET MAGGFDA(2005,"+1,",6)="PHOTO ID"
+10 QUIT
End DoDot:1
QUIT
+11 ;MAGERR="0^Missing Parent Data File pointer" Q
IF PARENT=""
SET MAGGFDA(2005,"+1,",40)="NONE"
QUIT
+12 IF PARENT'=8925
SET PKG=$PIECE(^MAG(2005.03,PARENT,2),U)
QUIT
+13 SET PXIEN=$GET(MAGGFDA(2005,"+1,",17))
+14 DO DATA^MAGGNTI(.MAGRY,PXIEN)
+15 DO ISCP^TIUCP(.OK,$PIECE(MAGRY,U,2))
IF OK
SET MAGGFDA(2005,"+1,",40)="CP"
QUIT
+16 DO ISCNSLT^TIUCNSLT(.OK,$PIECE(MAGRY,U,2))
IF OK
SET MAGGFDA(2005,"+1,",40)="CONS"
QUIT
+17 SET MAGGFDA(2005,"+1,",40)="NOTE"
+18 QUIT
MAKEPROC ; Patch 8: This call will attempt to compute PROCEDURE field ^ (#6) PROCEDURE [8F]
+1 ; from Fields: (#41) CLASS [2P] or PACKAGE field (#40) PACKAGE [1S]
+2 ; Call assumes the FM FDA Array MAGGFDA exists.
+3 ; We are here because TYPE INDEX, CLASS INDEX and PACKAGE INDEX exist but PROCEDURE doesn't
+4 ; Calling RTN expects MAGERR to exist if error. ;
+5 NEW TYPE,CLS,PKG
+6 IF $GET(MAGGFDA(2005,"+1,",40),"NONE")'="NONE"
SET MAGGFDA(2005,"+1,",6)=MAGGFDA(2005,"+1,",40)
QUIT
+7 SET TYPE=$GET(MAGGFDA(2005,"+1,",42))
+8 ; Can't make Type required. yet.
+9 SET CLS=$PIECE(^MAG(2005.83,TYPE,0),U,2)
+10 IF 'CLS
SET MAGERR="0^Missing Class pointer for TYPE : "_$PIECE(^MAG(2005.83,TYPE,0),U)_" ("_TYPE_")"
QUIT
+11 SET MAGGFDA(2005,"+1,",6)=$PIECE($$GET1^DIQ(2005.82,CLS,".01","E"),"/")
+12 QUIT
MAKEORIG ; Patch 8: This call will default the Origin field #45 to "VA"
+1 ; We are here because TYPE exists in the Array but Origin doesn't
+2 ; Patch 108: set to "V"
SET MAGGFDA(2005,"+1,",45)="V"
+3 QUIT
KILLENT(MAGGDA) ; Delete the entry just created, because of Post processing Error
+1 DO CLEAN^DILF
+2 SET DA=MAGGDA
SET DIK="^MAG(2005,"
DO ^DIK
+3 KILL DA,DIC,DIK
+4 QUIT
RTRNERR(ETXT,MAGGXE) ; There was error from UPDATE^DIE quit with error text
+1 SET ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1)
+2 QUIT
PHOTODA() ;Return the DA from File IMAGE INDEX FOR TYPES that is the PhotoID entry.
+1 QUIT $ORDER(^MAG(2005.83,"B","PHOTO ID",""))
