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

MAGQBUT5.m

Go to the documentation of this file.
  1. 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
  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. AI(RESULT) ; List of Associated Institution candidates;
  1. N INDEX,INST,J,K,L,OUT
  1. S K=0
  1. S RESULT(K)=""
  1. S K=K+1
  1. D LIST^DIC(40.8,,".01;.07I",,,,,,,,"OUT")
  1. S RESULT(K)="The following Medical Center Divisions have Imaging Site Parameters defined on ",K=K+1
  1. S RESULT(K)="your system:" D
  1. . S INDEX=0,K=K+1 F S INDEX=INDEX+1 Q:'$D(OUT("DILIST","ID",INDEX)) D
  1. . . 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
  1. . . . S RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST,K=K+1 Q
  1. . . Q
  1. . Q
  1. I INDEX=1 S RESULT(K)="None",K=K+1
  1. S RESULT(K)="The following Medical Center Divisions have 'Associated Institutions' defined on ",K=K+1
  1. S RESULT(K)="your system:" D
  1. . S INDEX="",K=K+1,L=K F S INDEX=$O(^MAG(2006.1,"B",INDEX)) Q:'INDEX D
  1. . . Q:$P($G(^MAG(2006.1,$O(^MAG(2006.1,"B",INDEX,"")),0)),U)=INDEX
  1. . . S RESULT(K)=$$GET1^DIQ(4,INDEX,.01,"E")_" "_INDEX,K=K+1 Q ;IA fix
  1. . Q
  1. I K=L S RESULT(K)="None",K=K+1
  1. S RESULT(K)="The following Medical Center Divisions have NO Imaging parameter affiliations ",K=K+1
  1. S RESULT(K)="defined on your system:" D
  1. . S INDEX=0,K=K+1,L=K F S INDEX=INDEX+1 Q:'$D(OUT("DILIST","ID",INDEX)) D
  1. . . S INST=OUT("DILIST","ID",INDEX,.07) Q:$D(^MAG(2006.1,"B",INST)) D
  1. . . . S RESULT(K)=OUT("DILIST","ID",INDEX,.01)_" "_INST,K=K+1 Q
  1. . . Q
  1. . Q
  1. I K=L S RESULT(K)="None",K=K+1
  1. K OUT
  1. D CLEAN^DILF
  1. Q
  1. PLNM(PLACE) ; Returns the Institution name of the Place
  1. N INST
  1. Q:'PLACE " "
  1. S INST=$P($G(^MAG(2006.1,PLACE,0)),U)
  1. Q $$GET1^DIQ(4,INST,.01,"E") ;IA fix
  1. TPMESS(PLACE) ;Trigger a purge message
  1. N Y,LOC,CNT,XMSUB
  1. S Y=$$FMTE^XLFDT($$NOW^XLFDT)
  1. S LOC=$$KSP^XUPARAM("WHERE")
  1. S CNT=1,^TMP($J,"MAGQ",CNT)="SITE: "_LOC
  1. S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="DATE: "_Y_" "_$G(^XMB("TIMEZONE"))
  1. S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="SENDER: "_$$PLNM^MAGQBUT5(PLACE)_" Imaging Background Processor"
  1. S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="An automatic purge event has been initiated"
  1. S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="in order to maintain adequate image storage"
  1. S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="no operator intervention is required."
  1. S XMSUB="VistA Imaging BP Queue processor - Autopurge"
  1. D MAILSHR^MAGQBUT1(PLACE,"AUTOPURGE",XMSUB)
  1. D UDMI^MAGQBUT5("VistA Imaging BP Queue processor - Autopurge",PLACE)
  1. Q
  1. ADDMG(SUB,XMY,PLACE) ; Provide an array of Message Recipients for Message Subject
  1. N INDEX,IEN,GROUP,NAME,J,K,L,KEY
  1. S SUB=$TR(SUB," ","_")
  1. S XMY("G.MAG SERVER")=""
  1. S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D
  1. . Q:SUB'[INDEX
  1. . S J=$O(^MAG(2006.1,PLACE,6,"B",INDEX,"")) ; first add Mail Groups
  1. . S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,1,"B",K)) Q:'K D
  1. . . Q:'$$GOTLOCAL^XMXAPIG(K,"")
  1. . . S NAME="G."_$$GET1^DIQ(3.8,K,.01,"E")
  1. . . S XMY(NAME)=""
  1. . . Q
  1. . I +$P($G(^MAG(2006.1,PLACE,6,J,3,0)),U,4) D ; next add Mail Message members
  1. . . S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,3,"B",K)) Q:'K D
  1. . . . Q:'+$$ACTIVE^XUSER(K)
  1. . . . S XMY(K)=""
  1. . . . Q
  1. . . Q
  1. . I +$P($G(^MAG(2006.1,PLACE,6,J,4,0)),U,4) D ; next add designated Security Key holders
  1. . . S K=0 F S K=$O(^MAG(2006.1,PLACE,6,J,4,"B",K)) Q:'K D
  1. . . . S KEY=$P($G(^DIC(19.1,K,0)),U,1) Q:KEY=""
  1. . . . S L="" F S L=$O(^XUSEC(KEY,L)) Q:'L D
  1. . . . . Q:'+$$ACTIVE^XUSER(L)
  1. . . . . S XMY(L)=""
  1. . . . . Q
  1. . . . Q
  1. . . Q
  1. . Q
  1. Q
  1. GETMI(SUB,PLACE) ; Provide the message interval assigned to this message type
  1. N INDEX,RETURN,IEN,IENS
  1. S RETURN=0
  1. S SUB=$TR(SUB," ","_")
  1. S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D
  1. . Q:SUB'[INDEX
  1. . S IEN=$O(^MAG(2006.1,PLACE,6,"B",INDEX,""))
  1. . S IENS=IEN_","_PLACE_","
  1. . S RETURN=$$GET1^DIQ(2006.166,IENS,1)_U_$$GET1^DIQ(2006.166,IENS,3,"I")
  1. Q $S('RETURN:0,1:RETURN)
  1. ;
  1. UDMI(SUB,PLACE) ; Update DATE OF LAST MESSAGE
  1. N INDEX,RETURN,IEN
  1. S RETURN=0
  1. S SUB=$TR(SUB," ","_")
  1. S INDEX="" F S INDEX=$O(^MAG(2006.1,PLACE,6,"B",INDEX)) Q:INDEX="" D Q:RETURN
  1. . Q:SUB'[INDEX
  1. . S IEN=$O(^MAG(2006.1,PLACE,6,"B",INDEX,""))
  1. . S $P(^MAG(2006.1,PLACE,6,IEN,2),U,1)=$$NOW^XLFDT
  1. . S RETURN="1"
  1. . Q
  1. Q RETURN
  1. ;
  1. RMRPC(NAME) ; Removing an RPC in order to revise
  1. N MW,RPC,MWE,DIERR,DA,DIK
  1. S MW=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","")
  1. D CLEAN^DILF
  1. S RPC=$$FIND1^DIC(8994,"","X",NAME,"","","")
  1. D CLEAN^DILF
  1. Q:'RPC
  1. I MW D
  1. . S MWE=$$FIND1^DIC(19.05,","_MW_",","X",NAME,"","","")
  1. . D CLEAN^DILF
  1. . Q:'MWE
  1. . S DA=MWE,DA(1)=MW,DIK="^DIC(19,"_DA(1)_",""RPC"","
  1. . D ^DIK
  1. . K DA,DIK
  1. . Q
  1. S DA=RPC,DIK="^XWB(8994,"
  1. D ^DIK
  1. K DA,DIK
  1. Q
  1. MOVE(RESULT,FNAM) ;[MAGQ MOVE]
  1. N IEN,FTYPE,NMSPC,SITEID,EXT,ALT,J,X
  1. S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S NMSPC=$TR($P(FNAM,"."),"0123456789","")
  1. S SITEID=$$INIS^MAGQBPG2($$PLACE^MAGBAPI(+DUZ(2)))
  1. I SITEID'[(","_NMSPC_",") D Q
  1. . S RESULT="0^Invalid Imaging Namespace"
  1. S IEN=$O(^MAG(2005,"F",$P(FNAM,"."),""))
  1. I IEN'?1N.N!('$D(^MAG(2005,IEN,0))) D Q
  1. . S RESULT="0^No matching 2005 entry"
  1. S EXT=$P(FNAM,".",2)
  1. I $P($G(^MAG(2005,IEN,0)),U,2)[FNAM S RESULT=IEN_U_"FULL"
  1. E D
  1. . S FTYPE=$$FTYPE^MAGQBPRG(EXT,IEN)
  1. . I FTYPE="FULL" D Q
  1. . . D FTYPE(.ALT)
  1. . . S J=""
  1. . . F S J=$O(ALT(J)) Q:J'?1N.N S:ALT(J)[EXT FTYPE="ALT"
  1. . . I FTYPE["ALT" S RESULT=IEN_U_FTYPE
  1. . . E S RESULT="0^Invalid File Extension"
  1. . E S RESULT=IEN_U_FTYPE
  1. Q
  1. QRNGE(RESULT,QUEUE,PROC,START,STOP,PLACE) ;
  1. ;[MAGQ QRNGE] Requeue/Dequeue a Range of Queues
  1. N XX,CNT,TMP,QP,X,PART
  1. S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S CNT=0,TMP=""
  1. S PLACE=$P($G(^MAGQUEUE(2006.03,START,0)),U,12)
  1. Q:'PLACE
  1. S XX=+$O(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,START),-1)
  1. F S XX=$O(^MAGQUEUE(2006.03,"C",PLACE,QUEUE,XX)) Q:'XX Q:XX>(STOP) D
  1. . S CNT=CNT+1
  1. . D:PROC="DEL"
  1. . . S QP=$O(^MAGQUEUE(2006.031,"C",PLACE,QUEUE,""))
  1. . . S PART=$S(QP:$P(^MAGQUEUE(2006.031,QP,0),U,2),1:"")
  1. . . I XX>PART D ADD^MAGBAPI(-1,QUEUE,PLACE)
  1. . . D DQUE^MAGQBUT2(XX)
  1. . . Q
  1. . D:PROC="REQ" REQUE^MAGQBTM(.TMP,XX)
  1. . Q
  1. S RESULT=CNT
  1. Q
  1. 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)
  1. N WSIEN,TASKS,WS,UAT,NODE,PIECE,FIELD,ASSIGNED,I
  1. ; Remove and re-build unassigned task entry
  1. S I=0 F S I=$O(^MAG(2006.8,I)) Q:'I S NODE=$G(^MAG(2006.8,I,0)) D
  1. . Q:$P(NODE,U)'="UAT"
  1. . Q:$P(NODE,U,2)'=PLACE
  1. . S DIK="^MAG(2006.8,",DA=I
  1. . D ^DIK
  1. . K DIK
  1. . Q
  1. S RESULT="1"
  1. D:'$D(^MAG(2006.8,"C",PLACE,"Unassigned Tasks")) CUAT(PLACE)
  1. S UAT=$O(^MAG(2006.8,"C",PLACE,"Unassigned Tasks",""))
  1. F FIELD=3,4,12,13,14,15,16,17,20 D
  1. . S (ASSIGNED,WS)=""
  1. . F S WS=$O(^MAG(2006.8,"C",PLACE,WS)) Q:WS="" D Q:ASSIGNED
  1. . . S WSIEN=$O(^MAG(2006.8,"C",PLACE,WS,""))
  1. . . S ASSIGNED=+$$GET1^DIQ(2006.8,WSIEN_",",FIELD,"I","","")
  1. . . Q
  1. . I 'ASSIGNED S FDA(2006.8,UAT_",",FIELD)="1"
  1. . Q
  1. I $D(FDA) D FILE^DIE("","FDA","FDAIEN")
  1. K FDA,FDAIEN
  1. Q RESULT
  1. CUAT(PLACE) ;
  1. N CUATFDA
  1. S CUATFDA(10,2006.8,"+1,",.01)="UAT"
  1. S CUATFDA(10,2006.8,"+1,",.04)=PLACE
  1. S CUATFDA(10,2006.8,"+1,",50)="Unassigned Tasks"
  1. D UPDATE^DIE("","CUATFDA(10)","FDAIEN")
  1. K CUATFDA
  1. Q
  1. 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;
  1. N VALUE,INDEX
  1. F INDEX=1:1:$L(FNDVALUE,U) S VALUE(INDEX)=$P(FNDVALUE,U,INDEX)
  1. S RESULT=$$FIND1^DIC(FNUM,IENS,FLAG,.VALUE,XREF,SCREEN,"FNDERR")
  1. K FNDERR
  1. Q RESULT
  1. CRG(PL,RG) ; Count RAID groups by place
  1. N CNT,I,J,NODE,NV
  1. S I=RG,CNT=0,NV=""
  1. F S I=$O(^MAG(2005.2,"B",I)) Q:I="" Q:($E(I,1,$L(RG))'[RG) D
  1. . S J=$O(^MAG(2005.2,"B",I,"")) Q:'J S NODE=$G(^MAG(2005.2,J,0)) D Q:NV'=""
  1. . . Q:$P(NODE,"^",10)'=PL ; Screen on Place
  1. . . S CNT=CNT+1
  1. . . S:'$D(^MAG(2005.2,"B",(RG_CNT))) NV=(RG_CNT)
  1. . . Q
  1. . Q
  1. S:NV="" NV=RG_(CNT+1)
  1. Q NV
  1. ADDRG(RESULT,CNT,PLACE) ; Add Raid Groups to the Network Location file
  1. ; [MAGQ ADD RAID GROUP]
  1. N PL,I,VALUE,NMSP,LRG,X
  1. S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S PL=$G(PLACE)
  1. S:PL="" PL=$$PLACE^MAGBAPI(+$G(DUZ(2))) Q:'PL D
  1. . S NMSP=$P($G(^MAG(2006.1,PL,0)),U,2)
  1. . F I=1:1:CNT D
  1. . . S VALUE=$$CRG(PL,"RG-"_NMSP)
  1. . . Q:$D(^MAG(2005.2,"D",PL,VALUE)) ; Do not create duplicates
  1. . . S MAGFDA(2005.2,"+1,",.01)=VALUE
  1. . . S MAGFDA(2005.2,"+1,",.04)=PL ;Place
  1. . . S MAGFDA(2005.2,"+1,",5)="0" ;READ-only
  1. . . S MAGFDA(2005.2,"+1,",6)="GRP" ;"RAID-GROUP"
  1. . . D UPDATE^DIE("U","MAGFDA","MAGIEN","MAGERR")
  1. . . I $D(DIERR) W !,"Error updating the Network Location file: "_MAGERR("DIERR",1,"TEXT",1)
  1. . . K MAGFDA,DIERR,MAGIEN,MAGFDA,MAGERR
  1. . . Q
  1. . Q
  1. S RESULT="1"
  1. Q
  1. ;
  1. CAS ; Remove Acquisition Session file entries
  1. ; Remove entries in 2006.041 - ACQUISITION SESSION FILE
  1. ; Find COMPLETE import series and reduce to final outcome entry, keep for unique TrackingID ?
  1. ; Next remove IMPORT QUEUE entry if Complete
  1. ;Remove old queue entries from 2006.034 with no 2006.041 complement
  1. N DA,DIK,IEN,TRKID,IMPORTQ,ZNODE,STATUS,SIEN
  1. S IEN="A"
  1. F S IEN=$O(^MAG(2006.041,IEN),-1) Q:'IEN D
  1. . S ZNODE=$G(^MAG(2006.041,IEN,0))
  1. . S IMPORTQ=$P(ZNODE,U,1),TRKID=$P(ZNODE,U,2),STATUS=$P(ZNODE,U,5)
  1. . I TRKID="" S DIK="^MAG(2006.041,",DA=IEN D ^DIK K DIK,DA Q
  1. . I $D(^MAG(2006.041,"C",TRKID)) D
  1. . . ; skip latest entry, remove preliminary status entries
  1. . . S SIEN="A",SIEN=$O(^MAG(2006.041,"C",TRKID,SIEN),-1)
  1. . . I $$UPPER^MAGQE4($G(^MAG(2006.041,IEN,0)))["COMPLETE" D
  1. . . . ; Remove IMPORT QUEUE entry if Complete
  1. . . . I $D(^MAG(2006.034,IMPORTQ,0)) D
  1. . . . . S DIK="^MAG(2006.034,",DA=IMPORTQ
  1. . . . . D ^DIK K DIK,DA
  1. . . . . ; Remove Queue Record, if it exists to eliminate dangling pointer
  1. . . . . I $D(^MAGQUEUE(2006.03,IMPORTQ,0)) D DQUE^MAGQBUT2(IMPORTQ)
  1. . . . . Q
  1. . . . ; Remove log activity if Complete
  1. . . . F S SIEN=$O(^MAG(2006.041,"C",TRKID,SIEN),-1) Q:'SIEN D
  1. . . . . S DIK="^MAG(2006.041,",DA=SIEN
  1. . . . . D ^DIK K DIK,DA
  1. . . . . Q
  1. . Q
  1. ; Remove old queue entries from 2006.034 with no 2006.041 complement
  1. S IEN="" F S IEN=$O(^MAG(2006.034,IEN)) Q:'IEN D:'$D(^MAG(2006.041,"B",IEN))
  1. . S DIK="^MAG(2006.034,",DA=IEN
  1. . D ^DIK
  1. . K DIK,DA
  1. . ; Remove Queue Record, if it exists to eliminate dangling pointer
  1. . I $D(^MAGQUEUE(2006.03,IMPORTQ,0)) D DQUE^MAGQBUT2(IMPORTQ)
  1. . Q
  1. Q
  1. ;
  1. FTYPE(RESULT) ;
  1. ; RPC[MAGQ FTYPE]
  1. N MAX,INDX,PLACE,X
  1. S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
  1. S U="^",MAX=$P(^MAG(2006.1,PLACE,2,0),U,4),INDX=0
  1. Q:+MAX<1
  1. F S INDX=$O(^MAG(2006.1,PLACE,2,INDX)) Q:INDX'?1N.N D Q:INDX=MAX
  1. . S RESULT(INDX-1)=$G(^MAG(2006.1,PLACE,2,INDX,0))
  1. . Q
  1. Q