- 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 Feb 18, 2025@23:34:26 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