MAGQBUT1 ;WOIFO/RP/PTW - Utilities for Background ; 23 May 2013 10:50 AM
;;3.0;IMAGING;**7,8,20,81,39,135**;Mar 19, 2002;Build 5238;Jul 17, 2013
;; 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
UBPW(WS,ASSIGN) ; screen for duplicate assignments
N IEN,PLACE,PIECE,WSIEN,VALUE,DUP
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S VALUE(1)=PLACE,VALUE(2)=WS
S WSIEN=$$FIND1^DIC(2006.8,"","QX",.VALUE,"D","","")
S PIECE=$P(ASSIGN,";",2)
S (DUP,IEN)=0
;IF NOT ASSIGNED THEN QUIT
I '$P($G(^MAG(2006.8,WSIEN,0)),U,PIECE) K VALUE Q DUP
F S IEN=$O(^MAG(2006.8,IEN)) Q:'IEN D Q:DUP
. S ZNODE=^MAG(2006.8,IEN,0)
. Q:'$P(ZNODE,U,12) ; not a BP
. Q:$P(ZNODE,U,2)'=PLACE
. Q:$P(ZNODE,U)=WS
. S:+$P(ZNODE,U,PIECE) DUP=1
. Q
Q DUP
BPPS(INPUT,WS,PROCESS) ;INPUT TRANSFORM FOR FILE 2006.8
N IEN,FND,WSNAME,WSNAME2,ZNODE,PIECE,MAGX,MAGY,PLACE
S U="^"
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
Q:'(+$P($G(^MAG(2006.8,WS,0)),U,12)) 0 ;NOT A BACKGROUND PROCESSOR
Q:'INPUT 1 ; Always allow unassigned
S WSNAME=$P($G(^MAG(2006.8,WS,0)),U) ;Workstation Name
Q:$L(WSNAME)<3 0 ;BP WS NOT PROPERLY INSTALLED
Q:$O(^MAG(2006.8,"C",PLACE,WSNAME,""))'?1N.N 1
S PIECE=$P($$GET1^DID(2006.8,PROCESS,"","GLOBAL SUBSCRIPT LOCATION"),";",2)
S IEN=0,WSNAME2="",FND=0
F S WSNAME2=$O(^MAG(2006.8,"C",PLACE,WSNAME2)) Q:WSNAME2="" D Q:FND
. Q:WSNAME2=WSNAME
. S IEN=$O(^MAG(2006.8,"C",PLACE,WSNAME2,"")) Q:IEN'?1N.N
. S ZNODE=$G(^MAG(2006.8,IEN,0))
. Q:$P(ZNODE,"^",12)'="1"
. S FND=$P(ZNODE,"^",PIECE)="1"
. Q
Q $S(FND="1":0,1:1)
RSQUE(RESULT,IEN,QUEUE) ;[MAGQB RSQUE]
N PTR,PLACE
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S PTR=$O(^MAGQUEUE(2006.031,"C",PLACE,QUEUE,""))
I $P(^MAGQUEUE(2006.031,PTR,0),"^")=QUEUE D
. S $P(^MAGQUEUE(2006.031,PTR,0),"^",2)=IEN
. Q
Q
ICCL(SRVRCNT,NMESS,PLACE) ;UPDATE IMAGING DISTRIBUTION
N Y,LOC,INDEX,CNT,IEN,ARRAY,SUB1,SUB2,NAME
S Y=$$FMTE^XLFDT($$NOW^XLFDT)
S LOC=$$KSP^XUPARAM("WHERE")
S CNT=1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="SITE: "_LOC
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="DATE: "_Y_" "_$G(^XMB("TIMEZONE"))
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="SENDER: "_$$PLNM^MAGQBUT5(PLACE)_" Imaging Background Processor"
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="Total Cache Free: "_$P(SRVRCNT,U,2)_" megabytes"
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="Total Cache Available: "_$P(SRVRCNT,U,3)_" megabytes"
I $P(SRVRCNT,U,4) S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="An Automatic Purge process has been Activated. "
E S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is NOT configured. "
I $P(SRVRCNT,U,5)]"" S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is assigned to: "_$P(SRVRCNT,U,5)
E S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is NOT assigned to a BP server. "
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="The "_$P(SRVRCNT,U)_" Imaging cache servers will"
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="require operator intervention to ensure continued"
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="availability. The following MAG SERVER members"
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="are being notified: "
S INDEX=0,IEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
Q:IEN'?1N.N
D GETS^DIQ(3.8,IEN_",","2*;11*;12*","","ARRAY")
S (SUB1,SUB2)=""
F S SUB1=$O(ARRAY(SUB1)) Q:SUB1="" D
. F S SUB2=$O(ARRAY(SUB1,SUB2)) Q:SUB2="" D
. . S NAME=$G(ARRAY(SUB1,SUB2,".01")) D:NAME'=""
. . . S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",8+CNT)=NAME
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)="The next notifications will occur in: "
S CNT=CNT+1,^TMP($J,"MAGQ",PLACE,"BP",CNT)=NMESS
D MAILSHR(PLACE,"BP","Image Cache Critically Low at "_LOC)
S $P(^MAG(2006.1,$$PLACE^MAGBAPI($G(DUZ(2))),3),"^",11)=$$NOW^XLFDT
D UDMI^MAGQBUT5("Image Cache Critically Low at ",PLACE)
K ARRAY
Q
MAILSHR(PLACE,APP,XMSUB) ;Shared Mail server code
N XMY,XMTEXT,XMID,XMZ
S XMTEXT="^TMP($J,""MAGQ"",PLACE,APP)"
S:$G(DUZ) XMY(DUZ)=""
D:$$PROD^XUPROD("1") ADDMG^MAGQBUT5(XMSUB,.XMY,PLACE)
S:$G(MAGDUZ) XMY(MAGDUZ)=""
S XMID=$G(DUZ) S:'XMID XMID=.5
S XMY(XMID)=""
N L1,L2,L3
S L2=$L($P(XMSUB,"^",2))
S L3=60-L2
S L1=$L($P(XMSUB,"^"))
I L2=0 S XMSUB=$E(XMSUB,1,60)
E S XMSUB=$E($P(XMSUB,"^"),1,L3-1)_"^"_$P(XMSUB,"^",2)
D SENDMSG^XMXAPI(XMID,XMSUB,XMTEXT,.XMY,,.XMZ,)
K ^TMP($J,"MAGQ",PLACE,APP)
I $G(XMERR) M XMERR=^TMP("XMERR",$J) K XMERR
Q
ALLSERV(RESULT,GRP) ; BP Queue Processor
; RPC[MAGQ ALL SERVER] used for ServerSize update/display function - reports network resources
; Returns OnLine, network addressed, non-router, place related Magnetic shares
; it returns the share designated as the current Write location in the (0) indice
; it does not screen on READ-ONLY, and the list is group specific
; the function could be replaced by a fileman call from the GUI
; PHYSICAL REFERENCE^CWL or ien^FREE SPACE^TOTAL SPACE^NAME^GROUP^TYPE
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
N INDX,DATA,CNT,SHARE,CWL,VALUE,TMP,PLACE,CWG ;CWL=CURRENT WRITE LOCATION CWG=CURRENT WRITE GROUP
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S CWG=$S($G(GRP)["ALL":"",1:$$CWG^MAGBAPI(PLACE))
D:CWG CWGIC(CWG) ;Remove all members that do not reference this group
S CWL=$$CWL^MAGBAPI(PLACE)
; I CWL D ;First report Current Write Location data
; . S DATA=$G(^MAG(2005.2,CWL,0))
; . S SHARE=$P(DATA,U,2)
; . S RESULT(0)=SHARE_U_CWL_U_+$P(DATA,U,5)_U_+$P(DATA,U,3)_U_$P(DATA,U)
; . S RESULT(0)=RESULT(0)_U_$S($L($$GET1^DIQ(2005.2,CWL,31,"E","","")):$$GET1^DIQ(2005.2,CWL,31,"E","",""),1:"")
; . S RESULT(0)=RESULT(0)_U_$$GET1^DIQ(2005.2,CWL,6,"I","","")
; . Q
; E S RESULT(0)="-1^The Current Write Location (CWL) is not currently set."
S INDX=0,U="^",CNT=1
K ^TMP("MAGQAS")
F S INDX=$O(^MAG(2005.2,INDX)) Q:INDX'?1N.N D
. S DATA=$G(^MAG(2005.2,INDX,0))
. Q:$P(DATA,U,6,7)'["1^MAG"
. Q:$P(DATA,U,2)[":"
. Q:($P(DATA,U,10)'=PLACE)
. Q:$P(DATA,U,9)="1" ;ROUTING SHARE
. S SHARE=$P(DATA,U,2)
. Q:$E(SHARE,1,2)'="\\"
. I $E(SHARE,$L(SHARE))="\" S SHARE=$E(SHARE,1,$L(SHARE)-1)
. S TMP(SHARE)=""
. I CWG,'$$GMEM(CWG,INDX) Q ;screen on Current Write Group also validate group member reference
. S VALUE=SHARE_U_INDX_U_+$P(DATA,U,5)_U_+$P(DATA,U,3)_U_$P(DATA,U)
. S VALUE=VALUE_U_$S($L($$GET1^DIQ(2005.2,INDX,31,"E","","")):$$GET1^DIQ(2005.2,INDX,31,"E","",""),1:"")
. S VALUE=VALUE_U_$$GET1^DIQ(2005.2,INDX,6,"E","","")
. I INDX=CWL D Q ;ELSE CONTINUE
. . S RESULT(0)=VALUE_U_$G(^TMP("MAGQ","WSUD"))
. . S ^TMP("MAGQAS",0)=VALUE ;1ST SHARE=CWL
. . Q
. S RESULT(CNT)=VALUE,CNT=CNT+1
. S ^TMP("MAGQAS",CNT-1)=VALUE
. Q
Q
ALLSHR(RESULT,TYPE) ; RPC[MAGQBP ALL SHARES] - Used by BP Purge
; screens off-line,read-only,routing share,non-mag,non-place,next group,current group,specific group(s)
N TMP,INDX,DATA,CNT,SHARE,CWL,VALUE,PLACE,NG,GRP ;CWL=CURRENT WRITE LOCATION
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S (CNT,INDX)=0,U="^" S:'$D(TYPE) TYPE="ALL" ;calling routine will define TYPE, or set as ALL by default (no screen).
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S CWL=$$CWL^MAGBAPI(PLACE)
S GRP=$$GRP^MAGQBUT(PLACE)
S NG=$$NXTGP^MAGQBUT(PLACE,GRP,"1") ; Next Purge capable group
F S INDX=$O(^MAG(2005.2,INDX)) Q:INDX'?1N.N D
. S DATA=$G(^MAG(2005.2,INDX,0))
. Q:$P(DATA,U,6,7)'["1^MAG"
. Q:$P(DATA,U,9)="1" ;ROUTING SHARE
. Q:$P(DATA,U,2)[":"
. Q:($P(DATA,U,10)'=PLACE)
. Q:($P($G(^MAG(2005.2,INDX,1)),U,6)="1") ;Read Only
. Q:(("^AUTO^NRG^"[("^"_TYPE_"^"))&($P($G(^MAG(2005.2,INDX,1)),U,8)'=NG)) ;NOT a member of the Next RAID Group
. Q:(("^CRG^"[("^"_TYPE_"^"))&($P($G(^MAG(2005.2,INDX,1)),U,8)'=GRP)) ;NOT a member of the Current RAID Group
. Q:((TYPE?1N.N)&($P($G(^MAG(2005.2,INDX,1)),U,8)'=TYPE)) ;NOT a member of the Specified RAID Group
. S SHARE=$$UPPER^MAGQE4($P(DATA,U,2))
. Q:$E(SHARE,1,2)'="\\"
. I $E(SHARE,$L(SHARE))="\" S SHARE=$E(SHARE,1,$L(SHARE)-1)
. Q:$D(TMP(SHARE))
. S TMP(SHARE)=""
. Q
S INDX=""
F S INDX=$O(TMP(INDX)) Q:INDX="" D
. S RESULT(CNT)=INDX,CNT=CNT+1
. Q
K TMP
Q
FSUPDT(RESULT,IEN,SPACE,SIZE) ; File Server Update
; RPC[MAGQ FS UPDATE]
; Space is field #2 (Total Space)and is actually share size
; Size is field #4 (Free Space)
N NODE,X,Y,INDEX,SHNAME,PLACE
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
K ^TMP("MAGQ","WSUD")
S ^TMP("MAGQ","WSUD",IEN)=$$FMTE^XLFDT($$NOW^XLFDT)_U_IEN_U_SPACE_U_SIZE
I $G(^MAG(2005.2,IEN,0))="" S RESULT="-1^No Network Location Entry" Q
S SHNAME=$P($G(^MAG(2005.2,IEN,0)),U,2)
D FSW(IEN,SPACE,SIZE) ;The next is to update redundant shares and should not be necessary
S INDEX=0 F S INDEX=$O(^MAG(2005.2,"AC",SHNAME,INDEX)) Q:'INDEX D
. Q:INDEX=IEN
. D FSW(INDEX,SPACE,SIZE)
. Q
S RESULT="1^Update Complete"
Q
FSW(IX,SP,SZ) ;
S $P(^MAG(2005.2,IX,0),U,3)=+SP,$P(^MAG(2005.2,IX,0),U,5)=+SZ
Q
QUEUER(QUE,FROM,TO) ;
N TYPE,INC,CNT,AR,TMP,PLACE,INST,MAGFILE
I $$GET1^DIQ(200,+$G(DUZ),.01)="" D Q
. W !,"You must have a valid User ID (DUZ) to use this function!"
. Q
I "^JBTOHD^PREFET^ABSTRACT^JUKEBOX^GCC^DELETE^EVAL^"'[QUE D Q
. W !,"Only JBTOHD, PREFET, ABSTRACT, JUKEBOX, DELETE, EVAL & GCC queues are valid!"
. W !,"Input values: ""Queue type"",""From Image IEN"",""To Image IEN"""
S CNT=0,PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))),INST=$$GET1^DIQ(2006.1,PLACE,.01,"I")
F INC=FROM:1:TO D
. I ('$D(^MAG(2005,INC,0))&('$D(^MAG(2005.1,INC,0)))) Q
. I $D(^MAG(2005,INC,0)),$$PLACE^MAGBAPI(+$P($G(^MAG(2005,INC,100)),U,3))'=PLACE Q
. I $D(^MAG(2005.1,INC,0)),$$PLACE^MAGBAPI(+$P($G(^MAG(2005.1,INC,100)),U,3))'=PLACE Q
. I ($P($G(^MAG(2005,INC,0)),"^",2)="")&($P($G(^MAG(2005.1,INC,0)),"^",2)="") Q ;No full filename attribute
. I (+$P($G(^MAG(2005,INC,1,0)),"^",4)>0)!(+$P($G(^MAG(2005.1,INC,1,0)),"^",4)>0) Q ;GROUP PARENT
. I "^DELETE^"[QUE D Q
. . N MAGXX S MAGXX=INC D VSTNOCP^MAGFILEB I $E(MAGFILE,1,2)="-1" W !,"Image # "_INC Q
. . S MAGXX=INC D ABSNOCP^MAGFILEB I $E(MAGFILE,1,2)="-1" W !,"Image # "_INC Q
. . D IMAGEDEL^MAGGTID(.MAGFILE,INC,"","TESTING")
. . Q
. I "^ABSTRACT^"[QUE D Q
. . I $$ABSOK^MAGQBUT1(INC) D MAPI(QUE,INC,.CNT)
. . Q
. I "^JBTOHD^PREFET^"[QUE F TYPE="ABSTRACT","FULL","BIG" D
. . Q:(TYPE="BIG")&('$D(^MAG(2005,INC,"FBIG"))&'$D(^MAG(2005.1,INC,"FBIG")))
. . D MAPI(QUE,INC_"^"_TYPE,.CNT)
. . Q
. E D MAPI(QUE,INC,.CNT) ; JUKEBOX,EVAL,GCC
. Q
Q
MAPI(TYP,PARAM,CNT) ;
N PLACE
S CNT=CNT+1,PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
W !,CNT," TYPE: ",TYP,": ",PARAM_" QUEUE #: ",@("$$"_TYP_"^MAGBAPI(PARAM,PLACE)")
Q
ABSOK(IEN) ; Verify that the Full Image Type is a supported by our ABSTRACT method
N TYPE,FILE,IFT ; Image file type
S FILE=$S($D(^MAG(2005,IEN)):$P($G(^MAG(2005,IEN,0)),U,2),$D(^MAG(2005.1,IEN)):$P($G(^MAG(2005.1,IEN,0)),U,2),1:"")
S TYPE=$P(FILE,".",2)
S IFT=$S($D(^MAG(2005.021,"B",TYPE)):$O(^MAG(2005.021,"B",TYPE,"")),1:"")
I (IFT']"")!($P($G(^MAG(2005.021,IFT,0)),U,5)'="1") D Q 0
. W !,"Abstract not supported IEN/TYPE: "_IEN_"/"_TYPE
Q $P($G(^MAG(2005.021,IFT,0)),U,5)
BPQSL(RESULT,TYPE) ; Called from MAGQUEMAN.PAS and MagSiteParameters.PAS
; RPC[MAGQB QSL]
N STATUS,CNT,IEN,CP,PLACE
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
S STATUS="",CNT=0
F S STATUS=$O(^MAGQUEUE(2006.03,"D",PLACE,TYPE,STATUS)) Q:STATUS="" D
. Q:+STATUS>0
. S IEN=$O(^MAGQUEUE(2006.03,"D",PLACE,TYPE,STATUS,""))
. S CP=$P(^MAGQUEUE(2006.031,$O(^MAGQUEUE(2006.031,"C",PLACE,TYPE,"")),0),"^",2)
. Q:IEN>(CP)
. S CNT=CNT+1,RESULT(CNT)=STATUS
. Q
Q
CWGIC(CWG) ; Current RAID Group integrity check
N VALUE,IEN,MAGFDA,MSG
S VALUE=""
F S VALUE=$O(^MAG(2005.2,CWG,7,"B",VALUE)) Q:'VALUE D:($P($G(^MAG(2005.2,VALUE,1)),U,8)'=CWG)
. S IEN=$O(^MAG(2005.2,CWG,7,"B",VALUE,""))
. S MAGFDA(2005.22,IEN_","_CWG_",",.01)="@"
. D FILE^DIE("","MAGFDA","")
. K MAGFDA
. Q
Q
GMEM(CWG,IEN) ; Update Current RAID Group
N GVAL
S GVAL=$P($G(^MAG(2005.2,IEN,1)),U,8)
I GVAL,'$D(^MAG(2005.2,GVAL,7,"B",IEN)) D
. N MAGFDA
. S MAGFDA(2005.22,"+1,"_GVAL_",",.01)=IEN
. D UPDATE^DIE("","MAGFDA","","")
. K MAGFDA
. Q
Q $S(GVAL'=CWG:0,1:1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBUT1 13202 printed Dec 13, 2024@02:07:55 Page 2
MAGQBUT1 ;WOIFO/RP/PTW - Utilities for Background ; 23 May 2013 10:50 AM
+1 ;;3.0;IMAGING;**7,8,20,81,39,135**;Mar 19, 2002;Build 5238;Jul 17, 2013
+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
UBPW(WS,ASSIGN) ; screen for duplicate assignments
+1 NEW IEN,PLACE,PIECE,WSIEN,VALUE,DUP
+2 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+3 SET VALUE(1)=PLACE
SET VALUE(2)=WS
+4 SET WSIEN=$$FIND1^DIC(2006.8,"","QX",.VALUE,"D","","")
+5 SET PIECE=$PIECE(ASSIGN,";",2)
+6 SET (DUP,IEN)=0
+7 ;IF NOT ASSIGNED THEN QUIT
+8 IF '$PIECE($GET(^MAG(2006.8,WSIEN,0)),U,PIECE)
KILL VALUE
QUIT DUP
+9 FOR
SET IEN=$ORDER(^MAG(2006.8,IEN))
if 'IEN
QUIT
Begin DoDot:1
+10 SET ZNODE=^MAG(2006.8,IEN,0)
+11 ; not a BP
if '$PIECE(ZNODE,U,12)
QUIT
+12 if $PIECE(ZNODE,U,2)'=PLACE
QUIT
+13 if $PIECE(ZNODE,U)=WS
QUIT
+14 if +$PIECE(ZNODE,U,PIECE)
SET DUP=1
+15 QUIT
End DoDot:1
if DUP
QUIT
+16 QUIT DUP
BPPS(INPUT,WS,PROCESS) ;INPUT TRANSFORM FOR FILE 2006.8
+1 NEW IEN,FND,WSNAME,WSNAME2,ZNODE,PIECE,MAGX,MAGY,PLACE
+2 SET U="^"
+3 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+4 ;NOT A BACKGROUND PROCESSOR
if '(+$PIECE($GET(^MAG(2006.8,WS,0)),U,12))
QUIT 0
+5 ; Always allow unassigned
if 'INPUT
QUIT 1
+6 ;Workstation Name
SET WSNAME=$PIECE($GET(^MAG(2006.8,WS,0)),U)
+7 ;BP WS NOT PROPERLY INSTALLED
if $LENGTH(WSNAME)<3
QUIT 0
+8 if $ORDER(^MAG(2006.8,"C",PLACE,WSNAME,""))'?1N.N
QUIT 1
+9 SET PIECE=$PIECE($$GET1^DID(2006.8,PROCESS,"","GLOBAL SUBSCRIPT LOCATION"),";",2)
+10 SET IEN=0
SET WSNAME2=""
SET FND=0
+11 FOR
SET WSNAME2=$ORDER(^MAG(2006.8,"C",PLACE,WSNAME2))
if WSNAME2=""
QUIT
Begin DoDot:1
+12 if WSNAME2=WSNAME
QUIT
+13 SET IEN=$ORDER(^MAG(2006.8,"C",PLACE,WSNAME2,""))
if IEN'?1N.N
QUIT
+14 SET ZNODE=$GET(^MAG(2006.8,IEN,0))
+15 if $PIECE(ZNODE,"^",12)'="1"
QUIT
+16 SET FND=$PIECE(ZNODE,"^",PIECE)="1"
+17 QUIT
End DoDot:1
if FND
QUIT
+18 QUIT $SELECT(FND="1":0,1:1)
RSQUE(RESULT,IEN,QUEUE) ;[MAGQB RSQUE]
+1 NEW PTR,PLACE
+2 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+3 SET PTR=$ORDER(^MAGQUEUE(2006.031,"C",PLACE,QUEUE,""))
+4 IF $PIECE(^MAGQUEUE(2006.031,PTR,0),"^")=QUEUE
Begin DoDot:1
+5 SET $PIECE(^MAGQUEUE(2006.031,PTR,0),"^",2)=IEN
+6 QUIT
End DoDot:1
+7 QUIT
ICCL(SRVRCNT,NMESS,PLACE) ;UPDATE IMAGING DISTRIBUTION
+1 NEW Y,LOC,INDEX,CNT,IEN,ARRAY,SUB1,SUB2,NAME
+2 SET Y=$$FMTE^XLFDT($$NOW^XLFDT)
+3 SET LOC=$$KSP^XUPARAM("WHERE")
+4 SET CNT=1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="SITE: "_LOC
+5 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="DATE: "_Y_" "_$GET(^XMB("TIMEZONE"))
+6 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="SENDER: "_$$PLNM^MAGQBUT5(PLACE)_" Imaging Background Processor"
+7 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="Total Cache Free: "_$PIECE(SRVRCNT,U,2)_" megabytes"
+8 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="Total Cache Available: "_$PIECE(SRVRCNT,U,3)_" megabytes"
+9 IF $PIECE(SRVRCNT,U,4)
SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="An Automatic Purge process has been Activated. "
+10 IF '$TEST
SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is NOT configured. "
+11 IF $PIECE(SRVRCNT,U,5)]""
SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is assigned to: "_$PIECE(SRVRCNT,U,5)
+12 IF '$TEST
SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="The Automatic Purge process is NOT assigned to a BP server. "
+13 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="The "_$PIECE(SRVRCNT,U)_" Imaging cache servers will"
+14 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="require operator intervention to ensure continued"
+15 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="availability. The following MAG SERVER members"
+16 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="are being notified: "
+17 SET INDEX=0
SET IEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
+18 if IEN'?1N.N
QUIT
+19 DO GETS^DIQ(3.8,IEN_",","2*;11*;12*","","ARRAY")
+20 SET (SUB1,SUB2)=""
+21 FOR
SET SUB1=$ORDER(ARRAY(SUB1))
if SUB1=""
QUIT
Begin DoDot:1
+22 FOR
SET SUB2=$ORDER(ARRAY(SUB1,SUB2))
if SUB2=""
QUIT
Begin DoDot:2
+23 SET NAME=$GET(ARRAY(SUB1,SUB2,".01"))
if NAME'=""
Begin DoDot:3
+24 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",8+CNT)=NAME
End DoDot:3
End DoDot:2
End DoDot:1
+25 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)="The next notifications will occur in: "
+26 SET CNT=CNT+1
SET ^TMP($JOB,"MAGQ",PLACE,"BP",CNT)=NMESS
+27 DO MAILSHR(PLACE,"BP","Image Cache Critically Low at "_LOC)
+28 SET $PIECE(^MAG(2006.1,$$PLACE^MAGBAPI($GET(DUZ(2))),3),"^",11)=$$NOW^XLFDT
+29 DO UDMI^MAGQBUT5("Image Cache Critically Low at ",PLACE)
+30 KILL ARRAY
+31 QUIT
MAILSHR(PLACE,APP,XMSUB) ;Shared Mail server code
+1 NEW XMY,XMTEXT,XMID,XMZ
+2 SET XMTEXT="^TMP($J,""MAGQ"",PLACE,APP)"
+3 if $GET(DUZ)
SET XMY(DUZ)=""
+4 if $$PROD^XUPROD("1")
DO ADDMG^MAGQBUT5(XMSUB,.XMY,PLACE)
+5 if $GET(MAGDUZ)
SET XMY(MAGDUZ)=""
+6 SET XMID=$GET(DUZ)
if 'XMID
SET XMID=.5
+7 SET XMY(XMID)=""
+8 NEW L1,L2,L3
+9 SET L2=$LENGTH($PIECE(XMSUB,"^",2))
+10 SET L3=60-L2
+11 SET L1=$LENGTH($PIECE(XMSUB,"^"))
+12 IF L2=0
SET XMSUB=$EXTRACT(XMSUB,1,60)
+13 IF '$TEST
SET XMSUB=$EXTRACT($PIECE(XMSUB,"^"),1,L3-1)_"^"_$PIECE(XMSUB,"^",2)
+14 DO SENDMSG^XMXAPI(XMID,XMSUB,XMTEXT,.XMY,,.XMZ,)
+15 KILL ^TMP($JOB,"MAGQ",PLACE,APP)
+16 IF $GET(XMERR)
MERGE XMERR=^TMP("XMERR",$JOB)
KILL XMERR
+17 QUIT
ALLSERV(RESULT,GRP) ; BP Queue Processor
+1 ; RPC[MAGQ ALL SERVER] used for ServerSize update/display function - reports network resources
+2 ; Returns OnLine, network addressed, non-router, place related Magnetic shares
+3 ; it returns the share designated as the current Write location in the (0) indice
+4 ; it does not screen on READ-ONLY, and the list is group specific
+5 ; the function could be replaced by a fileman call from the GUI
+6 ; PHYSICAL REFERENCE^CWL or ien^FREE SPACE^TOTAL SPACE^NAME^GROUP^TYPE
+7 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+8 ;CWL=CURRENT WRITE LOCATION CWG=CURRENT WRITE GROUP
NEW INDX,DATA,CNT,SHARE,CWL,VALUE,TMP,PLACE,CWG
+9 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+10 SET CWG=$SELECT($GET(GRP)["ALL":"",1:$$CWG^MAGBAPI(PLACE))
+11 ;Remove all members that do not reference this group
if CWG
DO CWGIC(CWG)
+12 SET CWL=$$CWL^MAGBAPI(PLACE)
+13 ; I CWL D ;First report Current Write Location data
+14 ; . S DATA=$G(^MAG(2005.2,CWL,0))
+15 ; . S SHARE=$P(DATA,U,2)
+16 ; . S RESULT(0)=SHARE_U_CWL_U_+$P(DATA,U,5)_U_+$P(DATA,U,3)_U_$P(DATA,U)
+17 ; . S RESULT(0)=RESULT(0)_U_$S($L($$GET1^DIQ(2005.2,CWL,31,"E","","")):$$GET1^DIQ(2005.2,CWL,31,"E","",""),1:"")
+18 ; . S RESULT(0)=RESULT(0)_U_$$GET1^DIQ(2005.2,CWL,6,"I","","")
+19 ; . Q
+20 ; E S RESULT(0)="-1^The Current Write Location (CWL) is not currently set."
+21 SET INDX=0
SET U="^"
SET CNT=1
+22 KILL ^TMP("MAGQAS")
+23 FOR
SET INDX=$ORDER(^MAG(2005.2,INDX))
if INDX'?1N.N
QUIT
Begin DoDot:1
+24 SET DATA=$GET(^MAG(2005.2,INDX,0))
+25 if $PIECE(DATA,U,6,7)'["1^MAG"
QUIT
+26 if $PIECE(DATA,U,2)["
QUIT
+27 if ($PIECE(DATA,U,10)'=PLACE)
QUIT
+28 ;ROUTING SHARE
if $PIECE(DATA,U,9)="1"
QUIT
+29 SET SHARE=$PIECE(DATA,U,2)
+30 if $EXTRACT(SHARE,1,2)'="\\"
QUIT
+31 IF $EXTRACT(SHARE,$LENGTH(SHARE))="\"
SET SHARE=$EXTRACT(SHARE,1,$LENGTH(SHARE)-1)
+32 SET TMP(SHARE)=""
+33 ;screen on Current Write Group also validate group member reference
IF CWG
IF '$$GMEM(CWG,INDX)
QUIT
+34 SET VALUE=SHARE_U_INDX_U_+$PIECE(DATA,U,5)_U_+$PIECE(DATA,U,3)_U_$PIECE(DATA,U)
+35 SET VALUE=VALUE_U_$SELECT($LENGTH($$GET1^DIQ(2005.2,INDX,31,"E","","")):$$GET1^DIQ(2005.2,INDX,31,"E","",""),1:"")
+36 SET VALUE=VALUE_U_$$GET1^DIQ(2005.2,INDX,6,"E","","")
+37 ;ELSE CONTINUE
IF INDX=CWL
Begin DoDot:2
+38 SET RESULT(0)=VALUE_U_$GET(^TMP("MAGQ","WSUD"))
+39 ;1ST SHARE=CWL
SET ^TMP("MAGQAS",0)=VALUE
+40 QUIT
End DoDot:2
QUIT
+41 SET RESULT(CNT)=VALUE
SET CNT=CNT+1
+42 SET ^TMP("MAGQAS",CNT-1)=VALUE
+43 QUIT
End DoDot:1
+44 QUIT
ALLSHR(RESULT,TYPE) ; RPC[MAGQBP ALL SHARES] - Used by BP Purge
+1 ; screens off-line,read-only,routing share,non-mag,non-place,next group,current group,specific group(s)
+2 ;CWL=CURRENT WRITE LOCATION
NEW TMP,INDX,DATA,CNT,SHARE,CWL,VALUE,PLACE,NG,GRP
+3 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+4 ;calling routine will define TYPE, or set as ALL by default (no screen).
SET (CNT,INDX)=0
SET U="^"
if '$DATA(TYPE)
SET TYPE="ALL"
+5 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+6 SET CWL=$$CWL^MAGBAPI(PLACE)
+7 SET GRP=$$GRP^MAGQBUT(PLACE)
+8 ; Next Purge capable group
SET NG=$$NXTGP^MAGQBUT(PLACE,GRP,"1")
+9 FOR
SET INDX=$ORDER(^MAG(2005.2,INDX))
if INDX'?1N.N
QUIT
Begin DoDot:1
+10 SET DATA=$GET(^MAG(2005.2,INDX,0))
+11 if $PIECE(DATA,U,6,7)'["1^MAG"
QUIT
+12 ;ROUTING SHARE
if $PIECE(DATA,U,9)="1"
QUIT
+13 if $PIECE(DATA,U,2)["
QUIT
+14 if ($PIECE(DATA,U,10)'=PLACE)
QUIT
+15 ;Read Only
if ($PIECE($GET(^MAG(2005.2,INDX,1)),U,6)="1")
QUIT
+16 ;NOT a member of the Next RAID Group
if (("^AUTO^NRG^"[("^"_TYPE_"^"))&($PIECE($GET(^MAG(2005.2,INDX,1)),U,8)'=NG))
QUIT
+17 ;NOT a member of the Current RAID Group
if (("^CRG^"[("^"_TYPE_"^"))&($PIECE($GET(^MAG(2005.2,INDX,1)),U,8)'=GRP))
QUIT
+18 ;NOT a member of the Specified RAID Group
if ((TYPE?1N.N)&($PIECE($GET(^MAG(2005.2,INDX,1)),U,8)'=TYPE))
QUIT
+19 SET SHARE=$$UPPER^MAGQE4($PIECE(DATA,U,2))
+20 if $EXTRACT(SHARE,1,2)'="\\"
QUIT
+21 IF $EXTRACT(SHARE,$LENGTH(SHARE))="\"
SET SHARE=$EXTRACT(SHARE,1,$LENGTH(SHARE)-1)
+22 if $DATA(TMP(SHARE))
QUIT
+23 SET TMP(SHARE)=""
+24 QUIT
End DoDot:1
+25 SET INDX=""
+26 FOR
SET INDX=$ORDER(TMP(INDX))
if INDX=""
QUIT
Begin DoDot:1
+27 SET RESULT(CNT)=INDX
SET CNT=CNT+1
+28 QUIT
End DoDot:1
+29 KILL TMP
+30 QUIT
FSUPDT(RESULT,IEN,SPACE,SIZE) ; File Server Update
+1 ; RPC[MAGQ FS UPDATE]
+2 ; Space is field #2 (Total Space)and is actually share size
+3 ; Size is field #4 (Free Space)
+4 NEW NODE,X,Y,INDEX,SHNAME,PLACE
+5 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+6 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+7 KILL ^TMP("MAGQ","WSUD")
+8 SET ^TMP("MAGQ","WSUD",IEN)=$$FMTE^XLFDT($$NOW^XLFDT)_U_IEN_U_SPACE_U_SIZE
+9 IF $GET(^MAG(2005.2,IEN,0))=""
SET RESULT="-1^No Network Location Entry"
QUIT
+10 SET SHNAME=$PIECE($GET(^MAG(2005.2,IEN,0)),U,2)
+11 ;The next is to update redundant shares and should not be necessary
DO FSW(IEN,SPACE,SIZE)
+12 SET INDEX=0
FOR
SET INDEX=$ORDER(^MAG(2005.2,"AC",SHNAME,INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+13 if INDEX=IEN
QUIT
+14 DO FSW(INDEX,SPACE,SIZE)
+15 QUIT
End DoDot:1
+16 SET RESULT="1^Update Complete"
+17 QUIT
FSW(IX,SP,SZ) ;
+1 SET $PIECE(^MAG(2005.2,IX,0),U,3)=+SP
SET $PIECE(^MAG(2005.2,IX,0),U,5)=+SZ
+2 QUIT
QUEUER(QUE,FROM,TO) ;
+1 NEW TYPE,INC,CNT,AR,TMP,PLACE,INST,MAGFILE
+2 IF $$GET1^DIQ(200,+$GET(DUZ),.01)=""
Begin DoDot:1
+3 WRITE !,"You must have a valid User ID (DUZ) to use this function!"
+4 QUIT
End DoDot:1
QUIT
+5 IF "^JBTOHD^PREFET^ABSTRACT^JUKEBOX^GCC^DELETE^EVAL^"'[QUE
Begin DoDot:1
+6 WRITE !,"Only JBTOHD, PREFET, ABSTRACT, JUKEBOX, DELETE, EVAL & GCC queues are valid!"
+7 WRITE !,"Input values: ""Queue type"",""From Image IEN"",""To Image IEN"""
End DoDot:1
QUIT
+8 SET CNT=0
SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
SET INST=$$GET1^DIQ(2006.1,PLACE,.01,"I")
+9 FOR INC=FROM:1:TO
Begin DoDot:1
+10 IF ('$DATA(^MAG(2005,INC,0))&('$DATA(^MAG(2005.1,INC,0))))
QUIT
+11 IF $DATA(^MAG(2005,INC,0))
IF $$PLACE^MAGBAPI(+$PIECE($GET(^MAG(2005,INC,100)),U,3))'=PLACE
QUIT
+12 IF $DATA(^MAG(2005.1,INC,0))
IF $$PLACE^MAGBAPI(+$PIECE($GET(^MAG(2005.1,INC,100)),U,3))'=PLACE
QUIT
+13 ;No full filename attribute
IF ($PIECE($GET(^MAG(2005,INC,0)),"^",2)="")&($PIECE($GET(^MAG(2005.1,INC,0)),"^",2)="")
QUIT
+14 ;GROUP PARENT
IF (+$PIECE($GET(^MAG(2005,INC,1,0)),"^",4)>0)!(+$PIECE($GET(^MAG(2005.1,INC,1,0)),"^",4)>0)
QUIT
+15 IF "^DELETE^"[QUE
Begin DoDot:2
+16 NEW MAGXX
SET MAGXX=INC
DO VSTNOCP^MAGFILEB
IF $EXTRACT(MAGFILE,1,2)="-1"
WRITE !,"Image # "_INC
QUIT
+17 SET MAGXX=INC
DO ABSNOCP^MAGFILEB
IF $EXTRACT(MAGFILE,1,2)="-1"
WRITE !,"Image # "_INC
QUIT
+18 DO IMAGEDEL^MAGGTID(.MAGFILE,INC,"","TESTING")
+19 QUIT
End DoDot:2
QUIT
+20 IF "^ABSTRACT^"[QUE
Begin DoDot:2
+21 IF $$ABSOK^MAGQBUT1(INC)
DO MAPI(QUE,INC,.CNT)
+22 QUIT
End DoDot:2
QUIT
+23 IF "^JBTOHD^PREFET^"[QUE
FOR TYPE="ABSTRACT","FULL","BIG"
Begin DoDot:2
+24 if (TYPE="BIG")&('$DATA(^MAG(2005,INC,"FBIG"))&'$DATA(^MAG(2005.1,INC,"FBIG")))
QUIT
+25 DO MAPI(QUE,INC_"^"_TYPE,.CNT)
+26 QUIT
End DoDot:2
+27 ; JUKEBOX,EVAL,GCC
IF '$TEST
DO MAPI(QUE,INC,.CNT)
+28 QUIT
End DoDot:1
+29 QUIT
MAPI(TYP,PARAM,CNT) ;
+1 NEW PLACE
+2 SET CNT=CNT+1
SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+3 WRITE !,CNT," TYPE: ",TYP,": ",PARAM_" QUEUE #: ",@("$$"_TYP_"^MAGBAPI(PARAM,PLACE)")
+4 QUIT
ABSOK(IEN) ; Verify that the Full Image Type is a supported by our ABSTRACT method
+1 ; Image file type
NEW TYPE,FILE,IFT
+2 SET FILE=$SELECT($DATA(^MAG(2005,IEN)):$PIECE($GET(^MAG(2005,IEN,0)),U,2),$DATA(^MAG(2005.1,IEN)):$PIECE($GET(^MAG(2005.1,IEN,0)),U,2),1:"")
+3 SET TYPE=$PIECE(FILE,".",2)
+4 SET IFT=$SELECT($DATA(^MAG(2005.021,"B",TYPE)):$ORDER(^MAG(2005.021,"B",TYPE,"")),1:"")
+5 IF (IFT']"")!($PIECE($GET(^MAG(2005.021,IFT,0)),U,5)'="1")
Begin DoDot:1
+6 WRITE !,"Abstract not supported IEN/TYPE: "_IEN_"/"_TYPE
End DoDot:1
QUIT 0
+7 QUIT $PIECE($GET(^MAG(2005.021,IFT,0)),U,5)
BPQSL(RESULT,TYPE) ; Called from MAGQUEMAN.PAS and MagSiteParameters.PAS
+1 ; RPC[MAGQB QSL]
+2 NEW STATUS,CNT,IEN,CP,PLACE
+3 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+4 SET STATUS=""
SET CNT=0
+5 FOR
SET STATUS=$ORDER(^MAGQUEUE(2006.03,"D",PLACE,TYPE,STATUS))
if STATUS=""
QUIT
Begin DoDot:1
+6 if +STATUS>0
QUIT
+7 SET IEN=$ORDER(^MAGQUEUE(2006.03,"D",PLACE,TYPE,STATUS,""))
+8 SET CP=$PIECE(^MAGQUEUE(2006.031,$ORDER(^MAGQUEUE(2006.031,"C",PLACE,TYPE,"")),0),"^",2)
+9 if IEN>(CP)
QUIT
+10 SET CNT=CNT+1
SET RESULT(CNT)=STATUS
+11 QUIT
End DoDot:1
+12 QUIT
CWGIC(CWG) ; Current RAID Group integrity check
+1 NEW VALUE,IEN,MAGFDA,MSG
+2 SET VALUE=""
+3 FOR
SET VALUE=$ORDER(^MAG(2005.2,CWG,7,"B",VALUE))
if 'VALUE
QUIT
if ($PIECE($GET(^MAG(2005.2,VALUE,1)),U,8)'=CWG)
Begin DoDot:1
+4 SET IEN=$ORDER(^MAG(2005.2,CWG,7,"B",VALUE,""))
+5 SET MAGFDA(2005.22,IEN_","_CWG_",",.01)="@"
+6 DO FILE^DIE("","MAGFDA","")
+7 KILL MAGFDA
+8 QUIT
End DoDot:1
+9 QUIT
GMEM(CWG,IEN) ; Update Current RAID Group
+1 NEW GVAL
+2 SET GVAL=$PIECE($GET(^MAG(2005.2,IEN,1)),U,8)
+3 IF GVAL
IF '$DATA(^MAG(2005.2,GVAL,7,"B",IEN))
Begin DoDot:1
+4 NEW MAGFDA
+5 SET MAGFDA(2005.22,"+1,"_GVAL_",",.01)=IEN
+6 DO UPDATE^DIE("","MAGFDA","","")
+7 KILL MAGFDA
+8 QUIT
End DoDot:1
+9 QUIT $SELECT(GVAL'=CWG:0,1:1)
