MAGQBUT2 ;WOIFO/SRR/RMP/JL - IMAGE SITE PARAMETERS COMPANION ; 05 May 2017 3:06 PM
;;3.0;IMAGING;**7,8,20,81,39,186**;Mar 19, 2002;Build 23;Mar 08, 2011
;; 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. |
;; +---------------------------------------------------------------+
;;
MAGSYS(LIST) ;
; RPC[MAGQ SYSTEM]
N VAIEN,NODE,MGIEN,UNAME,TDATE
S MGIEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
S VAIEN=0
F S VAIEN=$O(^XUSEC("MAG SYSTEM",VAIEN)) Q:VAIEN'?1N.N D
. S UNAME=$$GET1^DIQ(200,VAIEN,.01)
. Q:UNAME=""
. ;CHECK FOR TERMINATION DATE
. S TDATE=$$GET1^DIQ(200,VAIEN,9.2)
. Q:((TDATE'="")&(TDATE<$$NOW^XLFDT))
. ;the next line screens existing 'MAG SERVER' members
. I MGIEN?1N.N,$$FIND1^DIC(3.81,","_MGIEN_",","QA",VAIEN,"","","ERR") Q
. S LIST(VAIEN)=VAIEN_"^"_UNAME
Q
IMPAR(RESULT,QIEN) ; Import Array
N INDX,CNT
S (INDX,CNT)=0
F S INDX=$O(^MAG(2006.034,QIEN,1,INDX)) Q:INDX'?1N.N D
. S CNT=CNT+1
. S RESULT(CNT)=$G(^MAG(2006.034,QIEN,1,INDX,0))
I CNT<1 S RESULT(0)="0^Corrupted Import Array"
E S RESULT(0)="1"
Q
CHKIMG(IEN) ;
; Given an Image IEN, return:
; 1: Case # or accession #
; 2: Parent application~IEN
; 3: Application DFN
; 4: Image DFN
; 5: Flag: true = all DFNs in images in same parent group are identical
; 6: Image object Class
;
; PF: Parent Data file number
; PT(): Parent file data dictionary
; PD0: Parent (Global root) IEN (D0)
; PD1: Lab Parent Global Root (D1)
; PD2: Parent Data File Image Pointer
; T(): Error types
; IDFN: Image file entry DFN
; PDFN: Parent file DFN
; GRG: virtual Parent File Image Multiple
; IOR: Image Object Referenced (by parent)
N GF,GP,G0,GR,GRD,GRG,GR0,IDFN,IENV,P0,PD0,PD1,PD2,PF,PT,X,X0,X2,N0,N1,R,T,GPDFN,PACS,IOR,APR,I,PDFN
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S R="^^^^^"
S T(1)="No Image ptr in AP"
S T(2)="GP has no Images"
S T(3)="Conflicting AP & Image DFNs"
S T(4)="Invalid Image Ptr to AP"
S T(5)="Conflicting GP and GO DFN"
S T(6)="GP & GO AP Mismatch"
S T(7)="GP Missing GO ptr"
S T(8)="No AP Ptr"
S T(9)="No AP Entry ptr"
S T(10)="No AP Mult ptr"
S T(11)="GO DFN mismatches"
S T(12)="Null Image Ptr"
S T(13)="Invalid Image Ptr"
S T(14)="Invalid Image Ptr to AP"
S T(15)="Image Entry is structurally abnormal"
S T(16)="Missing Group Objects"
S T(21)="DFN Mismatches in AP Image Mult"
I IEN="" S $P(R,"^",5)=T(12)_"~1" Q R
S X0=$G(^MAG(2005,IEN,0))
I X0="" S $P(R,"^",5)=T(13)_"~1" Q R
S IDFN=$P(X0,"^",7),$P(R,"^",4)=IDFN
S PT(3.9)="^XMB(3.9,PD0,|Mail message||2|^XMB(3.9,PD0,2005,|MAIL"
; The following 5 Lab subsections must be in-synch with FILE+42^MAGGTLB1
; IA #1962
S PT(63)="^LR(PD0,GF,PD1,|Autopsy (microscopic)|AY|1|^LR(PD0,GF,PD1,2005.1,|AUM"
S PT(63.02)="^LR(PD0,GF,PD1,|Electron microscopy|EM|1|^LR(PD0,GF,PD1,2005,|EM"
S PT(63.08)="^LR(PD0,GF,PD1,|Surgical pathology|SP|1|^LR(PD0,GF,PD1,2005,|SP"
S PT(63.09)="^LR(PD0,GF,PD1,|Cytology|CY|1|^LR(PD0,GF,PD1,2005,|CY|"
S PT(63.2)="^LR(PD0,GF,PD1,|Autopsy (gross)|AY|1|^LR(PD0,GF,PD1,2005,|AUG"
S PT(70)="^RADPT(PDFN,|Radiology Patient||1|"
S PT(74)="^RARPT(PD0,|Radiology||2|^RARPT(PD0,2005,|RAD"
S PT(130)="^SRF(PD0,|Surgery||1|^SRF(PD0,2005,|SUR"
S PT(691)="^MCAR(691,PD0,|Echocardiogram||2|^MCAR(691,PD0,2005,|ECHO"
S PT(691.1)="^MCAR(691.1,PD0,|Cardiac catheterization||2|^MCAR(691.1,PD0,2005,|CATH"
S PT(691.5)="^MCAR(691.5,PD0,|Electrocardiography||2|^MCAR(691.5,PD0,2005,|ECG"
S PT(694)="^MCAR(694,PD0,|Hematology||2|^MCAR(694,PD0,2005,|HEM"
S PT(699)="^MCAR(699,PD0,|Endoscopy||2|^MCAR(699,PD0,2005,|ENDO"
S PT(699.5)="^MCAR(699.5,PD0,|Medicine||2|^MCAR(699.5,PD0,2005,|GEN"
S PT(8925)="^TIU(8925,PD0,|TIU||2|^TIU(8925.91,""ADI"",PD0,|TIU"
S IC=$$IC(IEN,.N0,.N2,.GPDFN),$P(R,U,6)=IC
I IC="ER" S $P(R,U,5)=T(15)_"~1" Q R
I IC["GP",'$O(^MAG(2005,IEN,1,0)) S $P(R,U,5)=T(2)_"~1" Q R
D PF(IEN,IC,N0,.PF,.PD0,.PD1,.PD2,.PACS,.IOR,.APR)
I "GP^GO"[IC D Q:$P(R,U,5)'="" R
. S I=0
. F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N D
. . I '$D(^MAG(2005,$P($G(^MAG(2005,IOR,1,I,0)),U),0)) S $P(R,U,5)=T(16)_$S(IC="GO":"~2",1:"~1")
. . Q
I IC["GO" S $P(R,U,6)=$P(R,U,6)_"~"_IOR
I PD2'?1N.N,(('PACS)&(PD0?1N.N)) S $P(R,U,5)=T(10)_$S(IC["GO":"~2",1:"~1") Q R
I IC["GO" D Q:$P(R,U,5)'="" R
. N I,J
. S (I,J)=0
. F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N S:IEN=$P($G(^MAG(2005,IOR,1,I,0)),U,1) J=1
. S:J=0 $P(R,U,5)=T(7)_"~2"
. Q
I IC["GO",IDFN'=GPDFN S $P(R,U,5)=T(5)_"~1",$P(R,U,3)=GPDFN Q R
I IC["GO" D Q:$P(R,U,5)'="" R
. N I,J
. S I=0
. F S I=$O(^MAG(2005,IOR,1,I)) Q:I'?1N.N D Q:$P(R,U,5)'=""
. . S J=$P($G(^MAG(2005,IOR,1,I,0)),U)
. . I $P($G(^MAG(2005,J,0)),U,7)'=IDFN S $P(R,U,5)=T(11)_"~2",$P(R,U,3)=$P($G(^MAG(2005,J,0)),U,7)
. . Q
I IC["GO",PACS,(($P(N2,U,6,7)'="")&($P(N2,U,6,7)'="^")),$P(N2,U,6,7)'=$P($G(^MAG(2005,$P(N0,U,10),2)),U,6,7) D Q R
. S $P(R,U,5)=T(6)_"~1",$P(R,U,3)=$P(^MAG(2005,IOR,0),U,7) Q
I (PF\1=63),PD1'?1N.N,PD1'?1N.N1"."1N.N Q R
I PF?1N.E,$D(PT(+PF)),PD0?1N.N D
. S $P(R,"^",2)=$P(PT(PF),"|",6)_"~"_PD0
. S GR=$P(PT(PF),"|",1),GR0=GR_"0)"
. S GF=$P(PT(PF),"|",3),GP=$P(PT(PF),"|",4)
. S T=$P(PT(PF),"|",5),GRD=T_"G0,0)",GRG=T_"G0)"
E D Q R
. S:((IC["GP")&($P(R,U,5)="")) $P(R,U,5)="1"
S P0=$G(@GR0)
I P0="" S $P(R,"^",5)=T(4)_$S((('PACS)&(IC["GO")):"~2",1:"~1") Q R
S PDFN=$S(PF\1=63:$P(^LR(PD0,0),U,3),$P(P0,"^",GP)'="":$P(P0,"^",GP),1:PDFN)
I 'PDFN,$P($G(^VA(200,IDFN,0)),"^",1)=PDFN S PDFN=IDFN
S $P(R,"^",3)=PDFN
I PDFN'=IDFN S $P(R,U,5)=T(3)_$S((('PACS)&(IC["GO")):"~2",1:"~1") Q R
I PF=74 D
. S GR=$P(PT(70),"|",1),GR0=GR_"0)"
. S GF=$P(PT(70),"|",3),GP=$P(PT(70),"|",4)
. S P0=$G(@GR0),$P(R,"^",3)=$P(R,"^",3)_"~"_$P(P0,"^",GP)
S T=1,G0=0,IENV=0
F S G0=$O(@GRG) Q:'G0 Q:$P(R,U,5)'="" D I 'T K PT Q
. I PF=8925 D Q
. . I '$D(^MAG(2005,+G0,0)) S $P(R,U,5)=T(14)_$S((('PACS)&(IC["GO")):"~2",1:"~1")
. . S:G0=IOR IENV=1
. . I $P($G(^MAG(2005,+G0,0)),"^",7)'=IDFN S $P(R,U,5)=T(21)_"~2",$P(R,U,3)=$P($G(^MAG(2005,+G0,0)),"^",7)
. . Q
. I '$D(^MAG(2005,+$P($G(@GRD),"^",1),0)) S $P(R,U,5)=T(14)_$S((('PACS)&(IC["GO")):"~2",1:"~1")
. I $P($G(^MAG(2005,+$P($G(@GRD),"^",1),0)),"^",7)'=IDFN D Q
. . S $P(R,U,5)=T(21)_"~2",$P(R,U,3)=$P($G(^MAG(2005,+$P($G(@GRD),"^",1),0)),"^",7) Q
. I PF=63 S:+$P($G(^LR(PD0,GF,PD1,2005.1,G0,0)),U)=IOR IENV=1
. I PF=63.2 S:+$P($G(^LR(PD0,GF,PD1,2005,G0,0)),U)=IOR IENV=1
. S:+$P($G(@GRD),"^",1)=IOR IENV=1
. Q
Q:$P(R,U,5)'="" R
I IC["GP" S $P(R,U,5)="1"
I IENV=0 S $P(R,U,5)=T(1)_"~1"
I PF=74 S $P(R,"^",1)=$P(P0,"^",1)
K PT
Q R
IC(IEN,N0,N2,GPDFN) ;
S N0=$G(^MAG(2005,IEN,0))
S N1=$G(^MAG(2005,IEN,1,0))
S N2=$G(^MAG(2005,IEN,2))
I ($P(N0,U,2)="")&($P(N0,U,10)="")&($P(N1,U,4)>0) Q "GP"
I (($P(N0,U,2)'="")&($P(N0,U,10)?1N.N)&(N1="")) D Q "GO"
. S GPDFN=$P($G(^MAG(2005,$P(N0,U,10),0)),U,7) Q
I ($P(N0,U,2)'="")&($P(N0,U,10)'?1N.N)&(N1="") Q "NG"
Q "ER"
PF(IEN,IC,N0,PF,PD0,PD1,PD2,PACS,IOR,APR) ;
N N2
S PACS=$S($D(^MAG(2005,IEN,"PACS")):1,1:0)
S IOR=$S(IC="GO":$P($G(N0),U,10),1:IEN)
I ((IC="GP")!(IC="NG")!((PACS)&(IC="GO"))) S N2=$G(^MAG(2005,IEN,2))
I ((IC="GO")&('PACS)) S N2=$G(^MAG(2005,IOR,2))
S PF=$P(N2,"^",6),PD0=$P(N2,"^",7),PD1=$P(N2,"^",10),PD2=$P(N2,"^",8)
I PACS S APR=$S(PD0?1N.N:1,1:0)
E S APR=$S(((PF'="")&(PD0?1N.N)):1,$P($G(^MAG(2005,IOR,100)),U)?1N.N:1,$P($G(^MAG(2005,IOR,0)),U,6)="18":1,1:0)
Q
DBQ(QIEN,PLACE,ZNODE) ;
Q:'$G(QIEN) N INDX,ST,I,QTYP,TMP ;P186 X-ref clean up
F INDX="DELETE","ABSTRACT","JUKEBOX","JBTOHD","PREFET","IMPORT","EVAL" D
. K ^MAGQUEUE(2006.03,"C",PLACE,INDX,QIEN)
. K:$P(ZNODE,U,5)]"" ^MAGQUEUE(2006.03,"D",PLACE,INDX,$E($P(ZNODE,U,5),1,30),QIEN)
. I INDX="JUKEBOX" D
. . K:$P(ZNODE,U,7) ^MAGQUEUE(2006.03,"E",PLACE,$P(ZNODE,U,7),QIEN) Q
. I "^JBTOHD^PREFET^"[("^"_INDX_"^") D
. . K:((+$P(ZNODE,U,7))&($P(ZNODE,U,8)]"")) ^MAGQUEUE(2006.03,"F",PLACE,$P(ZNODE,U,7),$P(ZNODE,U,8),QIEN) Q
K ^MAGQUEUE(2006.03,QIEN,0)
L +^MAGQUEUE(2006.03,0):1E9 ;P186
S $P(^MAGQUEUE(2006.03,0),"^",4)=$P(^MAGQUEUE(2006.03,0),"^",4)-1
L -^MAGQUEUE(2006.03,0)
L +^MAGQUEUE(2006.031,QP,0):1E9
S TMP=$G(^MAGQUEUE(2006.031,QP,0)),$P(TMP,U,5)=$P(TMP,U,5)-1
S ^MAGQUEUE(2006.031,QP,0)=TMP
L -^MAGQUEUE(2006.031,QP,0)
K ^MAGQUEUE(2006.03,"C",PLACE,$P(ZNODE,U),QIEN)
S ST=$E($P(ZNODE,U,5),1,30) I $L(ST) D ;p186 remove "D" xref COMPLETION STATUS of QIEN - ST
. F I=1:1:100 S TYPE=$O(^MAGQUEUE(2006.03,"D",PLACE,TYPE)) K ^MAGQUEUE(2006.03,"D",PLACE,TYPE,ST,QIEN)
. Q
S MAGIEN=$P(ZNODE,U,7),QTYP=$P(ZNODE,U,8) I +MAGIEN,$L(QTYP) K ^MAGQUEUE(2006.03,"F",PLACE,MAGIEN,QTYP,QIEN)
Q
DQUE(QIEN,QONLY) ;
N ZNODE,TYPE,MAGIEN,PLACE,QP,TMP,DA,IMPORTIEN
S ZNODE=$G(^MAGQUEUE(2006.03,QIEN,0))
S PLACE=$P(ZNODE,U,12)
S TYPE=$P(ZNODE,U)
I TYPE="" D DBQ^MAGQBUT2(QIEN,PLACE,ZNODE) Q
I "^IMPORT^"[("^"_TYPE_"^") S IMPORTIEN=$S($P(ZNODE,U,11)?1N.N:$P(ZNODE,U,11),1:QIEN)
S MAGIEN=$P(ZNODE,U,7)
S QP=$O(^MAGQUEUE(2006.031,"C",PLACE,TYPE,""))
L +^MAGQUEUE(2006.031,QP,0):1E9
S TMP=$G(^MAGQUEUE(2006.031,QP,0))
S $P(TMP,U,5)=$P(TMP,U,5)-1
S ^MAGQUEUE(2006.031,QP,0)=TMP
L -^MAGQUEUE(2006.031,QP,0)
K ^MAGQUEUE(2006.03,"C",PLACE,$P(ZNODE,U),QIEN)
K ^MAGQUEUE(2006.03,QIEN,0)
I $P(ZNODE,U,5)]"" D ;remove "D" xref COMPLETION STATUS of QIEN
. K ^MAGQUEUE(2006.03,"D",PLACE,TYPE,$E($P(ZNODE,U,5),1,30),QIEN)
L +^MAGQUEUE(2006.03,0):1E9
S $P(^MAGQUEUE(2006.03,0),"^",4)=$P(^MAGQUEUE(2006.03,0),"^",4)-1
L -^MAGQUEUE(2006.03,0)
I "^IMPORT^"[("^"_TYPE_"^"),'$D(QONLY) D Q
. I $D(^MAG(2006.041,"B",IMPORTIEN)) D
. . N TRACKID,ASIEN,SIEN
. . S ASIEN=$O(^MAG(2006.041,"B",IMPORTIEN)) Q:ASIEN=""
. . S TRACKID=$P($G(^MAG(2006.041,ASIEN)),U,2) Q:TRACKID=""
. . S ASIEN="A",ASIEN=$O(^MAG(2006.041,"C",TRACKID,ASIEN),-1)
. . F S SIEN=$O(^MAG(2006.041,"C",TRACKID,SIEN),-1) Q:'SIEN D
. . . S DIK="^MAG(2006.041,",DA=SIEN
. . . D ^DIK K DIK,DA
. . . Q
. . Q
. S DIK="^MAG(2006.034,",DA=IMPORTIEN D ^DIK
. K DIK,DA
. K:MAGIEN ^MAGQUEUE(2006.03,"E",PLACE,MAGIEN,IMPORTIEN)
. Q
Q:("^JBTOHD^PREFET^JUKEBOX^")'[("^"_TYPE_"^")
S MAGIEN=$P(ZNODE,U,7)
Q:'MAGIEN
I TYPE="JUKEBOX" D Q
. K ^MAGQUEUE(2006.03,"E",PLACE,MAGIEN,QIEN)
I "^JBTOHD^PREFET^"[("^"_TYPE_"^") D Q
. Q:$P(ZNODE,U,8)']""
. K ^MAGQUEUE(2006.03,"F",PLACE,MAGIEN,$P(ZNODE,U,8),QIEN)
. Q
Q
DQUE1(RESULT,QIEN) ;[MAGQB QUEDEL]
N X,TYPE
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S RESULT=0
S TYPE=$P($G(^MAGQUEUE(2006.03,QIEN,0)),U)
D QRNGE^MAGQBUT5(.RESULT,TYPE,"DEL",QIEN,QIEN)
S RESULT=1
Q
JBQUE(RESULT,QIEN) ; RPC[MAGQ JBQUE]
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
I '+QIEN S RESULT=0 Q
S RESULT=$$JUKEBOX^MAGBAPI(QIEN,$$PLACE^MAGBAPI(+$G(DUZ(2))))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBUT2 11685 printed Sep 23, 2025@19:44:13 Page 2
MAGQBUT2 ;WOIFO/SRR/RMP/JL - IMAGE SITE PARAMETERS COMPANION ; 05 May 2017 3:06 PM
+1 ;;3.0;IMAGING;**7,8,20,81,39,186**;Mar 19, 2002;Build 23;Mar 08, 2011
+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 ;;
MAGSYS(LIST) ;
+1 ; RPC[MAGQ SYSTEM]
+2 NEW VAIEN,NODE,MGIEN,UNAME,TDATE
+3 SET MGIEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
+4 SET VAIEN=0
+5 FOR
SET VAIEN=$ORDER(^XUSEC("MAG SYSTEM",VAIEN))
if VAIEN'?1N.N
QUIT
Begin DoDot:1
+6 SET UNAME=$$GET1^DIQ(200,VAIEN,.01)
+7 if UNAME=""
QUIT
+8 ;CHECK FOR TERMINATION DATE
+9 SET TDATE=$$GET1^DIQ(200,VAIEN,9.2)
+10 if ((TDATE'="")&(TDATE<$$NOW^XLFDT))
QUIT
+11 ;the next line screens existing 'MAG SERVER' members
+12 IF MGIEN?1N.N
IF $$FIND1^DIC(3.81,","_MGIEN_",","QA",VAIEN,"","","ERR")
QUIT
+13 SET LIST(VAIEN)=VAIEN_"^"_UNAME
End DoDot:1
+14 QUIT
IMPAR(RESULT,QIEN) ; Import Array
+1 NEW INDX,CNT
+2 SET (INDX,CNT)=0
+3 FOR
SET INDX=$ORDER(^MAG(2006.034,QIEN,1,INDX))
if INDX'?1N.N
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET RESULT(CNT)=$GET(^MAG(2006.034,QIEN,1,INDX,0))
End DoDot:1
+6 IF CNT<1
SET RESULT(0)="0^Corrupted Import Array"
+7 IF '$TEST
SET RESULT(0)="1"
+8 QUIT
CHKIMG(IEN) ;
+1 ; Given an Image IEN, return:
+2 ; 1: Case # or accession #
+3 ; 2: Parent application~IEN
+4 ; 3: Application DFN
+5 ; 4: Image DFN
+6 ; 5: Flag: true = all DFNs in images in same parent group are identical
+7 ; 6: Image object Class
+8 ;
+9 ; PF: Parent Data file number
+10 ; PT(): Parent file data dictionary
+11 ; PD0: Parent (Global root) IEN (D0)
+12 ; PD1: Lab Parent Global Root (D1)
+13 ; PD2: Parent Data File Image Pointer
+14 ; T(): Error types
+15 ; IDFN: Image file entry DFN
+16 ; PDFN: Parent file DFN
+17 ; GRG: virtual Parent File Image Multiple
+18 ; IOR: Image Object Referenced (by parent)
+19 NEW GF,GP,G0,GR,GRD,GRG,GR0,IDFN,IENV,P0,PD0,PD1,PD2,PF,PT,X,X0,X2,N0,N1,R,T,GPDFN,PACS,IOR,APR,I,PDFN
+20 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+21 SET R="^^^^^"
+22 SET T(1)="No Image ptr in AP"
+23 SET T(2)="GP has no Images"
+24 SET T(3)="Conflicting AP & Image DFNs"
+25 SET T(4)="Invalid Image Ptr to AP"
+26 SET T(5)="Conflicting GP and GO DFN"
+27 SET T(6)="GP & GO AP Mismatch"
+28 SET T(7)="GP Missing GO ptr"
+29 SET T(8)="No AP Ptr"
+30 SET T(9)="No AP Entry ptr"
+31 SET T(10)="No AP Mult ptr"
+32 SET T(11)="GO DFN mismatches"
+33 SET T(12)="Null Image Ptr"
+34 SET T(13)="Invalid Image Ptr"
+35 SET T(14)="Invalid Image Ptr to AP"
+36 SET T(15)="Image Entry is structurally abnormal"
+37 SET T(16)="Missing Group Objects"
+38 SET T(21)="DFN Mismatches in AP Image Mult"
+39 IF IEN=""
SET $PIECE(R,"^",5)=T(12)_"~1"
QUIT R
+40 SET X0=$GET(^MAG(2005,IEN,0))
+41 IF X0=""
SET $PIECE(R,"^",5)=T(13)_"~1"
QUIT R
+42 SET IDFN=$PIECE(X0,"^",7)
SET $PIECE(R,"^",4)=IDFN
+43 SET PT(3.9)="^XMB(3.9,PD0,|Mail message||2|^XMB(3.9,PD0,2005,|MAIL"
+44 ; The following 5 Lab subsections must be in-synch with FILE+42^MAGGTLB1
+45 ; IA #1962
+46 SET PT(63)="^LR(PD0,GF,PD1,|Autopsy (microscopic)|AY|1|^LR(PD0,GF,PD1,2005.1,|AUM"
+47 SET PT(63.02)="^LR(PD0,GF,PD1,|Electron microscopy|EM|1|^LR(PD0,GF,PD1,2005,|EM"
+48 SET PT(63.08)="^LR(PD0,GF,PD1,|Surgical pathology|SP|1|^LR(PD0,GF,PD1,2005,|SP"
+49 SET PT(63.09)="^LR(PD0,GF,PD1,|Cytology|CY|1|^LR(PD0,GF,PD1,2005,|CY|"
+50 SET PT(63.2)="^LR(PD0,GF,PD1,|Autopsy (gross)|AY|1|^LR(PD0,GF,PD1,2005,|AUG"
+51 SET PT(70)="^RADPT(PDFN,|Radiology Patient||1|"
+52 SET PT(74)="^RARPT(PD0,|Radiology||2|^RARPT(PD0,2005,|RAD"
+53 SET PT(130)="^SRF(PD0,|Surgery||1|^SRF(PD0,2005,|SUR"
+54 SET PT(691)="^MCAR(691,PD0,|Echocardiogram||2|^MCAR(691,PD0,2005,|ECHO"
+55 SET PT(691.1)="^MCAR(691.1,PD0,|Cardiac catheterization||2|^MCAR(691.1,PD0,2005,|CATH"
+56 SET PT(691.5)="^MCAR(691.5,PD0,|Electrocardiography||2|^MCAR(691.5,PD0,2005,|ECG"
+57 SET PT(694)="^MCAR(694,PD0,|Hematology||2|^MCAR(694,PD0,2005,|HEM"
+58 SET PT(699)="^MCAR(699,PD0,|Endoscopy||2|^MCAR(699,PD0,2005,|ENDO"
+59 SET PT(699.5)="^MCAR(699.5,PD0,|Medicine||2|^MCAR(699.5,PD0,2005,|GEN"
+60 SET PT(8925)="^TIU(8925,PD0,|TIU||2|^TIU(8925.91,""ADI"",PD0,|TIU"
+61 SET IC=$$IC(IEN,.N0,.N2,.GPDFN)
SET $PIECE(R,U,6)=IC
+62 IF IC="ER"
SET $PIECE(R,U,5)=T(15)_"~1"
QUIT R
+63 IF IC["GP"
IF '$ORDER(^MAG(2005,IEN,1,0))
SET $PIECE(R,U,5)=T(2)_"~1"
QUIT R
+64 DO PF(IEN,IC,N0,.PF,.PD0,.PD1,.PD2,.PACS,.IOR,.APR)
+65 IF "GP^GO"[IC
Begin DoDot:1
+66 SET I=0
+67 FOR
SET I=$ORDER(^MAG(2005,IOR,1,I))
if I'?1N.N
QUIT
Begin DoDot:2
+68 IF '$DATA(^MAG(2005,$PIECE($GET(^MAG(2005,IOR,1,I,0)),U),0))
SET $PIECE(R,U,5)=T(16)_$SELECT(IC="GO":"~2",1:"~1")
+69 QUIT
End DoDot:2
End DoDot:1
if $PIECE(R,U,5)'=""
QUIT R
+70 IF IC["GO"
SET $PIECE(R,U,6)=$PIECE(R,U,6)_"~"_IOR
+71 IF PD2'?1N.N
IF (('PACS)&(PD0?1N.N))
SET $PIECE(R,U,5)=T(10)_$SELECT(IC["GO":"~2",1:"~1")
QUIT R
+72 IF IC["GO"
Begin DoDot:1
+73 NEW I,J
+74 SET (I,J)=0
+75 FOR
SET I=$ORDER(^MAG(2005,IOR,1,I))
if I'?1N.N
QUIT
if IEN=$PIECE($GET(^MAG(2005,IOR,1,I,0)),U,1)
SET J=1
+76 if J=0
SET $PIECE(R,U,5)=T(7)_"~2"
+77 QUIT
End DoDot:1
if $PIECE(R,U,5)'=""
QUIT R
+78 IF IC["GO"
IF IDFN'=GPDFN
SET $PIECE(R,U,5)=T(5)_"~1"
SET $PIECE(R,U,3)=GPDFN
QUIT R
+79 IF IC["GO"
Begin DoDot:1
+80 NEW I,J
+81 SET I=0
+82 FOR
SET I=$ORDER(^MAG(2005,IOR,1,I))
if I'?1N.N
QUIT
Begin DoDot:2
+83 SET J=$PIECE($GET(^MAG(2005,IOR,1,I,0)),U)
+84 IF $PIECE($GET(^MAG(2005,J,0)),U,7)'=IDFN
SET $PIECE(R,U,5)=T(11)_"~2"
SET $PIECE(R,U,3)=$PIECE($GET(^MAG(2005,J,0)),U,7)
+85 QUIT
End DoDot:2
if $PIECE(R,U,5)'=""
QUIT
End DoDot:1
if $PIECE(R,U,5)'=""
QUIT R
+86 IF IC["GO"
IF PACS
IF (($PIECE(N2,U,6,7)'="")&($PIECE(N2,U,6,7)'="^"))
IF $PIECE(N2,U,6,7)'=$PIECE($GET(^MAG(2005,$PIECE(N0,U,10),2)),U,6,7)
Begin DoDot:1
+87 SET $PIECE(R,U,5)=T(6)_"~1"
SET $PIECE(R,U,3)=$PIECE(^MAG(2005,IOR,0),U,7)
QUIT
End DoDot:1
QUIT R
+88 IF (PF\1=63)
IF PD1'?1N.N
IF PD1'?1N.N1"."1N.N
QUIT R
+89 IF PF?1N.E
IF $DATA(PT(+PF))
IF PD0?1N.N
Begin DoDot:1
+90 SET $PIECE(R,"^",2)=$PIECE(PT(PF),"|",6)_"~"_PD0
+91 SET GR=$PIECE(PT(PF),"|",1)
SET GR0=GR_"0)"
+92 SET GF=$PIECE(PT(PF),"|",3)
SET GP=$PIECE(PT(PF),"|",4)
+93 SET T=$PIECE(PT(PF),"|",5)
SET GRD=T_"G0,0)"
SET GRG=T_"G0)"
End DoDot:1
+94 IF '$TEST
Begin DoDot:1
+95 if ((IC["GP")&($PIECE(R,U,5)=""))
SET $PIECE(R,U,5)="1"
End DoDot:1
QUIT R
+96 SET P0=$GET(@GR0)
+97 IF P0=""
SET $PIECE(R,"^",5)=T(4)_$SELECT((('PACS)&(IC["GO")):"~2",1:"~1")
QUIT R
+98 SET PDFN=$SELECT(PF\1=63:$PIECE(^LR(PD0,0),U,3),$PIECE(P0,"^",GP)'="":$PIECE(P0,"^",GP),1:PDFN)
+99 IF 'PDFN
IF $PIECE($GET(^VA(200,IDFN,0)),"^",1)=PDFN
SET PDFN=IDFN
+100 SET $PIECE(R,"^",3)=PDFN
+101 IF PDFN'=IDFN
SET $PIECE(R,U,5)=T(3)_$SELECT((('PACS)&(IC["GO")):"~2",1:"~1")
QUIT R
+102 IF PF=74
Begin DoDot:1
+103 SET GR=$PIECE(PT(70),"|",1)
SET GR0=GR_"0)"
+104 SET GF=$PIECE(PT(70),"|",3)
SET GP=$PIECE(PT(70),"|",4)
+105 SET P0=$GET(@GR0)
SET $PIECE(R,"^",3)=$PIECE(R,"^",3)_"~"_$PIECE(P0,"^",GP)
End DoDot:1
+106 SET T=1
SET G0=0
SET IENV=0
+107 FOR
SET G0=$ORDER(@GRG)
if 'G0
QUIT
if $PIECE(R,U,5)'=""
QUIT
Begin DoDot:1
+108 IF PF=8925
Begin DoDot:2
+109 IF '$DATA(^MAG(2005,+G0,0))
SET $PIECE(R,U,5)=T(14)_$SELECT((('PACS)&(IC["GO")):"~2",1:"~1")
+110 if G0=IOR
SET IENV=1
+111 IF $PIECE($GET(^MAG(2005,+G0,0)),"^",7)'=IDFN
SET $PIECE(R,U,5)=T(21)_"~2"
SET $PIECE(R,U,3)=$PIECE($GET(^MAG(2005,+G0,0)),"^",7)
+112 QUIT
End DoDot:2
QUIT
+113 IF '$DATA(^MAG(2005,+$PIECE($GET(@GRD),"^",1),0))
SET $PIECE(R,U,5)=T(14)_$SELECT((('PACS)&(IC["GO")):"~2",1:"~1")
+114 IF $PIECE($GET(^MAG(2005,+$PIECE($GET(@GRD),"^",1),0)),"^",7)'=IDFN
Begin DoDot:2
+115 SET $PIECE(R,U,5)=T(21)_"~2"
SET $PIECE(R,U,3)=$PIECE($GET(^MAG(2005,+$PIECE($GET(@GRD),"^",1),0)),"^",7)
QUIT
End DoDot:2
QUIT
+116 IF PF=63
if +$PIECE($GET(^LR(PD0,GF,PD1,2005.1,G0,0)),U)=IOR
SET IENV=1
+117 IF PF=63.2
if +$PIECE($GET(^LR(PD0,GF,PD1,2005,G0,0)),U)=IOR
SET IENV=1
+118 if +$PIECE($GET(@GRD),"^",1)=IOR
SET IENV=1
+119 QUIT
End DoDot:1
IF 'T
KILL PT
QUIT
+120 if $PIECE(R,U,5)'=""
QUIT R
+121 IF IC["GP"
SET $PIECE(R,U,5)="1"
+122 IF IENV=0
SET $PIECE(R,U,5)=T(1)_"~1"
+123 IF PF=74
SET $PIECE(R,"^",1)=$PIECE(P0,"^",1)
+124 KILL PT
+125 QUIT R
IC(IEN,N0,N2,GPDFN) ;
+1 SET N0=$GET(^MAG(2005,IEN,0))
+2 SET N1=$GET(^MAG(2005,IEN,1,0))
+3 SET N2=$GET(^MAG(2005,IEN,2))
+4 IF ($PIECE(N0,U,2)="")&($PIECE(N0,U,10)="")&($PIECE(N1,U,4)>0)
QUIT "GP"
+5 IF (($PIECE(N0,U,2)'="")&($PIECE(N0,U,10)?1N.N)&(N1=""))
Begin DoDot:1
+6 SET GPDFN=$PIECE($GET(^MAG(2005,$PIECE(N0,U,10),0)),U,7)
QUIT
End DoDot:1
QUIT "GO"
+7 IF ($PIECE(N0,U,2)'="")&($PIECE(N0,U,10)'?1N.N)&(N1="")
QUIT "NG"
+8 QUIT "ER"
PF(IEN,IC,N0,PF,PD0,PD1,PD2,PACS,IOR,APR) ;
+1 NEW N2
+2 SET PACS=$SELECT($DATA(^MAG(2005,IEN,"PACS")):1,1:0)
+3 SET IOR=$SELECT(IC="GO":$PIECE($GET(N0),U,10),1:IEN)
+4 IF ((IC="GP")!(IC="NG")!((PACS)&(IC="GO")))
SET N2=$GET(^MAG(2005,IEN,2))
+5 IF ((IC="GO")&('PACS))
SET N2=$GET(^MAG(2005,IOR,2))
+6 SET PF=$PIECE(N2,"^",6)
SET PD0=$PIECE(N2,"^",7)
SET PD1=$PIECE(N2,"^",10)
SET PD2=$PIECE(N2,"^",8)
+7 IF PACS
SET APR=$SELECT(PD0?1N.N:1,1:0)
+8 IF '$TEST
SET APR=$SELECT(((PF'="")&(PD0?1N.N)):1,$PIECE($GET(^MAG(2005,IOR,100)),U)?1N.N:1,$PIECE($GET(^MAG(2005,IOR,0)),U,6)="18":1,1:0)
+9 QUIT
DBQ(QIEN,PLACE,ZNODE) ;
+1 ;P186 X-ref clean up
if '$GET(QIEN)
QUIT
NEW INDX,ST,I,QTYP,TMP
+2 FOR INDX="DELETE","ABSTRACT","JUKEBOX","JBTOHD","PREFET","IMPORT","EVAL"
Begin DoDot:1
+3 KILL ^MAGQUEUE(2006.03,"C",PLACE,INDX,QIEN)
+4 if $PIECE(ZNODE,U,5)]""
KILL ^MAGQUEUE(2006.03,"D",PLACE,INDX,$EXTRACT($PIECE(ZNODE,U,5),1,30),QIEN)
+5 IF INDX="JUKEBOX"
Begin DoDot:2
+6 if $PIECE(ZNODE,U,7)
KILL ^MAGQUEUE(2006.03,"E",PLACE,$PIECE(ZNODE,U,7),QIEN)
QUIT
End DoDot:2
+7 IF "^JBTOHD^PREFET^"[("^"_INDX_"^")
Begin DoDot:2
+8 if ((+$PIECE(ZNODE,U,7))&($PIECE(ZNODE,U,8)]""))
KILL ^MAGQUEUE(2006.03,"F",PLACE,$PIECE(ZNODE,U,7),$PIECE(ZNODE,U,8),QIEN)
QUIT
End DoDot:2
End DoDot:1
+9 KILL ^MAGQUEUE(2006.03,QIEN,0)
+10 ;P186
LOCK +^MAGQUEUE(2006.03,0):1E9
+11 SET $PIECE(^MAGQUEUE(2006.03,0),"^",4)=$PIECE(^MAGQUEUE(2006.03,0),"^",4)-1
+12 LOCK -^MAGQUEUE(2006.03,0)
+13 LOCK +^MAGQUEUE(2006.031,QP,0):1E9
+14 SET TMP=$GET(^MAGQUEUE(2006.031,QP,0))
SET $PIECE(TMP,U,5)=$PIECE(TMP,U,5)-1
+15 SET ^MAGQUEUE(2006.031,QP,0)=TMP
+16 LOCK -^MAGQUEUE(2006.031,QP,0)
+17 KILL ^MAGQUEUE(2006.03,"C",PLACE,$PIECE(ZNODE,U),QIEN)
+18 ;p186 remove "D" xref COMPLETION STATUS of QIEN - ST
SET ST=$EXTRACT($PIECE(ZNODE,U,5),1,30)
IF $LENGTH(ST)
Begin DoDot:1
+19 FOR I=1:1:100
SET TYPE=$ORDER(^MAGQUEUE(2006.03,"D",PLACE,TYPE))
KILL ^MAGQUEUE(2006.03,"D",PLACE,TYPE,ST,QIEN)
+20 QUIT
End DoDot:1
+21 SET MAGIEN=$PIECE(ZNODE,U,7)
SET QTYP=$PIECE(ZNODE,U,8)
IF +MAGIEN
IF $LENGTH(QTYP)
KILL ^MAGQUEUE(2006.03,"F",PLACE,MAGIEN,QTYP,QIEN)
+22 QUIT
DQUE(QIEN,QONLY) ;
+1 NEW ZNODE,TYPE,MAGIEN,PLACE,QP,TMP,DA,IMPORTIEN
+2 SET ZNODE=$GET(^MAGQUEUE(2006.03,QIEN,0))
+3 SET PLACE=$PIECE(ZNODE,U,12)
+4 SET TYPE=$PIECE(ZNODE,U)
+5 IF TYPE=""
DO DBQ^MAGQBUT2(QIEN,PLACE,ZNODE)
QUIT
+6 IF "^IMPORT^"[("^"_TYPE_"^")
SET IMPORTIEN=$SELECT($PIECE(ZNODE,U,11)?1N.N:$PIECE(ZNODE,U,11),1:QIEN)
+7 SET MAGIEN=$PIECE(ZNODE,U,7)
+8 SET QP=$ORDER(^MAGQUEUE(2006.031,"C",PLACE,TYPE,""))
+9 LOCK +^MAGQUEUE(2006.031,QP,0):1E9
+10 SET TMP=$GET(^MAGQUEUE(2006.031,QP,0))
+11 SET $PIECE(TMP,U,5)=$PIECE(TMP,U,5)-1
+12 SET ^MAGQUEUE(2006.031,QP,0)=TMP
+13 LOCK -^MAGQUEUE(2006.031,QP,0)
+14 KILL ^MAGQUEUE(2006.03,"C",PLACE,$PIECE(ZNODE,U),QIEN)
+15 KILL ^MAGQUEUE(2006.03,QIEN,0)
+16 ;remove "D" xref COMPLETION STATUS of QIEN
IF $PIECE(ZNODE,U,5)]""
Begin DoDot:1
+17 KILL ^MAGQUEUE(2006.03,"D",PLACE,TYPE,$EXTRACT($PIECE(ZNODE,U,5),1,30),QIEN)
End DoDot:1
+18 LOCK +^MAGQUEUE(2006.03,0):1E9
+19 SET $PIECE(^MAGQUEUE(2006.03,0),"^",4)=$PIECE(^MAGQUEUE(2006.03,0),"^",4)-1
+20 LOCK -^MAGQUEUE(2006.03,0)
+21 IF "^IMPORT^"[("^"_TYPE_"^")
IF '$DATA(QONLY)
Begin DoDot:1
+22 IF $DATA(^MAG(2006.041,"B",IMPORTIEN))
Begin DoDot:2
+23 NEW TRACKID,ASIEN,SIEN
+24 SET ASIEN=$ORDER(^MAG(2006.041,"B",IMPORTIEN))
if ASIEN=""
QUIT
+25 SET TRACKID=$PIECE($GET(^MAG(2006.041,ASIEN)),U,2)
if TRACKID=""
QUIT
+26 SET ASIEN="A"
SET ASIEN=$ORDER(^MAG(2006.041,"C",TRACKID,ASIEN),-1)
+27 FOR
SET SIEN=$ORDER(^MAG(2006.041,"C",TRACKID,SIEN),-1)
if 'SIEN
QUIT
Begin DoDot:3
+28 SET DIK="^MAG(2006.041,"
SET DA=SIEN
+29 DO ^DIK
KILL DIK,DA
+30 QUIT
End DoDot:3
+31 QUIT
End DoDot:2
+32 SET DIK="^MAG(2006.034,"
SET DA=IMPORTIEN
DO ^DIK
+33 KILL DIK,DA
+34 if MAGIEN
KILL ^MAGQUEUE(2006.03,"E",PLACE,MAGIEN,IMPORTIEN)
+35 QUIT
End DoDot:1
QUIT
+36 if ("^JBTOHD^PREFET^JUKEBOX^")'[("^"_TYPE_"^")
QUIT
+37 SET MAGIEN=$PIECE(ZNODE,U,7)
+38 if 'MAGIEN
QUIT
+39 IF TYPE="JUKEBOX"
Begin DoDot:1
+40 KILL ^MAGQUEUE(2006.03,"E",PLACE,MAGIEN,QIEN)
End DoDot:1
QUIT
+41 IF "^JBTOHD^PREFET^"[("^"_TYPE_"^")
Begin DoDot:1
+42 if $PIECE(ZNODE,U,8)']""
QUIT
+43 KILL ^MAGQUEUE(2006.03,"F",PLACE,MAGIEN,$PIECE(ZNODE,U,8),QIEN)
+44 QUIT
End DoDot:1
QUIT
+45 QUIT
DQUE1(RESULT,QIEN) ;[MAGQB QUEDEL]
+1 NEW X,TYPE
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 SET RESULT=0
+4 SET TYPE=$PIECE($GET(^MAGQUEUE(2006.03,QIEN,0)),U)
+5 DO QRNGE^MAGQBUT5(.RESULT,TYPE,"DEL",QIEN,QIEN)
+6 SET RESULT=1
+7 QUIT
JBQUE(RESULT,QIEN) ; RPC[MAGQ JBQUE]
+1 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+2 IF '+QIEN
SET RESULT=0
QUIT
+3 SET RESULT=$$JUKEBOX^MAGBAPI(QIEN,$$PLACE^MAGBAPI(+$GET(DUZ(2))))
+4 QUIT
