XPDUTL ;SFISC/RSD - KIDS utilities ;10/15/2008
;;8.0;KERNEL;**21,28,39,81,100,108,137,181,275,491,511,559,672**;Jul 10, 1995;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
Q
VERSION(X) ;Get current version from Package file, X=package name or
;package namespace
N I
S I=$$LKPKG(X) Q:'I ""
Q $P($G(^DIC(9.4,+I,"VERSION")),"^")
;
VER(X) ;returns version number from Build file, X=build name
Q:X["*" $P(X,"*",2)
Q $P(X," ",$L(X," "))
;
STATUS(IEN) ;returns status from Install File, IEN=Install File IEN
I '$D(^XPD(9.7,IEN,0)) Q -1
Q $P(^XPD(9.7,IEN,0),U,9)
;
PKG(X) ;returns package name from Build file, X=build name
Q $S(X["*":$P(X,"*"),1:$P(X," ",1,$L(X," ")-1))
;
LAST(PKG,VER,REL) ;returns last patch applied for a Package, PATCH^DATE
;PKG=package name, VER=version number, REL[optional]=1 if you want released patches only
;Patch includes Seq # if Released
N PKGIEN,VERIEN,LATEST,PATCH,SUBIEN,Y
S PKGIEN=$$LKPKG($G(PKG)) Q:'PKGIEN -1
I $G(VER)="" S VER=$P($G(^DIC(9.4,PKGIEN,"VERSION")),"^") Q:'VER -1
S VERIEN=$O(^DIC(9.4,PKGIEN,22,"B",VER,"")) Q:'VERIEN -1
S LATEST=-1,PATCH=-1,SUBIEN=0
F S SUBIEN=$O(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN)) Q:SUBIEN'>0 S Y=$G(^(SUBIEN,0)) D:$P(Y,U,2)>LATEST
. I $G(REL),$P(Y,U)'["SEQ #" Q ;released only, must contain SEQ
. S LATEST=$P(Y,U,2),PATCH=$P(Y,U)
Q PATCH_U_LATEST
;
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn ; p672 change 1.3N to 1.4N
Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0
N %,I,J
S I=$$LKPKG($P(X,"*")) Q:'I 0
S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
;check if patch is just a number
Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
S %=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
Q $S(%="":0,1:(X=+%))
;
INSTALDT(INSTALL,RESULT) ;returns number of installs, 0 if not installed or doesn't exist
;input: INSTALL=required, Install name; RESULT=required, passed by reference
;output: RESULT=number in RESULT array; RESULT(FM date/time)=TEST# ^ SEQ#
N CNT,DATE,IEN
K RESULT
S (IEN,CNT,RESULT)=0
I $G(INSTALL)="" Q 0
F S IEN=$O(^XPD(9.7,"B",INSTALL,IEN)) Q:'IEN D
.S DATE=$P($G(^XPD(9.7,IEN,1)),U,3) Q:'DATE
.S RESULT(DATE)=$G(^XPD(9.7,IEN,6)),CNT=CNT+1
S RESULT=CNT
Q CNT
;
NEWCP(XPD,XPDC,XPDP) ;create new check point, returns 0=error or ien
;XPD=name, XPDC=call back, XPDP=parameters
Q:$G(XPD)="" 0
N %,XPDI,XPDJ,XPDF,XPDY
;XPDCP="INI"=Pre-init, "INIT"=Post-init
S XPDI=$S(XPDCP="INIT":9.716,1:9.713)
S %=$$FIND1^DIC(XPDI,","_XPDA_",","X",XPD) Q:% %
S XPDF="+1,"_XPDA_",",XPDJ(XPDI,XPDF,.01)=XPD
S:$D(XPDC) XPDJ(XPDI,XPDF,2)=XPDC
S:$D(XPDP) XPDJ(XPDI,XPDF,3)=XPDP
D UPDATE^DIE("","XPDJ","XPDY")
Q $G(XPDY(1))
;
UPCP(XPD,XPDP) ;update check point, returns 0=error or ien
;XPD=name, XPDP=parameters
N XPDI,XPDJ,XPDF,XPDY
;XPDCP="INI"=Pre-init, "INIT"=Post-init
S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
Q:'XPDY 0
S XPDF=XPDY_","_XPDA_","
S:$D(XPDP) XPDJ(XPDI,XPDF,3)=XPDP
D FILE^DIE("","XPDJ")
Q XPDY
;
COMCP(XPD) ;complete check point, returns 0=error or date/time
;XPD=name
N XPDD,XPDI,XPDJ,XPDY
S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
Q:'XPDY 0
S XPDD=$$NOW^XLFDT,XPDJ(XPDI,XPDY_","_XPDA_",",1)=XPDD
D FILE^DIE("","XPDJ")
Q XPDD
;
VERCP(XPD) ;verify check point, returns 1=completed, 0=not
;-1=doesn't exist
;XPD=name
N XPDI,XPDY
S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
Q:'XPDY -1
Q ''$$GET1^DIQ(XPDI,XPDY_","_XPDA_",",1,"I")
;
PARCP(XPD,XPDF) ;returns parameters of check point
;XPD=name, XPDF="PRE"
N XPDI,XPDY
I $G(XPDF)="PRE" N XPDCP S XPDCP="INI"
S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
Q:'XPDY 0
Q $$GET1^DIQ(XPDI,XPDY_","_XPDA_",",3,"I")
;
CURCP(XPDF) ;returns current check point
;XPDF flag - 0=externel, 1=internal
Q $S($G(XPDF):XPDCHECK,1:XPDCHECK(0))
;
WP(X) ;X=global ref
N %
Q:'$D(@X)
F %=1:1 Q:'$D(@X@(%)) W !,@X@(%)
Q:'$G(XPDA) D WP^DIE(9.7,XPDA_",",20,"A",X)
Q
MES(X) ;record message, X=message or an array passed by reference
N %
I $D(X)#2 S %=X K X S X(1)=%
;write message
F %=1:1 Q:'$D(X(%)) W !,X(%)
Q:'$G(XPDA) D WP^DIE(9.7,XPDA_",",20,"A","X")
Q
BMES(X) ;add blank line before message
N %
I $D(X)#2 S %=X K X S X(1)=" ",X(2)=%
D MES(.X)
Q
RTNUP(X,Y) ;update routine action, X=routine, Y=action
;actions: 1=delete, 2=skip
N %
;set action to Y
Q:'$G(Y)!'$D(^XTMP("XPDI",$G(XPDA),"RTN",X)) 0 S $P(^(X),U)=+Y
Q 1
;get Build ien
S Y=$O(^XTMP("XPDI",XPDA,"BLD",0))
;remove checksum when updating action, since action can only be
;delete or skip, not sure if we want to do this
S:$P(%,U,2) $P(^XTMP("XPDI",XPDA,"BLD",Y,"KRN",9.8,"NM",$P(%,U,2),0),U,4)=""
Q 1
;
RTNLOG(X) ;Enter/Update routine in the Routine File
N Y,FDA,IEN
S Y=$O(^DIC(9.8,"B",X,0))
I Y'>0 S IEN="?+1,",FDA(9.8,IEN,1)="R"
I Y>0 S IEN=(+Y)_","
S FDA(9.8,IEN,.01)=X,FDA(9.8,IEN,7.4)=$$NOW^XLFDT
D UPDATE^DIE("","FDA","IEN")
Q
;
DICCP(X) ;lookup check point, returns ien or 0
Q:$G(X)="" 0
;if they pass ien, fail if can't find
I X=+X S Y=X Q:'$D(^XPD(9.7,XPDA,XPDCP,Y,0)) 0
E S Y=$$FIND1^DIC(XPDI,","_XPDA_",","X",X)
Q Y
;
PRODE(XPDN,XPD) ;enable/disable protocols, return 1 for success
;XPDN=protocol name, XPD=1-enable, 0-disable
Q:$G(XPDN)="" 0
S XPD=+$G(XPD)
D KIDS^XQOO1($P(XPDSET,U,2),101,XPDN,.XPD)
Q $S(XPD<0:0,1:1)
;
OPTDE(XPDN,XPD) ;enable/disable options, return 1 for success
;XPDN=protocol name, XPD=1-enable, 0-disable
Q:$G(XPDN)="" 0
S XPD=+$G(XPD)
D KIDS^XQOO1($P(XPDSET,U,2),19,XPDN,.XPD)
Q $S(XPD<0:0,1:1)
;
BUILD(XPDN,XPD) ;check if a build exists, return 1 for success
;XPDN=build name, XPD=1-exist, 0-been removed
S XPD=$D(XPDT("NM",XPDN))
Q XPD
;
MAILGRP(X) ;Return mail group for package, X=package name or namespace
N XD,DIC,DR,DA,DIQ
S DA=$$LKPKG(X) Q:'DA ""
S DIC="^DIC(9.4,",DR=1938,DIQ="XD" D EN^DIQ1
Q $S($G(XD(9.4,DA,1938))="":"",1:"G."_XD(9.4,DA,1938))
;
LKPKG(X) ;Return Package ien, X=package name or namespace
Q:$G(X)="" 0
N DA
I $L(X)<5 D Q:DA +DA
.S DA=$O(^DIC(9.4,"C",X,0))
.S:'DA DA=$O(^DIC(9.4,"C2",X,0))
I $L(X)>3 S DA=$O(^DIC(9.4,"B",X,0))
Q +DA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDUTL 6335 printed Oct 16, 2024@18:05:23 Page 2
XPDUTL ;SFISC/RSD - KIDS utilities ;10/15/2008
+1 ;;8.0;KERNEL;**21,28,39,81,100,108,137,181,275,491,511,559,672**;Jul 10, 1995;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
VERSION(X) ;Get current version from Package file, X=package name or
+1 ;package namespace
+2 NEW I
+3 SET I=$$LKPKG(X)
if 'I
QUIT ""
+4 QUIT $PIECE($GET(^DIC(9.4,+I,"VERSION")),"^")
+5 ;
VER(X) ;returns version number from Build file, X=build name
+1 if X["*"
QUIT $PIECE(X,"*",2)
+2 QUIT $PIECE(X," ",$LENGTH(X," "))
+3 ;
STATUS(IEN) ;returns status from Install File, IEN=Install File IEN
+1 IF '$DATA(^XPD(9.7,IEN,0))
QUIT -1
+2 QUIT $PIECE(^XPD(9.7,IEN,0),U,9)
+3 ;
PKG(X) ;returns package name from Build file, X=build name
+1 QUIT $SELECT(X["*":$PIECE(X,"*"),1:$PIECE(X," ",1,$LENGTH(X," ")-1))
+2 ;
LAST(PKG,VER,REL) ;returns last patch applied for a Package, PATCH^DATE
+1 ;PKG=package name, VER=version number, REL[optional]=1 if you want released patches only
+2 ;Patch includes Seq # if Released
+3 NEW PKGIEN,VERIEN,LATEST,PATCH,SUBIEN,Y
+4 SET PKGIEN=$$LKPKG($GET(PKG))
if 'PKGIEN
QUIT -1
+5 IF $GET(VER)=""
SET VER=$PIECE($GET(^DIC(9.4,PKGIEN,"VERSION")),"^")
if 'VER
QUIT -1
+6 SET VERIEN=$ORDER(^DIC(9.4,PKGIEN,22,"B",VER,""))
if 'VERIEN
QUIT -1
+7 SET LATEST=-1
SET PATCH=-1
SET SUBIEN=0
+8 FOR
SET SUBIEN=$ORDER(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN))
if SUBIEN'>0
QUIT
SET Y=$GET(^(SUBIEN,0))
if $PIECE(Y,U,2)>LATEST
Begin DoDot:1
+9 ;released only, must contain SEQ
IF $GET(REL)
IF $PIECE(Y,U)'["SEQ #"
QUIT
+10 SET LATEST=$PIECE(Y,U,2)
SET PATCH=$PIECE(Y,U)
End DoDot:1
+11 QUIT PATCH_U_LATEST
+12 ;
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn ; p672 change 1.3N to 1.4N
+1 if X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N
QUIT 0
+2 NEW %,I,J
+3 SET I=$$LKPKG($PIECE(X,"*"))
if 'I
QUIT 0
+4 SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))
SET X=$PIECE(X,"*",3)
if 'J
QUIT 0
+5 ;check if patch is just a number
+6 if $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))
QUIT 1
+7 SET %=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
+8 QUIT $SELECT(%="":0,1:(X=+%))
+9 ;
INSTALDT(INSTALL,RESULT) ;returns number of installs, 0 if not installed or doesn't exist
+1 ;input: INSTALL=required, Install name; RESULT=required, passed by reference
+2 ;output: RESULT=number in RESULT array; RESULT(FM date/time)=TEST# ^ SEQ#
+3 NEW CNT,DATE,IEN
+4 KILL RESULT
+5 SET (IEN,CNT,RESULT)=0
+6 IF $GET(INSTALL)=""
QUIT 0
+7 FOR
SET IEN=$ORDER(^XPD(9.7,"B",INSTALL,IEN))
if 'IEN
QUIT
Begin DoDot:1
+8 SET DATE=$PIECE($GET(^XPD(9.7,IEN,1)),U,3)
if 'DATE
QUIT
+9 SET RESULT(DATE)=$GET(^XPD(9.7,IEN,6))
SET CNT=CNT+1
End DoDot:1
+10 SET RESULT=CNT
+11 QUIT CNT
+12 ;
NEWCP(XPD,XPDC,XPDP) ;create new check point, returns 0=error or ien
+1 ;XPD=name, XPDC=call back, XPDP=parameters
+2 if $GET(XPD)=""
QUIT 0
+3 NEW %,XPDI,XPDJ,XPDF,XPDY
+4 ;XPDCP="INI"=Pre-init, "INIT"=Post-init
+5 SET XPDI=$SELECT(XPDCP="INIT":9.716,1:9.713)
+6 SET %=$$FIND1^DIC(XPDI,","_XPDA_",","X",XPD)
if %
QUIT %
+7 SET XPDF="+1,"_XPDA_","
SET XPDJ(XPDI,XPDF,.01)=XPD
+8 if $DATA(XPDC)
SET XPDJ(XPDI,XPDF,2)=XPDC
+9 if $DATA(XPDP)
SET XPDJ(XPDI,XPDF,3)=XPDP
+10 DO UPDATE^DIE("","XPDJ","XPDY")
+11 QUIT $GET(XPDY(1))
+12 ;
UPCP(XPD,XPDP) ;update check point, returns 0=error or ien
+1 ;XPD=name, XPDP=parameters
+2 NEW XPDI,XPDJ,XPDF,XPDY
+3 ;XPDCP="INI"=Pre-init, "INIT"=Post-init
+4 SET XPDI=$SELECT(XPDCP="INIT":9.716,1:9.713)
SET XPDY=$$DICCP($GET(XPD))
+5 if 'XPDY
QUIT 0
+6 SET XPDF=XPDY_","_XPDA_","
+7 if $DATA(XPDP)
SET XPDJ(XPDI,XPDF,3)=XPDP
+8 DO FILE^DIE("","XPDJ")
+9 QUIT XPDY
+10 ;
COMCP(XPD) ;complete check point, returns 0=error or date/time
+1 ;XPD=name
+2 NEW XPDD,XPDI,XPDJ,XPDY
+3 SET XPDI=$SELECT(XPDCP="INIT":9.716,1:9.713)
SET XPDY=$$DICCP($GET(XPD))
+4 if 'XPDY
QUIT 0
+5 SET XPDD=$$NOW^XLFDT
SET XPDJ(XPDI,XPDY_","_XPDA_",",1)=XPDD
+6 DO FILE^DIE("","XPDJ")
+7 QUIT XPDD
+8 ;
VERCP(XPD) ;verify check point, returns 1=completed, 0=not
+1 ;-1=doesn't exist
+2 ;XPD=name
+3 NEW XPDI,XPDY
+4 SET XPDI=$SELECT(XPDCP="INIT":9.716,1:9.713)
SET XPDY=$$DICCP($GET(XPD))
+5 if 'XPDY
QUIT -1
+6 QUIT ''$$GET1^DIQ(XPDI,XPDY_","_XPDA_",",1,"I")
+7 ;
PARCP(XPD,XPDF) ;returns parameters of check point
+1 ;XPD=name, XPDF="PRE"
+2 NEW XPDI,XPDY
+3 IF $GET(XPDF)="PRE"
NEW XPDCP
SET XPDCP="INI"
+4 SET XPDI=$SELECT(XPDCP="INIT":9.716,1:9.713)
SET XPDY=$$DICCP($GET(XPD))
+5 if 'XPDY
QUIT 0
+6 QUIT $$GET1^DIQ(XPDI,XPDY_","_XPDA_",",3,"I")
+7 ;
CURCP(XPDF) ;returns current check point
+1 ;XPDF flag - 0=externel, 1=internal
+2 QUIT $SELECT($GET(XPDF):XPDCHECK,1:XPDCHECK(0))
+3 ;
WP(X) ;X=global ref
+1 NEW %
+2 if '$DATA(@X)
QUIT
+3 FOR %=1:1
if '$DATA(@X@(%))
QUIT
WRITE !,@X@(%)
+4 if '$GET(XPDA)
QUIT
DO WP^DIE(9.7,XPDA_",",20,"A",X)
+5 QUIT
MES(X) ;record message, X=message or an array passed by reference
+1 NEW %
+2 IF $DATA(X)#2
SET %=X
KILL X
SET X(1)=%
+3 ;write message
+4 FOR %=1:1
if '$DATA(X(%))
QUIT
WRITE !,X(%)
+5 if '$GET(XPDA)
QUIT
DO WP^DIE(9.7,XPDA_",",20,"A","X")
+6 QUIT
BMES(X) ;add blank line before message
+1 NEW %
+2 IF $DATA(X)#2
SET %=X
KILL X
SET X(1)=" "
SET X(2)=%
+3 DO MES(.X)
+4 QUIT
RTNUP(X,Y) ;update routine action, X=routine, Y=action
+1 ;actions: 1=delete, 2=skip
+2 NEW %
+3 ;set action to Y
+4 if '$GET(Y)!'$DATA(^XTMP("XPDI",$GET(XPDA),"RTN",X))
QUIT 0
SET $PIECE(^(X),U)=+Y
+5 QUIT 1
+6 ;get Build ien
+7 SET Y=$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
+8 ;remove checksum when updating action, since action can only be
+9 ;delete or skip, not sure if we want to do this
+10 if $PIECE(%,U,2)
SET $PIECE(^XTMP("XPDI",XPDA,"BLD",Y,"KRN",9.8,"NM",$PIECE(%,U,2),0),U,4)=""
+11 QUIT 1
+12 ;
RTNLOG(X) ;Enter/Update routine in the Routine File
+1 NEW Y,FDA,IEN
+2 SET Y=$ORDER(^DIC(9.8,"B",X,0))
+3 IF Y'>0
SET IEN="?+1,"
SET FDA(9.8,IEN,1)="R"
+4 IF Y>0
SET IEN=(+Y)_","
+5 SET FDA(9.8,IEN,.01)=X
SET FDA(9.8,IEN,7.4)=$$NOW^XLFDT
+6 DO UPDATE^DIE("","FDA","IEN")
+7 QUIT
+8 ;
DICCP(X) ;lookup check point, returns ien or 0
+1 if $GET(X)=""
QUIT 0
+2 ;if they pass ien, fail if can't find
+3 IF X=+X
SET Y=X
if '$DATA(^XPD(9.7,XPDA,XPDCP,Y,0))
QUIT 0
+4 IF '$TEST
SET Y=$$FIND1^DIC(XPDI,","_XPDA_",","X",X)
+5 QUIT Y
+6 ;
PRODE(XPDN,XPD) ;enable/disable protocols, return 1 for success
+1 ;XPDN=protocol name, XPD=1-enable, 0-disable
+2 if $GET(XPDN)=""
QUIT 0
+3 SET XPD=+$GET(XPD)
+4 DO KIDS^XQOO1($PIECE(XPDSET,U,2),101,XPDN,.XPD)
+5 QUIT $SELECT(XPD<0:0,1:1)
+6 ;
OPTDE(XPDN,XPD) ;enable/disable options, return 1 for success
+1 ;XPDN=protocol name, XPD=1-enable, 0-disable
+2 if $GET(XPDN)=""
QUIT 0
+3 SET XPD=+$GET(XPD)
+4 DO KIDS^XQOO1($PIECE(XPDSET,U,2),19,XPDN,.XPD)
+5 QUIT $SELECT(XPD<0:0,1:1)
+6 ;
BUILD(XPDN,XPD) ;check if a build exists, return 1 for success
+1 ;XPDN=build name, XPD=1-exist, 0-been removed
+2 SET XPD=$DATA(XPDT("NM",XPDN))
+3 QUIT XPD
+4 ;
MAILGRP(X) ;Return mail group for package, X=package name or namespace
+1 NEW XD,DIC,DR,DA,DIQ
+2 SET DA=$$LKPKG(X)
if 'DA
QUIT ""
+3 SET DIC="^DIC(9.4,"
SET DR=1938
SET DIQ="XD"
DO EN^DIQ1
+4 QUIT $SELECT($GET(XD(9.4,DA,1938))="":"",1:"G."_XD(9.4,DA,1938))
+5 ;
LKPKG(X) ;Return Package ien, X=package name or namespace
+1 if $GET(X)=""
QUIT 0
+2 NEW DA
+3 IF $LENGTH(X)<5
Begin DoDot:1
+4 SET DA=$ORDER(^DIC(9.4,"C",X,0))
+5 if 'DA
SET DA=$ORDER(^DIC(9.4,"C2",X,0))
End DoDot:1
if DA
QUIT +DA
+6 IF $LENGTH(X)>3
SET DA=$ORDER(^DIC(9.4,"B",X,0))
+7 QUIT +DA
