source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT1.m@ 1397

MAGQBUT1 ;WOIFO/RP; Utilities for Background [ 03/25/2001 11:20 ]
 ;;3.0;IMAGING;**7,8,20,81**;May 17, 2007
 ;;  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
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
 S WSNAME=$$UPPER^MAGQE4($P($G(^MAG(2006.8,WS,1)),U)) ;Workstation Name
 Q:$L(WSNAME)<3 0 ;BP WS NOT PROPERLY INSTALLED
 Q:$O(^MAG(2006.8,"C",PLACE,WSNAME,""))'?1N.N 0
 F MAGX=12,13,14,15,16,17,20 D  Q:MAGY=PROCESS
 . S MAGY=$$GET1^DID(2006.8,MAGX,"","LABEL")
 . D:MAGY=PROCESS
 . . S PIECE=$$GET1^DID(2006.8,MAGX,"","GLOBAL SUBSCRIPT LOCATION")
 Q:MAGY'=PROCESS 0
 S PIECE=$P(PIECE,";",2)
 S IEN=0,WSNAME2="",FND=0
 F  S WSNAME2=$$UPPER^MAGQE4($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:($P(ZNODE,"^",PIECE)="1") FND="1"
 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
 . ;D RQCNT^MAGQBTM(PLACE)
 Q
ICCL(SRVRCNT,NMESS,PLACE) ;UPDATE IMAGING DISTRIBUTION
 N Y,LOC,INDEX,CNT,IEN,ARRAY,SUB1,SUB2,NAME
 D NOW^%DTC S Y=% D DD^%DT
 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)="Total Cache Free: "_$P(SRVRCNT,U,2)_" gigabytes"
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="Total Cache Available: "_$P(SRVRCNT,U,3)_" gigabytes"
 I $P(SRVRCNT,U,4) S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="An Automatic Purge process has been Activated."
 E  S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="The Automatic Purge process is NOT configured."
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="The "_$P(SRVRCNT,U)_" Imaging cache servers will"
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="require operator intervention to ensure continued"
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="availability.  The following MAG SERVER members"
 S CNT=CNT+1,^TMP($J,"MAGQ",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",8+CNT)=NAME
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)="The next notifications will occur in:"
 S CNT=CNT+1,^TMP($J,"MAGQ",CNT)=NMESS
 D MAILIT
 S $P(^MAG(2006.1,$$PLACE^MAGBAPI($G(DUZ(2))),3),"^",11)=$$NOW^XLFDT
 K ARRAY
 Q
MAILIT ;Send the report to the Clinical Application Time
 N XMSUB
 S XMSUB="Image Cache Critically Low at "_LOC
MAILSHR ;Shared Mail server code
 ;If dropping in...must manage XMSUB
 N XMY,XMTEXT
 S XMTEXT="^TMP($J,""MAGQ"","
 S:$G(DUZ) XMY(DUZ)=""
 S XMY("G.MAG SERVER")=""
 S:$G(MAGDUZ) XMY(MAGDUZ)=""
 D ^XMD
 K ^TMP($J,"MAGQ")
 Q
ALLSERV(RESULT) ;
 ; RPC[MAGQ ALL SERVER]
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 N INDX,DATA,CNT,SHARE,CWL,VALUE,TMP,PLACE ;CWL=CURRENT WRITE LOCATION
 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
 S CWL=$$CWL^MAGBAPI(PLACE)
 I CWL D
 . 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)
 . Q
 E  S RESULT(0)="-1^The Current Write Location (CWL) could not be 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)=""
 . S VALUE=SHARE_U_INDX_U_+$P(DATA,U,5)_U_+$P(DATA,U,3)_U_$P(DATA,U)
 . I INDX=CWL D  Q  ;ELSE CONTINUE 
 . . S RESULT(0)=VALUE_U_$G(^TMP("MAGQ","WSUD"))
 . . S ^TMP("MAGQAS",0)=VALUE ;1ST SHARE=CWL
 . S RESULT(CNT)=VALUE,CNT=CNT+1
 . S ^TMP("MAGQAS",CNT-1)=VALUE
 Q
ALLSHR(RESULT) ; RPC[MAGQBP ALL SHARES]
 N TMP,INDX,DATA,CNT,SHARE,CWL,VALUE,PLACE ;CWL=CURRENT WRITE LOCATION
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 S (CNT,INDX)=0,U="^"
 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
 S CWL=$$CWL^MAGBAPI(PLACE)
 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)
 . S SHARE=$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)=""
 S INDX=""
 F  S INDX=$O(TMP(INDX)) Q:INDX=""  D
 . S RESULT(CNT)=INDX,CNT=CNT+1
 K TMP
 Q
FSUPDT(RESULT,IEN,SPACE,SIZE) ;
 ;File Server Update
 ; RPC[MAGQ FS UPDATE]
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 N NODE,X,Y,INDEX,SHNAME,PLACE
 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
 S X=$$NOW^XLFDT S Y=X D DD^%DT S ^TMP("MAGQ","WSUD")=Y
 S ^TMP("MAGQ","WSUD",XWBTIP)=Y
 I $G(^MAG(2005.2,IEN,0))="" S RESULT="-1^No Network Location Entry" Q
 S NODE=^MAG(2005.2,IEN,0)
 D FSW(IEN,NODE)
 S INDEX=0,SHNAME=$P(NODE,"^",2)
 ; NOW UPDATE THE SIZING FIELDS FOR SHARES OF SAME PHYS LOCATION
 F  S INDEX=$O(^MAG(2005.2,"AC",SHNAME,INDEX)) Q:INDEX'?1N.N  D
 . Q:INDEX=IEN
 . S NODE=^MAG(2005.2,INDEX,0)
 . D FSW(INDEX,NODE)
 S RESULT="1^Update Complete"
 Q
FSW(INDEX,NODE) ;
 I (($P(NODE,"^",3)'=(+SIZE))!($P(NODE,"^",5)'=(+SPACE))) D
 . S $P(NODE,"^",3)=+SIZE,$P(NODE,"^",5)=+SPACE,^MAG(2005.2,INDEX,0)=NODE
 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!"
 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
 ;
 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
 ;
 S 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 ($$PLACE^MAGBAPI(+$P($G(^MAG(2005,INC,100)),U,3))'=PLACE)&($$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
 . . S MAGXX=INC D VSTNOCP^MAGFILEB I $P(MAGFILE,U)="-1" W !,"Image # "_INC Q 
 . . S MAGXX=INC D ABSNOCP^MAGFILEB I $P(MAGFILE,U)="-1" W !,"Image # "_INC Q
 . . S MAGXX=INC D BIGNOCP^MAGFILEB I $P(MAGFILE,U)="-1" W !,"Image # "_INC Q
 . . D IMAGEDEL^MAGGTID(.MAGFILE,INC,"","TESTING") 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)
 . E  D MAPI(QUE,INC,.CNT)
 Q
MPAC(SW,FROM,TO) ;
 N INDEX
 I (SW'=1)&(SW'=0) W !,"The first parameter must equal 0 or 1" Q
 I (FROM<0)!((TO<0)!(TO<FROM)) W !,"The second parameter must be greater than 0 and less than the third!" Q
 S FROM=FROM-1
 F  S INDEX=$O(^MAG(2005,INDEX)) Q:INDEX'?1N.N  Q:INDEX>TO  D
 . I '$D(^MAG(2005,INDEX,0)) Q
 . I $P($G(^MAG(2005,INDEX,0)),"^",2)="" Q  ;No full filename attribute
 . I +$P($G(^MAG(2005,INDEX,1,0)),"^",4)>0 Q  ;GROUP PARENT
 . I (SW=1)&('$D(^MAG(2005,INDEX,"PACS"))) S ^MAG(2005,INDEX,"PACS")="TEST PACS" Q
 . I SW=0 K ^MAG(2005,INDEX,"PACS")
 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
BPQSL(RESULT,TYPE) ;
 ; 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