MAGQBUT4 ;WOIFO/RMP,DAC,JSJ - BP Utilities ; Jun 16, 2022@14:42:24
;;3.0;IMAGING;**7,8,48,20,81,39,121,135,196,198,214,222,235,238,243,248,325,293,331,347**;Mar 19, 2002;Build 6
;; Per VA Directive 6402, 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
VOKR(RESULT,VER) ; RPC for VOK [MAGQ VOK]
; P196 changed the way version checking works.
; we now allow older versions of the BP to run.
N CLPATCH,SVRPATCH
; get client Patch number
S CLPATCH=$$TRIM($P(VER,"P",2))
; These are allowable Clients.
S SVRPATCH=",293,331,347" ; P293,P331,P347 drop P325 continue last 3
; if client patch is allowed Result = 1^...
I SVRPATCH[CLPATCH S RESULT="1^3.0P331"
E S RESULT="0^3.0P331"
Q
OLD ;
S VER="3.0P"_($$TRIM($P(VER,"P",2)))
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
S SLINE=$T(+2)
S PNUM=$$TRIM($P(SLINE,"**",2)),PNUM=$$TRIM($P(PNUM,",",$L(PNUM,",")))
S CVERS=$$TRIM($P(SLINE,";",3))_"P"_PNUM
S RESULT=$S(CVERS=VER:1,1:0)_U_CVERS
Q
;
CONV(ARR,ICT) ;Convert any single node array to FM Style multiple
; The node subscripts of ARR are ignored, and not retained
; i.e. ARR(34)=8
; ARR("BLUE")=9
; ARR("D")=10
; converts to
; ARR(1,0)=8
; ARR(2,0)=9
; ARR(3,0)=10
N I,ARO
S ICT=0,I=""
F S I=$O(ARR(I)) Q:(I="") D
. S ICT=ICT+1
. S ARO(ICT,0)=ARR(I)
K ARR
M ARR=ARO
Q
MRGMULT(ARR,RT,RTDSC,CT) ;Merge the FM formatted array into a FM File
; multiple field.
; This isn't for general consumption.
; RT = FILE ROOT, RECORD NUMBER, NODE
; i.e. "^MAG(2006.034,44,1," -> 44 is the IEN of MAG(2006.34
; RTDSC is the 2nd piece of the 0 node of the multiple field.
S RT=$E(RT,1,$L(RT)-1)_")"
S @RT@(0)=U_RTDSC_U_CT_U_CT ; i.e. ^2006.341A^13^13
M @RT=ARR
Q
DDLF(RESULTS,FILE,FIELD,FLAGS,ATTR) ;[MAG FLD ATT]
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
K X
N I
D FIELD^DID(FILE,FIELD,FLAGS,ATTR,"RESULTS","RESULTS")
S I=0 F S I=I+1 Q:'$D(RESULTS(ATTR,I)) M RESULTS(I)=RESULTS(ATTR,I)
Q
DDFA(RESULTS) ;[MAG ATT LST]
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
K X
D FIELDLST^DID(RESULTS)
Q
DVAL(RESULTS,FILE,IENS,FIELD,FLAGS,VALUE) ;[MAG FIELD VALIDATE]
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
K X
I FLAGS']"" S FLAGS="EHU"
D VAL^DIE(FILE,IENS,FIELD,FLAGS,VALUE,.RESULT,"","MSG")
I RESULT=U S RESULTS="-1^"_$G(MSG("DIERR","1","TEXT","1"))
E S RESULTS=1_U_RESULT_U_$G(RESULT(0))
Q
KVAL(RESULTS,FLAGS,FDA) ;[MAG KEY VALIDATE]
N TMP,DDRFDA
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
K X
D FDASET(.FDA,.DDRFDA)
S TMP=$$KEYVAL^DIE(FLAGS,"DDRFDA","MSG")
S RESULTS=$S(TMP=1:1,1:"-1^"_$G(MSG("DIERR","1","TEXT","1")))
K DDRFDA,MSG
Q
FDASET(DDRROOT,DDRFDA) ;
N DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
S I=0
F S I=$O(DDRROOT(I)) Q:'I S X=DDRROOT(I) D
. S DDRFILE=$P(X,U)
. S DDRFIELD=$P(X,U,2)
. S DDRIEN=$P(X,U,3)
. S DDRVAL=$P(X,U,4,99)
. D FDA^DILF(DDRFILE,DDRIEN_$S($E(DDRIEN,$L(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
Q
DHRPC(RESULTS,FNAME,FLOC) ;[MAG DIRHASH]
N TMP
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
K X
S TMP=$$DIRHASH^MAGFILEB(FNAME,FLOC)
S RESULTS=$S(TMP="":U,1:TMP)
Q
GPACHX(PV) ; Get Package File Install History of Imaging
N I,LCNT,MSG,PKG
S LCNT=0
S PV(0)="Version^Install Date"
F PKG="IMAGING" D
. N J,K,L,VERS,DATE,X,Y
. S J=$O(^DIC(9.4,"B",PKG,"")) Q:'J
. S VERS="" F S VERS=$O(^DIC(9.4,J,22,"B",VERS)) Q:VERS="" D
. . N MSG,TAR
. . S K=$O(^DIC(9.4,J,22,"B",VERS,""))
. . D LIST^DIC(9.4901,","_K_","_J_",","@;.01;.02;.03","","","","","","","","TAR","MSG")
. . Q:$D(MSG("DIERR"))
. . S L=0 F S L=$O(TAR("DILIST","ID",L)) Q:'L D
. . . S LCNT=LCNT+1
. . . S PV(LCNT)=VERS_"P"_$P(TAR("DILIST","ID",L,".01"),"^",1)
. . . S X=$P($P(TAR("DILIST","ID",L,".02"),"^",1),"@",1)
. . . S PV(LCNT)=PV(LCNT)_"^"_$S(X["-1":"",1:X)
. . . Q
. . Q
. Q
Q
;
TRIM(X) ; remove both leading and trailing blanks
N I,J
F I=1:1:$L(X) Q:$E(X,I)'=" "
F J=$L(X):-1:I Q:$E(X,J)'=" "
Q $S($E(X,I,J)=" ":"",1:$E(X,I,J))
;
QCNT(RESULT,PLC,QUE) ; [MAGQ QCNT] Called from MagQueManSet.pas and MagSiteParameters.pas
N CNT,DA,CQ,IA,X
S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
;CQ=Current Queue Pointer(#2006.03)
;QP=Queue file pointer(#2006.031)
;CNT=Queue type total, IA=Not failed total
S IA="",RESULT=0
S (CNT,IA)=0,DA=""
S QP=$S($D(^MAGQUEUE(2006.031,"C",PLC,QUE)):$O(^MAGQUEUE(2006.031,"C",PLC,QUE,"")),1:"")
S CQ=$S('QP:0,1:$P($G(^MAGQUEUE(2006.031,QP,0)),U,2))
F S DA=$O(^MAGQUEUE(2006.03,"C",PLC,QUE,DA)) Q:'DA D
. I '$D(^MAGQUEUE(2006.03,DA,0)) K ^MAGQUEUE(2006.03,"C",PLC,QUE,DA) Q
. S CNT=CNT+1
. I CQ<DA S IA=IA+1
. Q
D QPUP(PLC,QUE,CNT,CQ,IA,QP) Q
Q
;
QPUP(PLC,QUE,CNT,CQ,IA,QP) ;
N IEN,DIC,VAL
K VAL
S VAL(1)=PLC,VAL(2)=QUE
S QP=$S(QP:QP,1:$$FIND1^DIC(2006.031,"","QX",.VAL,"C","",""))
;I IEN>0 D Q:IEN
;. S $P(^MAGQUEUE(2006.031,IEN,0),U,5)=CNT Q
I 'QP D Q
. K DIE,FDA
. S FDA(2006.031,"+1,",.01)=QUE
. S FDA(2006.031,"+1,",.04)=PLC
. S FDA(2006.031,"+1,",1)=CQ
. S FDA(2006.031,"+1,",2)=IA
. S FDA(2006.031,"+1,",3)=CNT
. D UPDATE^DIE("U","FDA","","MAGQUP")
. K DIE,FDA
E D
. K DIE,FDA
. S FDA(2006.031,QP_",",.01)=QUE
. S FDA(2006.031,QP_",",.04)=PLC
. S FDA(2006.031,QP_",",1)=CQ
. S FDA(2006.031,QP_",",2)=IA
. S FDA(2006.031,QP_",",3)=CNT
. D FILE^DIE("","FDA","MAGERR")
. K DIE,FDA
Q
;
CPUD ;
N PLC,INS,QUE
S (INS,PLC)=""
F S INS=$O(^MAG(2006.1,"B",INS)) Q:INS="" D
. S PLC=$O(^MAG(2006.1,"B",INS,""))
. S QUE="" F S QUE=$O(^MAGQUEUE(2006.031,"C",PLC,QUE)) Q:QUE="" D
. . D QCNT^MAGQBUT4("",PLC,QUE)
. . Q
. Q
Q
CNL(GL,IEN,NLC) ; Check Network Location
N MAGREF,MAG0,MAG1,PLC
S NLC=NLC+1
I '$G(IEN) Q ""
S MAG0=$G(@(GL_IEN_",0)"))
S MAGREF=+$P(MAG0,"^",3) ; get file from raid
I MAGREF=0 S MAGREF=+$P(MAG0,"^",5) ; get file from jukebox
I 'MAGREF Q ""
I '$D(^MAG(2005.2,MAGREF,0)) Q ""
S PLC=$P($G(^MAG(2005.2,MAGREF,0)),U,10)
Q:'PLC ""
S PLC=$P($G(^MAG(2006.1,PLC,0)),U)
Q $S('PLC:"",1:PLC)
CNSP(GL,IEN,NMSP,NSC) ; Check NameSPace
N NMSPC,MAG0,FNAM,INSTIEN
S NSC=NSC+1
S MAG0=$G(@(GL_IEN_",0)"))
S FNAM=$P(MAG0,U,2)
S NMSPC=$TR($P(FNAM,"."),"0123456789","")
Q:NMSPC="" ""
S INSTIEN=$S($D(NMSP(NMSPC)):$O(NMSP(NMSPC,"")),1:"")
Q INSTIEN
NMSP(TMPA) ;
N IEN,INS,TMP,I,J
S INS="" F S INS=$O(^MAG(2006.1,"B",INS)) Q:INS="" S IEN="" D
. S IEN=$O(^MAG(2006.1,"B",INS,IEN)) Q:IEN="" D Q
. . S TMP=","_$$UPPER^MAGQE4($$INIS^MAGQBPG2(IEN))_"," D Q
. . . F I=2:1 S J=$P(TMP,",",I) Q:J="" S TMPA(J,INS)=""
. . . Q
S J="" F S J=$O(TMPA(J)) Q:J="" S INS=$O(TMPA(J,"")) K:($O(TMPA(J,INS))]"") TMPA(J)
Q
CLRQ ; Clears the Queue file and Queue Pointer files
N DA,DIK,FILE,IEN
F FILE=2006.03,2006.031 D
. S IEN=0 F S IEN=$O(^MAGQUEUE(FILE,IEN)) Q:'IEN D
. . S DIK="^MAGQUEUE("_FILE_","
. . S DA=IEN,DA(1)=FILE D ^DIK
K DIK,DA
Q
; We add RPC to MAG WINDOWS Option this way instead of sending Option : MAG WINDOWS
; If we send MAG WINDOWS Option, the last one installed will overwrite others.
; ADDRPC copied from Patch 51, added the call "D MES^XPDUTL(" instead of "W !"
ADDRPC(RPCNAME,OPTNAME) ;
N DA,DIC
S DIC="^DIC(19,",DIC(0)="",X=OPTNAME D ^DIC
I Y<0 D Q
. D MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
. D MES^XPDUTL("Cannot find Option: """_OPTNAME_""".")
. Q
I '$D(^XWB(8994,"B",RPCNAME)) D Q
. D MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
. D MES^XPDUTL("Cannot find RPC: """_RPCNAME_""".")
. Q
S DA(1)=+Y
I $D(^DIC(19,+Y,"RPC","B",$O(^XWB(8994,"B",RPCNAME,"")))) D Q
. D MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
. D MES^XPDUTL("RPC: """_RPCNAME_""" is already a member of """_OPTNAME_""".")
. Q
S DIC=DIC_DA(1)_",""RPC"","
S DIC(0)="L",DLAYGO="19" ; LAYGO should be allowed here
S X=RPCNAME
D ^DIC
K DIC,D0,DLAYGO
I Y<0 D Q
. D MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
. D MES^XPDUTL("Cannot find RPC: """_RPCNAME_""".")
. Q
Q
INS(XP,DUZ,DATE,IDA) ;
N CT,CNT,COM,D,D0,D1,D2,DDATE,DG,DIC,DICR,DIW,MAGMSG,ST,XMID,XMY,PLACE,XMSUB,XMZ
S PLACE=$O(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
D GETENV^%ZOSV
S CNT=0
S CNT=CNT+1,MAGMSG(CNT)="PACKAGE INSTALL"
S CNT=CNT+1,MAGMSG(CNT)="SITE: "_$$KSP^XUPARAM("WHERE")
S CNT=CNT+1,MAGMSG(CNT)=" Production Account: "_$$PROD^XUPROD("1")
S CNT=CNT+1,MAGMSG(CNT)="PACKAGE: "_XP
S CNT=CNT+1,MAGMSG(CNT)="Version: "_$$VER^XPDUTL(XP)
S ST=$$GET1^DIQ(9.7,IDA,11,"I")
S CNT=CNT+1,MAGMSG(CNT)="Start time: "_$$FMTE^XLFDT(ST)
S CT=$$GET1^DIQ(9.7,IDA,17,"I") S:+CT'=CT CT=$$NOW^XLFDT
S CNT=CNT+1,MAGMSG(CNT)="Completion time: "_$$FMTE^XLFDT(CT)
S CNT=CNT+1,MAGMSG(CNT)="Run time: "_$$FMDIFF^XLFDT(CT,ST,3)
S CNT=CNT+1,MAGMSG(CNT)="Environment: "_Y
S COM=$$GET1^DIQ(9.7,IDA,6,"I")
S CNT=CNT+1,MAGMSG(CNT)="FILE COMMENT: "_COM
S CNT=CNT+1,MAGMSG(CNT)="DATE: "_DATE
S CNT=CNT+1,MAGMSG(CNT)="Installed by: "_$$GET1^DIQ(9.7,IDA,9,"E")
S CNT=CNT+1,MAGMSG(CNT)="Install Name: "_$$GET1^DIQ(9.7,IDA,.01,"E")
S DDATE=$$GET1^DIQ(9.7,IDA,51,"I")
S CNT=CNT+1,MAGMSG(CNT)="Distribution Date: "_$$FMTE^XLFDT(DDATE)
S XMSUB=XP_" INSTALLATION"
S XMID=$G(DUZ) S:'XMID XMID=.5
S XMY(XMID)=""
S:$G(MAGDUZ) XMY(MAGDUZ)=""
S XMSUB=$E(XMSUB,1,63)
D:$$PROD^XUPROD("1") ADDMG^MAGQBUT5(XMSUB,.XMY,PLACE)
D SENDMSG^XMXAPI(XMID,XMSUB,"MAGMSG",.XMY,,.XMZ,)
I $G(XMERR) M XMERR=^TMP("XMERR",$J) K XMERR
K MAGMSG
Q
TEST ;
N FDA
S FDA(4)="2006.8^.01^+1,^BP1"
S FDA(1)="2006.8^.04^+1,^1"
S FDA(3)="2006.8^50^+1,^ISW-PRICER"
S FDA(2)="2006.8^11^+1,^1"
D KVAL(.RESULTS,"Q",.FDA)
W !,"RESULTS: "_RESULTS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBUT4 10734 printed Sep 23, 2025@19:44:14 Page 2
MAGQBUT4 ;WOIFO/RMP,DAC,JSJ - BP Utilities ; Jun 16, 2022@14:42:24
+1 ;;3.0;IMAGING;**7,8,48,20,81,39,121,135,196,198,214,222,235,238,243,248,325,293,331,347**;Mar 19, 2002;Build 6
+2 ;; Per VA Directive 6402, 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 ;
+18 QUIT
VOKR(RESULT,VER) ; RPC for VOK [MAGQ VOK]
+1 ; P196 changed the way version checking works.
+2 ; we now allow older versions of the BP to run.
+3 NEW CLPATCH,SVRPATCH
+4 ; get client Patch number
+5 SET CLPATCH=$$TRIM($PIECE(VER,"P",2))
+6 ; These are allowable Clients.
+7 ; P293,P331,P347 drop P325 continue last 3
SET SVRPATCH=",293,331,347"
+8 ; if client patch is allowed Result = 1^...
+9 IF SVRPATCH[CLPATCH
SET RESULT="1^3.0P331"
+10 IF '$TEST
SET RESULT="0^3.0P331"
+11 QUIT
OLD ;
+1 SET VER="3.0P"_($$TRIM($PIECE(VER,"P",2)))
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 SET SLINE=$TEXT(+2)
+4 SET PNUM=$$TRIM($PIECE(SLINE,"**",2))
SET PNUM=$$TRIM($PIECE(PNUM,",",$LENGTH(PNUM,",")))
+5 SET CVERS=$$TRIM($PIECE(SLINE,";",3))_"P"_PNUM
+6 SET RESULT=$SELECT(CVERS=VER:1,1:0)_U_CVERS
+7 QUIT
+8 ;
CONV(ARR,ICT) ;Convert any single node array to FM Style multiple
+1 ; The node subscripts of ARR are ignored, and not retained
+2 ; i.e. ARR(34)=8
+3 ; ARR("BLUE")=9
+4 ; ARR("D")=10
+5 ; converts to
+6 ; ARR(1,0)=8
+7 ; ARR(2,0)=9
+8 ; ARR(3,0)=10
+9 NEW I,ARO
+10 SET ICT=0
SET I=""
+11 FOR
SET I=$ORDER(ARR(I))
if (I="")
QUIT
Begin DoDot:1
+12 SET ICT=ICT+1
+13 SET ARO(ICT,0)=ARR(I)
End DoDot:1
+14 KILL ARR
+15 MERGE ARR=ARO
+16 QUIT
MRGMULT(ARR,RT,RTDSC,CT) ;Merge the FM formatted array into a FM File
+1 ; multiple field.
+2 ; This isn't for general consumption.
+3 ; RT = FILE ROOT, RECORD NUMBER, NODE
+4 ; i.e. "^MAG(2006.034,44,1," -> 44 is the IEN of MAG(2006.34
+5 ; RTDSC is the 2nd piece of the 0 node of the multiple field.
+6 SET RT=$EXTRACT(RT,1,$LENGTH(RT)-1)_")"
+7 ; i.e. ^2006.341A^13^13
SET @RT@(0)=U_RTDSC_U_CT_U_CT
+8 MERGE @RT=ARR
+9 QUIT
DDLF(RESULTS,FILE,FIELD,FLAGS,ATTR) ;[MAG FLD ATT]
+1 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+2 KILL X
+3 NEW I
+4 DO FIELD^DID(FILE,FIELD,FLAGS,ATTR,"RESULTS","RESULTS")
+5 SET I=0
FOR
SET I=I+1
if '$DATA(RESULTS(ATTR,I))
QUIT
MERGE RESULTS(I)=RESULTS(ATTR,I)
+6 QUIT
DDFA(RESULTS) ;[MAG ATT LST]
+1 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+2 KILL X
+3 DO FIELDLST^DID(RESULTS)
+4 QUIT
DVAL(RESULTS,FILE,IENS,FIELD,FLAGS,VALUE) ;[MAG FIELD VALIDATE]
+1 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+2 KILL X
+3 IF FLAGS']""
SET FLAGS="EHU"
+4 DO VAL^DIE(FILE,IENS,FIELD,FLAGS,VALUE,.RESULT,"","MSG")
+5 IF RESULT=U
SET RESULTS="-1^"_$GET(MSG("DIERR","1","TEXT","1"))
+6 IF '$TEST
SET RESULTS=1_U_RESULT_U_$GET(RESULT(0))
+7 QUIT
KVAL(RESULTS,FLAGS,FDA) ;[MAG KEY VALIDATE]
+1 NEW TMP,DDRFDA
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 KILL X
+4 DO FDASET(.FDA,.DDRFDA)
+5 SET TMP=$$KEYVAL^DIE(FLAGS,"DDRFDA","MSG")
+6 SET RESULTS=$SELECT(TMP=1:1,1:"-1^"_$GET(MSG("DIERR","1","TEXT","1")))
+7 KILL DDRFDA,MSG
+8 QUIT
FDASET(DDRROOT,DDRFDA) ;
+1 NEW DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
+2 SET I=0
+3 FOR
SET I=$ORDER(DDRROOT(I))
if 'I
QUIT
SET X=DDRROOT(I)
Begin DoDot:1
+4 SET DDRFILE=$PIECE(X,U)
+5 SET DDRFIELD=$PIECE(X,U,2)
+6 SET DDRIEN=$PIECE(X,U,3)
+7 SET DDRVAL=$PIECE(X,U,4,99)
+8 DO FDA^DILF(DDRFILE,DDRIEN_$SELECT($EXTRACT(DDRIEN,$LENGTH(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
End DoDot:1
+9 QUIT
DHRPC(RESULTS,FNAME,FLOC) ;[MAG DIRHASH]
+1 NEW TMP
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 KILL X
+4 SET TMP=$$DIRHASH^MAGFILEB(FNAME,FLOC)
+5 SET RESULTS=$SELECT(TMP="":U,1:TMP)
+6 QUIT
GPACHX(PV) ; Get Package File Install History of Imaging
+1 NEW I,LCNT,MSG,PKG
+2 SET LCNT=0
+3 SET PV(0)="Version^Install Date"
+4 FOR PKG="IMAGING"
Begin DoDot:1
+5 NEW J,K,L,VERS,DATE,X,Y
+6 SET J=$ORDER(^DIC(9.4,"B",PKG,""))
if 'J
QUIT
+7 SET VERS=""
FOR
SET VERS=$ORDER(^DIC(9.4,J,22,"B",VERS))
if VERS=""
QUIT
Begin DoDot:2
+8 NEW MSG,TAR
+9 SET K=$ORDER(^DIC(9.4,J,22,"B",VERS,""))
+10 DO LIST^DIC(9.4901,","_K_","_J_",","@;.01;.02;.03","","","","","","","","TAR","MSG")
+11 if $DATA(MSG("DIERR"))
QUIT
+12 SET L=0
FOR
SET L=$ORDER(TAR("DILIST","ID",L))
if 'L
QUIT
Begin DoDot:3
+13 SET LCNT=LCNT+1
+14 SET PV(LCNT)=VERS_"P"_$PIECE(TAR("DILIST","ID",L,".01"),"^",1)
+15 SET X=$PIECE($PIECE(TAR("DILIST","ID",L,".02"),"^",1),"@",1)
+16 SET PV(LCNT)=PV(LCNT)_"^"_$SELECT(X["-1":"",1:X)
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
TRIM(X) ; remove both leading and trailing blanks
+1 NEW I,J
+2 FOR I=1:1:$LENGTH(X)
if $EXTRACT(X,I)'=" "
QUIT
+3 FOR J=$LENGTH(X):-1:I
if $EXTRACT(X,J)'=" "
QUIT
+4 QUIT $SELECT($EXTRACT(X,I,J)=" ":"",1:$EXTRACT(X,I,J))
+5 ;
QCNT(RESULT,PLC,QUE) ; [MAGQ QCNT] Called from MagQueManSet.pas and MagSiteParameters.pas
+1 NEW CNT,DA,CQ,IA,X
+2 SET X="ERR^MAGQBTM"
SET @^%ZOSF("TRAP")
+3 ;CQ=Current Queue Pointer(#2006.03)
+4 ;QP=Queue file pointer(#2006.031)
+5 ;CNT=Queue type total, IA=Not failed total
+6 SET IA=""
SET RESULT=0
+7 SET (CNT,IA)=0
SET DA=""
+8 SET QP=$SELECT($DATA(^MAGQUEUE(2006.031,"C",PLC,QUE)):$ORDER(^MAGQUEUE(2006.031,"C",PLC,QUE,"")),1:"")
+9 SET CQ=$SELECT('QP:0,1:$PIECE($GET(^MAGQUEUE(2006.031,QP,0)),U,2))
+10 FOR
SET DA=$ORDER(^MAGQUEUE(2006.03,"C",PLC,QUE,DA))
if 'DA
QUIT
Begin DoDot:1
+11 IF '$DATA(^MAGQUEUE(2006.03,DA,0))
KILL ^MAGQUEUE(2006.03,"C",PLC,QUE,DA)
QUIT
+12 SET CNT=CNT+1
+13 IF CQ<DA
SET IA=IA+1
+14 QUIT
End DoDot:1
+15 DO QPUP(PLC,QUE,CNT,CQ,IA,QP)
QUIT
+16 QUIT
+17 ;
QPUP(PLC,QUE,CNT,CQ,IA,QP) ;
+1 NEW IEN,DIC,VAL
+2 KILL VAL
+3 SET VAL(1)=PLC
SET VAL(2)=QUE
+4 SET QP=$SELECT(QP:QP,1:$$FIND1^DIC(2006.031,"","QX",.VAL,"C","",""))
+5 ;I IEN>0 D Q:IEN
+6 ;. S $P(^MAGQUEUE(2006.031,IEN,0),U,5)=CNT Q
+7 IF 'QP
Begin DoDot:1
+8 KILL DIE,FDA
+9 SET FDA(2006.031,"+1,",.01)=QUE
+10 SET FDA(2006.031,"+1,",.04)=PLC
+11 SET FDA(2006.031,"+1,",1)=CQ
+12 SET FDA(2006.031,"+1,",2)=IA
+13 SET FDA(2006.031,"+1,",3)=CNT
+14 DO UPDATE^DIE("U","FDA","","MAGQUP")
+15 KILL DIE,FDA
End DoDot:1
QUIT
+16 IF '$TEST
Begin DoDot:1
+17 KILL DIE,FDA
+18 SET FDA(2006.031,QP_",",.01)=QUE
+19 SET FDA(2006.031,QP_",",.04)=PLC
+20 SET FDA(2006.031,QP_",",1)=CQ
+21 SET FDA(2006.031,QP_",",2)=IA
+22 SET FDA(2006.031,QP_",",3)=CNT
+23 DO FILE^DIE("","FDA","MAGERR")
+24 KILL DIE,FDA
End DoDot:1
+25 QUIT
+26 ;
CPUD ;
+1 NEW PLC,INS,QUE
+2 SET (INS,PLC)=""
+3 FOR
SET INS=$ORDER(^MAG(2006.1,"B",INS))
if INS=""
QUIT
Begin DoDot:1
+4 SET PLC=$ORDER(^MAG(2006.1,"B",INS,""))
+5 SET QUE=""
FOR
SET QUE=$ORDER(^MAGQUEUE(2006.031,"C",PLC,QUE))
if QUE=""
QUIT
Begin DoDot:2
+6 DO QCNT^MAGQBUT4("",PLC,QUE)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
CNL(GL,IEN,NLC) ; Check Network Location
+1 NEW MAGREF,MAG0,MAG1,PLC
+2 SET NLC=NLC+1
+3 IF '$GET(IEN)
QUIT ""
+4 SET MAG0=$GET(@(GL_IEN_",0)"))
+5 ; get file from raid
SET MAGREF=+$PIECE(MAG0,"^",3)
+6 ; get file from jukebox
IF MAGREF=0
SET MAGREF=+$PIECE(MAG0,"^",5)
+7 IF 'MAGREF
QUIT ""
+8 IF '$DATA(^MAG(2005.2,MAGREF,0))
QUIT ""
+9 SET PLC=$PIECE($GET(^MAG(2005.2,MAGREF,0)),U,10)
+10 if 'PLC
QUIT ""
+11 SET PLC=$PIECE($GET(^MAG(2006.1,PLC,0)),U)
+12 QUIT $SELECT('PLC:"",1:PLC)
CNSP(GL,IEN,NMSP,NSC) ; Check NameSPace
+1 NEW NMSPC,MAG0,FNAM,INSTIEN
+2 SET NSC=NSC+1
+3 SET MAG0=$GET(@(GL_IEN_",0)"))
+4 SET FNAM=$PIECE(MAG0,U,2)
+5 SET NMSPC=$TRANSLATE($PIECE(FNAM,"."),"0123456789","")
+6 if NMSPC=""
QUIT ""
+7 SET INSTIEN=$SELECT($DATA(NMSP(NMSPC)):$ORDER(NMSP(NMSPC,"")),1:"")
+8 QUIT INSTIEN
NMSP(TMPA) ;
+1 NEW IEN,INS,TMP,I,J
+2 SET INS=""
FOR
SET INS=$ORDER(^MAG(2006.1,"B",INS))
if INS=""
QUIT
SET IEN=""
Begin DoDot:1
+3 SET IEN=$ORDER(^MAG(2006.1,"B",INS,IEN))
if IEN=""
QUIT
Begin DoDot:2
+4 SET TMP=","_$$UPPER^MAGQE4($$INIS^MAGQBPG2(IEN))_","
Begin DoDot:3
+5 FOR I=2:1
SET J=$PIECE(TMP,",",I)
if J=""
QUIT
SET TMPA(J,INS)=""
+6 QUIT
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
+7 SET J=""
FOR
SET J=$ORDER(TMPA(J))
if J=""
QUIT
SET INS=$ORDER(TMPA(J,""))
if ($ORDER(TMPA(J,INS))]"")
KILL TMPA(J)
+8 QUIT
CLRQ ; Clears the Queue file and Queue Pointer files
+1 NEW DA,DIK,FILE,IEN
+2 FOR FILE=2006.03,2006.031
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^MAGQUEUE(FILE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+4 SET DIK="^MAGQUEUE("_FILE_","
+5 SET DA=IEN
SET DA(1)=FILE
DO ^DIK
End DoDot:2
End DoDot:1
+6 KILL DIK,DA
+7 QUIT
+8 ; We add RPC to MAG WINDOWS Option this way instead of sending Option : MAG WINDOWS
+9 ; If we send MAG WINDOWS Option, the last one installed will overwrite others.
+10 ; ADDRPC copied from Patch 51, added the call "D MES^XPDUTL(" instead of "W !"
ADDRPC(RPCNAME,OPTNAME) ;
+1 NEW DA,DIC
+2 SET DIC="^DIC(19,"
SET DIC(0)=""
SET X=OPTNAME
DO ^DIC
+3 IF Y<0
Begin DoDot:1
+4 DO MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
+5 DO MES^XPDUTL("Cannot find Option: """_OPTNAME_""".")
+6 QUIT
End DoDot:1
QUIT
+7 IF '$DATA(^XWB(8994,"B",RPCNAME))
Begin DoDot:1
+8 DO MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
+9 DO MES^XPDUTL("Cannot find RPC: """_RPCNAME_""".")
+10 QUIT
End DoDot:1
QUIT
+11 SET DA(1)=+Y
+12 IF $DATA(^DIC(19,+Y,"RPC","B",$ORDER(^XWB(8994,"B",RPCNAME,""))))
Begin DoDot:1
+13 DO MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
+14 DO MES^XPDUTL("RPC: """_RPCNAME_""" is already a member of """_OPTNAME_""".")
+15 QUIT
End DoDot:1
QUIT
+16 SET DIC=DIC_DA(1)_",""RPC"","
+17 ; LAYGO should be allowed here
SET DIC(0)="L"
SET DLAYGO="19"
+18 SET X=RPCNAME
+19 DO ^DIC
+20 KILL DIC,D0,DLAYGO
+21 IF Y<0
Begin DoDot:1
+22 DO MES^XPDUTL("Cannot add RPC: """_RPCNAME_""" to Option: """_OPTNAME_""".")
+23 DO MES^XPDUTL("Cannot find RPC: """_RPCNAME_""".")
+24 QUIT
End DoDot:1
QUIT
+25 QUIT
INS(XP,DUZ,DATE,IDA) ;
+1 NEW CT,CNT,COM,D,D0,D1,D2,DDATE,DG,DIC,DICR,DIW,MAGMSG,ST,XMID,XMY,PLACE,XMSUB,XMZ
+2 SET PLACE=$ORDER(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
+3 DO GETENV^%ZOSV
+4 SET CNT=0
+5 SET CNT=CNT+1
SET MAGMSG(CNT)="PACKAGE INSTALL"
+6 SET CNT=CNT+1
SET MAGMSG(CNT)="SITE: "_$$KSP^XUPARAM("WHERE")
+7 SET CNT=CNT+1
SET MAGMSG(CNT)=" Production Account: "_$$PROD^XUPROD("1")
+8 SET CNT=CNT+1
SET MAGMSG(CNT)="PACKAGE: "_XP
+9 SET CNT=CNT+1
SET MAGMSG(CNT)="Version: "_$$VER^XPDUTL(XP)
+10 SET ST=$$GET1^DIQ(9.7,IDA,11,"I")
+11 SET CNT=CNT+1
SET MAGMSG(CNT)="Start time: "_$$FMTE^XLFDT(ST)
+12 SET CT=$$GET1^DIQ(9.7,IDA,17,"I")
if +CT'=CT
SET CT=$$NOW^XLFDT
+13 SET CNT=CNT+1
SET MAGMSG(CNT)="Completion time: "_$$FMTE^XLFDT(CT)
+14 SET CNT=CNT+1
SET MAGMSG(CNT)="Run time: "_$$FMDIFF^XLFDT(CT,ST,3)
+15 SET CNT=CNT+1
SET MAGMSG(CNT)="Environment: "_Y
+16 SET COM=$$GET1^DIQ(9.7,IDA,6,"I")
+17 SET CNT=CNT+1
SET MAGMSG(CNT)="FILE COMMENT: "_COM
+18 SET CNT=CNT+1
SET MAGMSG(CNT)="DATE: "_DATE
+19 SET CNT=CNT+1
SET MAGMSG(CNT)="Installed by: "_$$GET1^DIQ(9.7,IDA,9,"E")
+20 SET CNT=CNT+1
SET MAGMSG(CNT)="Install Name: "_$$GET1^DIQ(9.7,IDA,.01,"E")
+21 SET DDATE=$$GET1^DIQ(9.7,IDA,51,"I")
+22 SET CNT=CNT+1
SET MAGMSG(CNT)="Distribution Date: "_$$FMTE^XLFDT(DDATE)
+23 SET XMSUB=XP_" INSTALLATION"
+24 SET XMID=$GET(DUZ)
if 'XMID
SET XMID=.5
+25 SET XMY(XMID)=""
+26 if $GET(MAGDUZ)
SET XMY(MAGDUZ)=""
+27 SET XMSUB=$EXTRACT(XMSUB,1,63)
+28 if $$PROD^XUPROD("1")
DO ADDMG^MAGQBUT5(XMSUB,.XMY,PLACE)
+29 DO SENDMSG^XMXAPI(XMID,XMSUB,"MAGMSG",.XMY,,.XMZ,)
+30 IF $GET(XMERR)
MERGE XMERR=^TMP("XMERR",$JOB)
KILL XMERR
+31 KILL MAGMSG
+32 QUIT
TEST ;
+1 NEW FDA
+2 SET FDA(4)="2006.8^.01^+1,^BP1"
+3 SET FDA(1)="2006.8^.04^+1,^1"
+4 SET FDA(3)="2006.8^50^+1,^ISW-PRICER"
+5 SET FDA(2)="2006.8^11^+1,^1"
+6 DO KVAL(.RESULTS,"Q",.FDA)
+7 WRITE !,"RESULTS: "_RESULTS
+8 QUIT
+9 ;
