MAGQBUT5 ;WOIFO/RMP - BP Utilities ; 17 JUL 2014 10:19 AM
;;3.0;IMAGING;**20,81,39,154**;Mar 19, 2002;Build 9;Jul 28, 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. |
;; +---------------------------------------------------------------+
;;
Q
AI(RESULT) ; List of Associated Institution candidates;
N INDEX,INST,J,K,L,OUT
S K=0
S RESULT(K)=""
S K=K+1
D LIST^DIC(40.8,,".01;.07I",,,,,,,,"OUT")
S RESULT(K)="The following Medical Center Divisions have Imaging Site Parameters defined on ",K=K+1
S RESULT(K)="your system:" D
. S INDEX=0,K=K+1 F S INDEX=INDEX+1 Q:'$D(OUT("DILIST","ID",INDEX)) D
. . S INST=OUT("DILIST","ID",INDEX,.07),J=0 F S J=$O(^MAG(2006.1,J)) Q:'J I $P(^MAG(2006.1,J,0),U)=INST D Q
. . . S RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST,K=K+1 Q
. . Q
. Q
I INDEX=1 S RESULT(K)="None",K=K+1
S RESULT(K)="The following Medical Center Divisions have 'Associated Institutions' defined on ",K=K+1
S RESULT(K)="your system:" D
. S INDEX="",K=K+1,L=K F S INDEX=$O(^MAG(2006.1,"B",INDEX)) Q:'INDEX D
. . Q:$P($G(^MAG(2006.1,$O(^MAG(2006.1,"B",INDEX,"")),0)),U)=INDEX
. . S RESULT(K)=$$GET1^DIQ(4,INDEX,.01,"E")_" "_INDEX,K=K+1 Q ;IA fix
. Q
I K=L S RESULT(K)="None",K=K+1
S RESULT(K)="The following Medical Center Divisions have NO Imaging parameter affiliations ",K=K+1
S RESULT(K)="defined on your system:" D
. S INDEX=0,K=K+1,L=K F S INDEX=INDEX+1 Q:'$D(OUT("DILIST","ID",INDEX)) D
. . S INST=OUT("DILIST","ID",INDEX,.07) Q:$D(^MAG(2006.1,"B",INST)) D
. . . S RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST,K=K+1 Q
. . Q
. Q
I K=L S RESULT(K)="None",K=K+1
K OUT
D CLEAN^DILF
Q
PLNM(PLACE) ; Returns the Institution name of the Place
N INST
Q:'PLACE " "
S INST=$P($G(^MAG(2006.1,PLACE,0)),U)
Q $$GET1^DIQ(4,INST,.01,"E") ;IA fix
TPMESS(PLACE) ;Trigger a purge message
N Y,LOC,CNT,XMSUB
S Y=$$FMTE^XLFDT($$NOW^XLFDT)
S LOC=$$KSP^XUPARAM("WHERE")
S CNT=1,^TMP($J,"MAGQ",CNT)="SITE: "_LOC
S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="DATE: "_Y_" "_$G(^XMB("TIMEZONE"))
S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="SENDER: "_$$PLNM^MAGQBUT5(PLACE)_" Imaging Background Processor"
S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="An automatic purge event has been initiated"
S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="in order to maintain adequate image storage"
S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="no operator intervention is required."
S XMSUB="VistA Imaging BP Queue processor - Autopurge"
D MAILSHR^MAGQBUT1(PLACE,"AUTOPURGE",XMSUB)
D UDMI^MAGQBUT5("VistA Imaging BP Queue processor - Autopurge",PLACE)
Q
ADDMG(SUB,XMY,PLACE) ; Provide an array of Message Recipients for Message Subject
N INDEX,IEN,GROUP,NAME,J,K,L,KEY
S SUB=$TR(SUB," ","_")
S XMY("G.MAG SERVER")=""
S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D
. Q:SUB'[INDEX
. S J=$O(^MAG(2006.1,PLACE,6,"B",INDEX,"")) ; first add Mail Groups
. S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,1,"B",K)) Q:'K D
. . Q:'$$GOTLOCAL^XMXAPIG(K,"")
. . S NAME="G."_$$GET1^DIQ(3.8,K,.01,"E")
. . S XMY(NAME)=""
. . Q
. I +$P($G(^MAG(2006.1,PLACE,6,J,3,0)),U,4) D ; next add Mail Message members
. . S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,3,"B",K)) Q:'K D
. . . Q:'+$$ACTIVE^XUSER(K)
. . . S XMY(K)=""
. . . Q
. . Q
. I +$P($G(^MAG(2006.1,PLACE,6,J,4,0)),U,4) D ; next add designated Security Key holders
. . S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,4,"B",K)) Q:'K D
. . . S KEY=$P($G(^DIC(19.1,K,0)),U,1) Q:KEY=""
. . . S L="" F S L=$O(^XUSEC(KEY,L)) Q:'L D
. . . . Q:'+$$ACTIVE^XUSER(L)
. . . . S XMY(L)=""
. . . . Q
. . . Q
. . Q
. Q
Q
GETMI(SUB,PLACE) ; Provide the message interval assigned to this message type
N INDEX,RETURN,IEN,IENS
S RETURN=0
S SUB=$TR(SUB," ","_")
S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D
. Q:SUB'[INDEX
. S IEN=$O(^MAG(2006.1,PLACE,6,"B",INDEX,""))
. S IENS=IEN_","_PLACE_","
. S RETURN=$$GET1^DIQ(2006.166,IENS,1)_U_$$GET1^DIQ(2006.166,IENS,3,"I")
Q $S('RETURN:0,1:RETURN)
;
UDMI(SUB,PLACE) ; Update DATE OF LAST MESSAGE
N INDEX,RETURN,IEN
S RETURN=0
S SUB=$TR(SUB," ","_")
S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D Q:RETURN
. Q:SUB'[INDEX
. S IEN=$O(^MAG(2006.1,PLACE,6,"B",INDEX,""))
. S $P(^MAG(2006.1,PLACE,6,IEN,2),U,1)=$$NOW^XLFDT
. S RETURN="1"
. Q
Q RETURN
;
RMRPC(NAME) ; Removing an RPC in order to revise
N MW,RPC,MWE,DIERR,DA,DIK
S MW=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","")
D CLEAN^DILF
S RPC=$$FIND1^DIC(8994,"","X",NAME,"","","")
D CLEAN^DILF
Q:'RPC
I MW D
. S MWE=$$FIND1^DIC(19.05,","_MW_",","X",NAME,"","","")
. D CLEAN^DILF
. Q:'MWE
. S DA=MWE,DA(1)=MW,DIK="^DIC(19,"_DA(1)_",""RPC"","
. D ^DIK
. K DA,DIK
. Q
S DA=RPC,DIK="^XWB(8994,"
D ^DIK
K DA,DIK
Q
MOVE(RESULT,FNAM) ;[MAGQ MOVE]
N IEN,FTYPE,NMSPC,SITEID,EXT,ALT,J,X
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S NMSPC=$TR($P(FNAM,"."),"0123456789","")
S SITEID=$$INIS^MAGQBPG2($$PLACE^MAGBAPI(+DUZ(2)))
I SITEID'[(","_NMSPC_",") D Q
. S RESULT="0^Invalid Imaging Namespace"
S IEN=$O(^MAG(2005,"F",$P(FNAM,"."),""))
I IEN'?1N.N!('$D(^MAG(2005,IEN,0))) D Q
. S RESULT="0^No matching 2005 entry"
S EXT=$P(FNAM,".",2)
I $P($G(^MAG(2005,IEN,0)),U,2)[FNAM S RESULT=IEN_U_"FULL"
E D
. S FTYPE=$$FTYPE^MAGQBPRG(EXT,IEN)
. I FTYPE="FULL" D Q
. . D FTYPE(.ALT)
. . S J=""
. . F S J=$O(ALT(J)) Q:J'?1N.N S:ALT(J)[EXT FTYPE="ALT"
. . I FTYPE["ALT" S RESULT=IEN_U_FTYPE
. . E S RESULT="0^Invalid File Extension"
. E S RESULT=IEN_U_FTYPE
Q
QRNGE(RESULT,QUEUE,PROC,START,STOP,PLACE) ;
;[MAGQ QRNGE] Requeue/Dequeue a Range of Queues
N XX,CNT,TMP,QP,X,PART
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S CNT=0,TMP=""
S PLACE=$P($G(^MAGQUEUE(2006.03,START,0)),U,12)
Q:'PLACE
S XX=+$O(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,START),-1)
F S XX=$O(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,XX)) Q:'XX Q:XX>(STOP) D
. S CNT=CNT+1
. D:PROC="DEL"
. . S QP=$O(^MAGQUEUE(2006.031,"C",PLACE,QUEUE,""))
. . S PART=$S(QP:$P(^MAGQUEUE(2006.031,QP,0),U,2),1:"")
. . I XX>PART D ADD^MAGBAPI(-1,QUEUE,PLACE)
. . D DQUE^MAGQBUT2(XX)
. . Q
. D:PROC="REQ" REQUE^MAGQBTM(.TMP,XX)
. Q
S RESULT=CNT
Q
UAT(RESULT,PLACE) ; to support and maintain a dummy BP workstation with unassigned workstation tasks - future RPC
;AUTO PURGE(3), AUTO VERIFY(4), ABSTRACT(12), JUKEBOX(13), JBTOHD(14), PREFET(15), IMPORT(16), GCC(17), DELETE(20)
N WSIEN,TASKS,WS,UAT,NODE,PIECE,FIELD,ASSIGNED,I
; Remove and re-build unassigned task entry
S I=0 F S I=$O(^MAG(2006.8,I)) Q:'I S NODE=$G(^MAG(2006.8,I,0)) D
. Q:$P(NODE,U)'="UAT"
. Q:$P(NODE,U,2)'=PLACE
. S DIK="^MAG(2006.8,",DA=I
. D ^DIK
. K DIK
. Q
S RESULT="1"
D:'$D(^MAG(2006.8,"C",PLACE,"Unassigned Tasks")) CUAT(PLACE)
S UAT=$O(^MAG(2006.8,"C",PLACE,"Unassigned Tasks",""))
F FIELD=3,4,12,13,14,15,16,17,20 D
. S (ASSIGNED,WS)=""
. F S WS=$O(^MAG(2006.8,"C",PLACE,WS)) Q:WS="" D Q:ASSIGNED
. . S WSIEN=$O(^MAG(2006.8,"C",PLACE,WS,""))
. . S ASSIGNED=+$$GET1^DIQ(2006.8,WSIEN_",",FIELD,"I","","")
. . Q
. I 'ASSIGNED S FDA(2006.8,UAT_",",FIELD)="1"
. Q
I $D(FDA) D FILE^DIE("","FDA","FDAIEN")
K FDA,FDAIEN
Q RESULT
CUAT(PLACE) ;
N CUATFDA
S CUATFDA(10,2006.8,"+1,",.01)="UAT"
S CUATFDA(10,2006.8,"+1,",.04)=PLACE
S CUATFDA(10,2006.8,"+1,",50)="Unassigned Tasks"
D UPDATE^DIE("","CUATFDA(10)","FDAIEN")
K CUATFDA
Q
FINDC(RESULT,FNUM,IENS,FLAG,FNDVALUE,XREF,SCREEN) ; [MAGQ FINDC] Find with Compound Index - uses key field lookup
; function Find1(FNum,IENS,Flag,FndValue,XREF,Screen:string;silent:boolean): string;
N VALUE,INDEX
F INDEX=1:1:$L(FNDVALUE,U) S VALUE(INDEX)=$P(FNDVALUE,U,INDEX)
S RESULT=$$FIND1^DIC(FNUM,IENS,FLAG,.VALUE,XREF,SCREEN,"FNDERR")
K FNDERR
Q RESULT
CRG(PL,RG) ; Count RAID groups by place
N CNT,I,J,NODE,NV
S I=RG,CNT=0,NV=""
F S I=$O(^MAG(2005.2,"B",I)) Q:I="" Q:($E(I,1,$L(RG))'[RG) D
. S J=$O(^MAG(2005.2,"B",I,"")) Q:'J S NODE=$G(^MAG(2005.2,J,0)) D Q:NV'=""
. . Q:$P(NODE,"^",10)'=PL ; Screen on Place
. . S CNT=CNT+1
. . S:'$D(^MAG(2005.2,"B",(RG_CNT))) NV=(RG_CNT)
. . Q
. Q
S:NV="" NV=RG_(CNT+1)
Q NV
ADDRG(RESULT,CNT,PLACE) ; Add Raid Groups to the Network Location file
; [MAGQ ADD RAID GROUP]
N PL,I,VALUE,NMSP,LRG,X
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S PL=$G(PLACE)
S:PL="" PL=$$PLACE^MAGBAPI(+$G(DUZ(2))) Q:'PL D
. S NMSP=$P($G(^MAG(2006.1,PL,0)),U,2)
. F I=1:1:CNT D
. . S VALUE=$$CRG(PL,"RG-"_NMSP)
. . Q:$D(^MAG(2005.2,"D",PL,VALUE)) ; Do not create duplicates
. . S MAGFDA(2005.2,"+1,",.01)=VALUE
. . S MAGFDA(2005.2,"+1,",.04)=PL ;Place
. . S MAGFDA(2005.2,"+1,",5)="0" ;READ-only
. . S MAGFDA(2005.2,"+1,",6)="GRP" ;"RAID-GROUP"
. . D UPDATE^DIE("U","MAGFDA","MAGIEN","MAGERR")
. . I $D(DIERR) W !,"Error updating the Network Location file: "_MAGERR("DIERR",1,"TEXT",1)
. . K MAGFDA,DIERR,MAGIEN,MAGFDA,MAGERR
. . Q
. Q
S RESULT="1"
Q
;
CAS ; Remove Acquisition Session file entries
; Remove entries in 2006.041 - ACQUISITION SESSION FILE
; Find COMPLETE import series and reduce to final outcome entry, keep for unique TrackingID ?
; Next remove IMPORT QUEUE entry if Complete
;Remove old queue entries from 2006.034 with no 2006.041 complement
N DA,DIK,IEN,TRKID,IMPORTQ,ZNODE,STATUS,SIEN
S IEN="A"
F S IEN=$O(^MAG(2006.041,IEN),-1) Q:'IEN D
. S ZNODE=$G(^MAG(2006.041,IEN,0))
. S IMPORTQ=$P(ZNODE,U,1),TRKID=$P(ZNODE,U,2),STATUS=$P(ZNODE,U,5)
. I TRKID="" S DIK="^MAG(2006.041,",DA=IEN D ^DIK K DIK,DA Q
. I $D(^MAG(2006.041,"C",TRKID)) D
. . ; skip latest entry, remove preliminary status entries
. . S SIEN="A",SIEN=$O(^MAG(2006.041,"C",TRKID,SIEN),-1)
. . I $$UPPER^MAGQE4($G(^MAG(2006.041,IEN,0)))["COMPLETE" D
. . . ; Remove IMPORT QUEUE entry if Complete
. . . I $D(^MAG(2006.034,IMPORTQ,0)) D
. . . . S DIK="^MAG(2006.034,",DA=IMPORTQ
. . . . D ^DIK K DIK,DA
. . . . ; Remove Queue Record, if it exists to eliminate dangling pointer
. . . . I $D(^MAGQUEUE(2006.03,IMPORTQ,0)) D DQUE^MAGQBUT2(IMPORTQ)
. . . . Q
. . . ; Remove log activity if Complete
. . . F S SIEN=$O(^MAG(2006.041,"C",TRKID,SIEN),-1) Q:'SIEN D
. . . . S DIK="^MAG(2006.041,",DA=SIEN
. . . . D ^DIK K DIK,DA
. . . . Q
. Q
; Remove old queue entries from 2006.034 with no 2006.041 complement
S IEN="" F S IEN=$O(^MAG(2006.034,IEN)) Q:'IEN D:'$D(^MAG(2006.041,"B",IEN))
. S DIK="^MAG(2006.034,",DA=IEN
. D ^DIK
. K DIK,DA
. ; Remove Queue Record, if it exists to eliminate dangling pointer
. I $D(^MAGQUEUE(2006.03,IMPORTQ,0)) D DQUE^MAGQBUT2(IMPORTQ)
. Q
Q
;
FTYPE(RESULT) ;
; RPC[MAGQ FTYPE]
N MAX,INDX,PLACE,X
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S U="^",MAX=$P(^MAG(2006.1,PLACE,2,0),U,4),INDX=0
Q:+MAX<1
F S INDX=$O(^MAG(2006.1,PLACE,2,INDX)) Q:INDX'?1N.N D Q:INDX=MAX
. S RESULT(INDX-1)=$G(^MAG(2006.1,PLACE,2,INDX,0))
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBUT5 11936 printed Sep 23, 2025@19:44:15 Page 2
MAGQBUT5 ;WOIFO/RMP - BP Utilities ; 17 JUL 2014 10:19 AM
+1 ;;3.0;IMAGING;**20,81,39,154**;Mar 19, 2002;Build 9;Jul 28, 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 ;;
+17 QUIT
AI(RESULT) ; List of Associated Institution candidates;
+1 NEW INDEX,INST,J,K,L,OUT
+2 SET K=0
+3 SET RESULT(K)=""
+4 SET K=K+1
+5 DO LIST^DIC(40.8,,".01;.07I",,,,,,,,"OUT")
+6 SET RESULT(K)="The following Medical Center Divisions have Imaging Site Parameters defined on "
SET K=K+1
+7 SET RESULT(K)="your system:"
Begin DoDot:1
+8 SET INDEX=0
SET K=K+1
FOR
SET INDEX=INDEX+1
if '$DATA(OUT("DILIST","ID",INDEX))
QUIT
Begin DoDot:2
+9 SET INST=OUT("DILIST","ID",INDEX,.07)
SET J=0
FOR
SET J=$ORDER(^MAG(2006.1,J))
if 'J
QUIT
IF $PIECE(^MAG(2006.1,J,0),U)=INST
Begin DoDot:3
+10 SET RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST
SET K=K+1
QUIT
End DoDot:3
QUIT
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF INDEX=1
SET RESULT(K)="None"
SET K=K+1
+14 SET RESULT(K)="The following Medical Center Divisions have 'Associated Institutions' defined on "
SET K=K+1
+15 SET RESULT(K)="your system:"
Begin DoDot:1
+16 SET INDEX=""
SET K=K+1
SET L=K
FOR
SET INDEX=$ORDER(^MAG(2006.1,"B",INDEX))
if 'INDEX
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^MAG(2006.1,$ORDER(^MAG(2006.1,"B",INDEX,"")),0)),U)=INDEX
QUIT
+18 ;IA fix
SET RESULT(K)=$$GET1^DIQ(4,INDEX,.01,"E")_" "_INDEX
SET K=K+1
QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF K=L
SET RESULT(K)="None"
SET K=K+1
+21 SET RESULT(K)="The following Medical Center Divisions have NO Imaging parameter affiliations "
SET K=K+1
+22 SET RESULT(K)="defined on your system:"
Begin DoDot:1
+23 SET INDEX=0
SET K=K+1
SET L=K
FOR
SET INDEX=INDEX+1
if '$DATA(OUT("DILIST","ID",INDEX))
QUIT
Begin DoDot:2
+24 SET INST=OUT("DILIST","ID",INDEX,.07)
if $DATA(^MAG(2006.1,"B",INST))
QUIT
Begin DoDot:3
+25 SET RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST
SET K=K+1
QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 IF K=L
SET RESULT(K)="None"
SET K=K+1
+29 KILL OUT
+30 DO CLEAN^DILF
+31 QUIT
PLNM(PLACE) ; Returns the Institution name of the Place
+1 NEW INST
+2 if 'PLACE
QUIT " "
+3 SET INST=$PIECE($GET(^MAG(2006.1,PLACE,0)),U)
+4 ;IA fix
QUIT $$GET1^DIQ(4,INST,.01,"E")
TPMESS(PLACE) ;Trigger a purge message
+1 NEW Y,LOC,CNT,XMSUB
+2 SET Y=$$FMTE^XLFDT($$NOW^XLFDT)
+3 SET LOC=$$KSP^XUPARAM("WHERE")
+4 SET CNT=1
SET ^TMP($JOB,"MAGQ",CNT)="SITE: "_LOC
+5 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",CNT)="DATE: "_Y_" "_$GET(^XMB("TIMEZONE"))
+6 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",CNT)="SENDER: "_$$PLNM^MAGQBUT5(PLACE)_" Imaging Background Processor"
+7 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",CNT)="An automatic purge event has been initiated"
+8 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",CNT)="in order to maintain adequate image storage"
+9 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",CNT)="no operator intervention is required."
+10 SET XMSUB="VistA Imaging BP Queue processor - Autopurge"
+11 DO MAILSHR^MAGQBUT1(PLACE,"AUTOPURGE",XMSUB)
+12 DO UDMI^MAGQBUT5("VistA Imaging BP Queue processor - Autopurge",PLACE)
+13 QUIT
ADDMG(SUB,XMY,PLACE) ; Provide an array of Message Recipients for Message Subject
+1 NEW INDEX,IEN,GROUP,NAME,J,K,L,KEY
+2 SET SUB=$TRANSLATE(SUB," ","_")
+3 SET XMY("G.MAG SERVER")=""
+4 SET INDEX=""
FOR
SET INDEX=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+5 if SUB'[INDEX
QUIT
+6 ; first add Mail Groups
SET J=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX,""))
+7 SET K=0
FOR
SET K=$ORDER(^MAG(2006.1,PLACE,6,J,1,"B",K))
if 'K
QUIT
Begin DoDot:2
+8 if '$$GOTLOCAL^XMXAPIG(K,"")
QUIT
+9 SET NAME="G."_$$GET1^DIQ(3.8,K,.01,"E")
+10 SET XMY(NAME)=""
+11 QUIT
End DoDot:2
+12 ; next add Mail Message members
IF +$PIECE($GET(^MAG(2006.1,PLACE,6,J,3,0)),U,4)
Begin DoDot:2
+13 SET K=0
FOR
SET K=$ORDER(^MAG(2006.1,PLACE,6,J,3,"B",K))
if 'K
QUIT
Begin DoDot:3
+14 if '+$$ACTIVE^XUSER(K)
QUIT
+15 SET XMY(K)=""
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 ; next add designated Security Key holders
IF +$PIECE($GET(^MAG(2006.1,PLACE,6,J,4,0)),U,4)
Begin DoDot:2
+19 SET K=0
FOR
SET K=$ORDER(^MAG(2006.1,PLACE,6,J,4,"B",K))
if 'K
QUIT
Begin DoDot:3
+20 SET KEY=$PIECE($GET(^DIC(19.1,K,0)),U,1)
if KEY=""
QUIT
+21 SET L=""
FOR
SET L=$ORDER(^XUSEC(KEY,L))
if 'L
QUIT
Begin DoDot:4
+22 if '+$$ACTIVE^XUSER(L)
QUIT
+23 SET XMY(L)=""
+24 QUIT
End DoDot:4
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 QUIT
GETMI(SUB,PLACE) ; Provide the message interval assigned to this message type
+1 NEW INDEX,RETURN,IEN,IENS
+2 SET RETURN=0
+3 SET SUB=$TRANSLATE(SUB," ","_")
+4 SET INDEX=""
FOR
SET INDEX=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+5 if SUB'[INDEX
QUIT
+6 SET IEN=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX,""))
+7 SET IENS=IEN_","_PLACE_","
+8 SET RETURN=$$GET1^DIQ(2006.166,IENS,1)_U_$$GET1^DIQ(2006.166,IENS,3,"I")
End DoDot:1
+9 QUIT $SELECT('RETURN:0,1:RETURN)
+10 ;
UDMI(SUB,PLACE) ; Update DATE OF LAST MESSAGE
+1 NEW INDEX,RETURN,IEN
+2 SET RETURN=0
+3 SET SUB=$TRANSLATE(SUB," ","_")
+4 SET INDEX=""
FOR
SET INDEX=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+5 if SUB'[INDEX
QUIT
+6 SET IEN=$ORDER(^MAG(2006.1,PLACE,6,"B",INDEX,""))
+7 SET $PIECE(^MAG(2006.1,PLACE,6,IEN,2),U,1)=$$NOW^XLFDT
+8 SET RETURN="1"
+9 QUIT
End DoDot:1
if RETURN
QUIT
+10 QUIT RETURN
+11 ;
RMRPC(NAME) ; Removing an RPC in order to revise
+1 NEW MW,RPC,MWE,DIERR,DA,DIK
+2 SET MW=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","")
+3 DO CLEAN^DILF
+4 SET RPC=$$FIND1^DIC(8994,"","X",NAME,"","","")
+5 DO CLEAN^DILF
+6 if 'RPC
QUIT
+7 IF MW
Begin DoDot:1
+8 SET MWE=$$FIND1^DIC(19.05,","_MW_",","X",NAME,"","","")
+9 DO CLEAN^DILF
+10 if 'MWE
QUIT
+11 SET DA=MWE
SET DA(1)=MW
SET DIK="^DIC(19,"_DA(1)_",""RPC"","
+12 DO ^DIK
+13 KILL DA,DIK
+14 QUIT
End DoDot:1
+15 SET DA=RPC
SET DIK="^XWB(8994,"
+16 DO ^DIK
+17 KILL DA,DIK
+18 QUIT
MOVE(RESULT,FNAM) ;[MAGQ MOVE]
+1 NEW IEN,FTYPE,NMSPC,SITEID,EXT,ALT,J,X
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 SET NMSPC=$TRANSLATE($PIECE(FNAM,"."),"0123456789","")
+4 SET SITEID=$$INIS^MAGQBPG2($$PLACE^MAGBAPI(+DUZ(2)))
+5 IF SITEID'[(","_NMSPC_",")
Begin DoDot:1
+6 SET RESULT="0^Invalid Imaging Namespace"
End DoDot:1
QUIT
+7 SET IEN=$ORDER(^MAG(2005,"F",$PIECE(FNAM,"."),""))
+8 IF IEN'?1N.N!('$DATA(^MAG(2005,IEN,0)))
Begin DoDot:1
+9 SET RESULT="0^No matching 2005 entry"
End DoDot:1
QUIT
+10 SET EXT=$PIECE(FNAM,".",2)
+11 IF $PIECE($GET(^MAG(2005,IEN,0)),U,2)[FNAM
SET RESULT=IEN_U_"FULL"
+12 IF '$TEST
Begin DoDot:1
+13 SET FTYPE=$$FTYPE^MAGQBPRG(EXT,IEN)
+14 IF FTYPE="FULL"
Begin DoDot:2
+15 DO FTYPE(.ALT)
+16 SET J=""
+17 FOR
SET J=$ORDER(ALT(J))
if J'?1N.N
QUIT
if ALT(J)[EXT
SET FTYPE="ALT"
+18 IF FTYPE["ALT"
SET RESULT=IEN_U_FTYPE
+19 IF '$TEST
SET RESULT="0^Invalid File Extension"
End DoDot:2
QUIT
+20 IF '$TEST
SET RESULT=IEN_U_FTYPE
End DoDot:1
+21 QUIT
QRNGE(RESULT,QUEUE,PROC,START,STOP,PLACE) ;
+1 ;[MAGQ QRNGE] Requeue/Dequeue a Range of Queues
+2 NEW XX,CNT,TMP,QP,X,PART
+3 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+4 SET CNT=0
SET TMP=""
+5 SET PLACE=$PIECE($GET(^MAGQUEUE(2006.03,START,0)),U,12)
+6 if 'PLACE
QUIT
+7 SET XX=+$ORDER(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,START),-1)
+8 FOR
SET XX=$ORDER(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,XX))
if 'XX
QUIT
if XX>(STOP)
QUIT
Begin DoDot:1
+9 SET CNT=CNT+1
+10 if PROC="DEL"
Begin DoDot:2
+11 SET QP=$ORDER(^MAGQUEUE(2006.031,"C",PLACE,QUEUE,""))
+12 SET PART=$SELECT(QP:$PIECE(^MAGQUEUE(2006.031,QP,0),U,2),1:"")
+13 IF XX>PART
DO ADD^MAGBAPI(-1,QUEUE,PLACE)
+14 DO DQUE^MAGQBUT2(XX)
+15 QUIT
End DoDot:2
+16 if PROC="REQ"
DO REQUE^MAGQBTM(.TMP,XX)
+17 QUIT
End DoDot:1
+18 SET RESULT=CNT
+19 QUIT
UAT(RESULT,PLACE) ; to support and maintain a dummy BP workstation with unassigned workstation tasks - future RPC
+1 ;AUTO PURGE(3), AUTO VERIFY(4), ABSTRACT(12), JUKEBOX(13), JBTOHD(14), PREFET(15), IMPORT(16), GCC(17), DELETE(20)
+2 NEW WSIEN,TASKS,WS,UAT,NODE,PIECE,FIELD,ASSIGNED,I
+3 ; Remove and re-build unassigned task entry
+4 SET I=0
FOR
SET I=$ORDER(^MAG(2006.8,I))
if 'I
QUIT
SET NODE=$GET(^MAG(2006.8,I,0))
Begin DoDot:1
+5 if $PIECE(NODE,U)'="UAT"
QUIT
+6 if $PIECE(NODE,U,2)'=PLACE
QUIT
+7 SET DIK="^MAG(2006.8,"
SET DA=I
+8 DO ^DIK
+9 KILL DIK
+10 QUIT
End DoDot:1
+11 SET RESULT="1"
+12 if '$DATA(^MAG(2006.8,"C",PLACE,"Unassigned Tasks"))
DO CUAT(PLACE)
+13 SET UAT=$ORDER(^MAG(2006.8,"C",PLACE,"Unassigned Tasks",""))
+14 FOR FIELD=3,4,12,13,14,15,16,17,20
Begin DoDot:1
+15 SET (ASSIGNED,WS)=""
+16 FOR
SET WS=$ORDER(^MAG(2006.8,"C",PLACE,WS))
if WS=""
QUIT
Begin DoDot:2
+17 SET WSIEN=$ORDER(^MAG(2006.8,"C",PLACE,WS,""))
+18 SET ASSIGNED=+$$GET1^DIQ(2006.8,WSIEN_",",FIELD,"I","","")
+19 QUIT
End DoDot:2
if ASSIGNED
QUIT
+20 IF 'ASSIGNED
SET FDA(2006.8,UAT_",",FIELD)="1"
+21 QUIT
End DoDot:1
+22 IF $DATA(FDA)
DO FILE^DIE("","FDA","FDAIEN")
+23 KILL FDA,FDAIEN
+24 QUIT RESULT
CUAT(PLACE) ;
+1 NEW CUATFDA
+2 SET CUATFDA(10,2006.8,"+1,",.01)="UAT"
+3 SET CUATFDA(10,2006.8,"+1,",.04)=PLACE
+4 SET CUATFDA(10,2006.8,"+1,",50)="Unassigned Tasks"
+5 DO UPDATE^DIE("","CUATFDA(10)","FDAIEN")
+6 KILL CUATFDA
+7 QUIT
FINDC(RESULT,FNUM,IENS,FLAG,FNDVALUE,XREF,SCREEN) ; [MAGQ FINDC] Find with Compound Index - uses key field lookup
+1 ; function Find1(FNum,IENS,Flag,FndValue,XREF,Screen:string;silent:boolean): string;
+2 NEW VALUE,INDEX
+3 FOR INDEX=1:1:$LENGTH(FNDVALUE,U)
SET VALUE(INDEX)=$PIECE(FNDVALUE,U,INDEX)
+4 SET RESULT=$$FIND1^DIC(FNUM,IENS,FLAG,.VALUE,XREF,SCREEN,"FNDERR")
+5 KILL FNDERR
+6 QUIT RESULT
CRG(PL,RG) ; Count RAID groups by place
+1 NEW CNT,I,J,NODE,NV
+2 SET I=RG
SET CNT=0
SET NV=""
+3 FOR
SET I=$ORDER(^MAG(2005.2,"B",I))
if I=""
QUIT
if ($EXTRACT(I,1,$LENGTH(RG))'[RG)
QUIT
Begin DoDot:1
+4 SET J=$ORDER(^MAG(2005.2,"B",I,""))
if 'J
QUIT
SET NODE=$GET(^MAG(2005.2,J,0))
Begin DoDot:2
+5 ; Screen on Place
if $PIECE(NODE,"^",10)'=PL
QUIT
+6 SET CNT=CNT+1
+7 if '$DATA(^MAG(2005.2,"B",(RG_CNT)))
SET NV=(RG_CNT)
+8 QUIT
End DoDot:2
if NV'=""
QUIT
+9 QUIT
End DoDot:1
+10 if NV=""
SET NV=RG_(CNT+1)
+11 QUIT NV
ADDRG(RESULT,CNT,PLACE) ; Add Raid Groups to the Network Location file
+1 ; [MAGQ ADD RAID GROUP]
+2 NEW PL,I,VALUE,NMSP,LRG,X
+3 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+4 SET PL=$GET(PLACE)
+5 if PL=""
SET PL=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
if 'PL
QUIT
Begin DoDot:1
+6 SET NMSP=$PIECE($GET(^MAG(2006.1,PL,0)),U,2)
+7 FOR I=1:1:CNT
Begin DoDot:2
+8 SET VALUE=$$CRG(PL,"RG-"_NMSP)
+9 ; Do not create duplicates
if $DATA(^MAG(2005.2,"D",PL,VALUE))
QUIT
+10 SET MAGFDA(2005.2,"+1,",.01)=VALUE
+11 ;Place
SET MAGFDA(2005.2,"+1,",.04)=PL
+12 ;READ-only
SET MAGFDA(2005.2,"+1,",5)="0"
+13 ;"RAID-GROUP"
SET MAGFDA(2005.2,"+1,",6)="GRP"
+14 DO UPDATE^DIE("U","MAGFDA","MAGIEN","MAGERR")
+15 IF $DATA(DIERR)
WRITE !,"Error updating the Network Location file: "_MAGERR("DIERR",1,"TEXT",1)
+16 KILL MAGFDA,DIERR,MAGIEN,MAGFDA,MAGERR
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 SET RESULT="1"
+20 QUIT
+21 ;
CAS ; Remove Acquisition Session file entries
+1 ; Remove entries in 2006.041 - ACQUISITION SESSION FILE
+2 ; Find COMPLETE import series and reduce to final outcome entry, keep for unique TrackingID ?
+3 ; Next remove IMPORT QUEUE entry if Complete
+4 ;Remove old queue entries from 2006.034 with no 2006.041 complement
+5 NEW DA,DIK,IEN,TRKID,IMPORTQ,ZNODE,STATUS,SIEN
+6 SET IEN="A"
+7 FOR
SET IEN=$ORDER(^MAG(2006.041,IEN),-1)
if 'IEN
QUIT
Begin DoDot:1
+8 SET ZNODE=$GET(^MAG(2006.041,IEN,0))
+9 SET IMPORTQ=$PIECE(ZNODE,U,1)
SET TRKID=$PIECE(ZNODE,U,2)
SET STATUS=$PIECE(ZNODE,U,5)
+10 IF TRKID=""
SET DIK="^MAG(2006.041,"
SET DA=IEN
DO ^DIK
KILL DIK,DA
QUIT
+11 IF $DATA(^MAG(2006.041,"C",TRKID))
Begin DoDot:2
+12 ; skip latest entry, remove preliminary status entries
+13 SET SIEN="A"
SET SIEN=$ORDER(^MAG(2006.041,"C",TRKID,SIEN),-1)
+14 IF $$UPPER^MAGQE4($GET(^MAG(2006.041,IEN,0)))["COMPLETE"
Begin DoDot:3
+15 ; Remove IMPORT QUEUE entry if Complete
+16 IF $DATA(^MAG(2006.034,IMPORTQ,0))
Begin DoDot:4
+17 SET DIK="^MAG(2006.034,"
SET DA=IMPORTQ
+18 DO ^DIK
KILL DIK,DA
+19 ; Remove Queue Record, if it exists to eliminate dangling pointer
+20 IF $DATA(^MAGQUEUE(2006.03,IMPORTQ,0))
DO DQUE^MAGQBUT2(IMPORTQ)
+21 QUIT
End DoDot:4
+22 ; Remove log activity if Complete
+23 FOR
SET SIEN=$ORDER(^MAG(2006.041,"C",TRKID,SIEN),-1)
if 'SIEN
QUIT
Begin DoDot:4
+24 SET DIK="^MAG(2006.041,"
SET DA=SIEN
+25 DO ^DIK
KILL DIK,DA
+26 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+27 QUIT
End DoDot:1
+28 ; Remove old queue entries from 2006.034 with no 2006.041 complement
+29 SET IEN=""
FOR
SET IEN=$ORDER(^MAG(2006.034,IEN))
if 'IEN
QUIT
if '$DATA(^MAG(2006.041,"B",IEN))
Begin DoDot:1
+30 SET DIK="^MAG(2006.034,"
SET DA=IEN
+31 DO ^DIK
+32 KILL DIK,DA
+33 ; Remove Queue Record, if it exists to eliminate dangling pointer
+34 IF $DATA(^MAGQUEUE(2006.03,IMPORTQ,0))
DO DQUE^MAGQBUT2(IMPORTQ)
+35 QUIT
End DoDot:1
+36 QUIT
+37 ;
FTYPE(RESULT) ;
+1 ; RPC[MAGQ FTYPE]
+2 NEW MAX,INDX,PLACE,X
+3 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+4 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+5 SET U="^"
SET MAX=$PIECE(^MAG(2006.1,PLACE,2,0),U,4)
SET INDX=0
+6 if +MAX<1
QUIT
+7 FOR
SET INDX=$ORDER(^MAG(2006.1,PLACE,2,INDX))
if INDX'?1N.N
QUIT
Begin DoDot:1
+8 SET RESULT(INDX-1)=$GET(^MAG(2006.1,PLACE,2,INDX,0))
+9 QUIT
End DoDot:1
if INDX=MAX
QUIT
+10 QUIT
