DVBAUDU3 ;ALB/CP - API Calls Routine #3 for programmers ; 4/12/18 7:28pm
;;2.7;AMIE;**256**;;Build 19
; Per VHA Directive 6402 this routine should not be modified5
; $$FIND1^DIC ; IA # 2051
; $$GET1^DIQ ; IA # 2056
; ^%ZOSF( ; IA #10096
; ^DISV ; IA # 510
; ^XPD(9.6, ; IA # 1125
;
;
Q ; You must execute a supported entry point
;
AUDIT ; Interactive version of AUDITBLD or AUDITSPC designed to
; build/initiate or delete option audits for either a BUILD
; or NAMESPACE (See TYPE input var.)
;
N DVBDRFAULT,DVBFLAG1
; ZEXCEPT: DUZ
;
S DVBFLAG1=1 ; 1st time flag
;
AUDIT1 ; Return here when the user wants to start over
;
N DVBACTION,DVBSOURCE,DVBQUIT
;
S DVBQUIT=0
;
; *** Prompt for 'Which Option Audit ACTION' ***
;
S DVBDRFAULT=$G(^DISV(DUZ,$T(+0),"DVBACTION"),1) I DVBFLAG1=0 D ;
. S DVBDRFAULT="" ; No DVBDRFAULT allows an easy exit on the 2nd time thru
W !
W !,"Which Option Audit ACTION"
W !,?3,"1) Create Option Audits"
W !,?3,"2) Delete Existing Option Audits"
S DVBACTION=$$ASKNUM^DVBAUDASK1(2,DVBDRFAULT,,2) G:DVBQUIT AUDITEX
I DVBACTION="^" S DVBQUIT=1 G AUDITEX
S ^DISV(DUZ,$T(+0),"DVBACTION")=DVBACTION
S DVBACTION=$S(DVBACTION=1:"CREATE",1:"DELETE")
S DVBFLAG1=0
;
; *** Prompt for 'Which Option Audit SOURCE' ***
;
S DVBDRFAULT=$G(^DISV(DUZ,$T(+0),"DVBSOURCE"),1)
W !
W !,"Which Option Audit SOURCE"
W !,?3,"1) Source is a KIDS BUILD"
W !,?3,"2) Source is a NAMESPACE"
S DVBSOURCE=$$ASKNUM^DVBAUDASK1(2,DVBDRFAULT,,2) G:DVBQUIT AUDIT1
I DVBSOURCE="^" S DVBQUIT=1 G AUDIT1 ; Start over
S ^DISV(DUZ,$T(+0),"DVBSOURCE")=DVBSOURCE
S DVBSOURCE=$S(DVBSOURCE=1:"BUILD",1:"NAMESPACE")
;
I DVBSOURCE="BUILD" W ! D ;
. N DVBASK,DVBBUILD,DVBMSG,DVBOPTYPE
. D BUILD^DVBAUDDIC Q:DVBQUIT
. D SELTYPE^DVBAUDDIR($T(+0)) Q:DVBQUIT
. W ! S DVBMSG="Is it OK to implement these changes"
. I $$ASKYESNO^DVBAUDASK1(DVBMSG,"NO")'="Y" S DVBQUIT=1 Q
. D AUDITBLD(DVBBUILD,DVBACTION,DVBOPTYPE)
G:DVBQUIT AUDIT1 ; Start over
;
I DVBSOURCE="NAMESPACE" D ;
. N DVBASK,DVBNAMSPC,DVBMSG,DVBOPTYPE
. D SELWILD^DVBAUDU1(2) Q:DVBQUIT
. D SELTYPE^DVBAUDDIR($T(+0)) Q:DVBQUIT
. W ! S DVBMSG="Is it OK to implement these changes"
. I $$ASKYESNO^DVBAUDASK1(DVBMSG,"NO")'="Y" S DVBQUIT=1 Q
. D AUDITSPC(DVBNAMSPC,DVBACTION,DVBOPTYPE)
G:DVBQUIT AUDIT1 ; Start over
;
;
AUDITEX ; Exit the AUDIT api
;
Q ; Quit AUDIT & AUDIT1
;
AUDITBLD(DVBXPDNM,DVBACTION,DVBOPTYPES) ; Stuff 'D AUDIT^DVBAUDOA' into ENTRY ACTION
; of every eligible OPTION for a DVBXPDNM of the KIDS Build.
N X,DVBOPTNAME,DVBXPDIEN,DVBXPDTYPE
; ZEXCEPT: U
;
S X="DVBAUDOA" X ^%ZOSF("TEST") Q:'$T
;
; Validate that the following files exist:
Q:'$$FIND1^DIC(1,"","BO","AMIE OPTION AUDIT EVENT")
Q:'$$FIND1^DIC(1,"","BO","AMIE AUDIT SUMMARY BY OPTION")
;
;
; Validate input variable ACTION
S DVBACTION=$G(DVBACTION,"CREATE")
I DVBACTION'="CREATE",DVBACTION'="DELETE" Q ; Must be 'CREATE' or 'DELETE'
; Validate input variable DVBXPDNM
Q:$G(DVBXPDNM)="" ; Quit if DVBXPDNM is not defined
S DVBXPDIEN=+$$FIND1^DIC(9.6,"","BO",DVBXPDNM) Q:DVBXPDIEN=0 ; IEN?
;
; Validate input variable DVBOPTYPES
S DVBOPTYPES=$G(DVBOPTYPES,$S(DVBACTION="CREATE":"AEIPRXSC",1:"AEIMPRXSC"))
Q:'$$OPTYPEOK(DVBOPTYPES)
;
N DVBFLAGMP ; To avoid too many 'Press <Enter> to continue' prompts
S DVBXPDTYPE=$$GET1^DIQ(9.6,DVBXPDIEN,2)
I DVBXPDTYPE="MULTI-PACKAGE" D BUNDLE(DVBXPDIEN,DVBOPTYPES,DVBACTION) Q
;
Q:DVBXPDTYPE="GLOBAL PACKAGE" ; Quit, if this is a GLOBAL PACKAGE
; Quit, if there are no OPTION components in this SINGLE PACKAGE
Q:'$P($G(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM",0)),U,4)
;
;
N DVBTARGET ; Output array of OPTION candidates for Option Auditing
S DVBOPTNAME=""
F S DVBOPTNAME=$O(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM","B",DVBOPTNAME)) Q:DVBOPTNAME="" D ;
. N DVBXPDIEN2
. S DVBXPDIEN2=0
. F S DVBXPDIEN2=$O(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM","B",DVBOPTNAME,DVBXPDIEN2)) Q:'DVBXPDIEN2="" D
. . N DVBACTION,DVBIEN19
. . ;
. . S DVBIEN19=$$FIND1^DIC(19,"","BO",DVBOPTNAME) Q:'DVBIEN19
. . ;
. . S DVBACTION=$$GET1^DIQ(9.68,XPDIEN2_",19,"_XPDIEN_",",.03)
. . Q:DVBACTION="DELETE AT SITE"
. . ;
. . ; Place the option in the DVBTARGET array
. . S DVBTARGET(DVBOPTNAME,DVBIEN19)=DVBXPDIEN2
Q:$O(DVBTARGET(""))="" ; No DVBTARGET option candidates found
;
I DVBACTION="CREATE" D BUILD^DVBAUDU3S("AUDITBLD",.DVBTARGET,DVBOPTYPES)
I DVBACTION="DELETE" D DELETE^DVBAUDU3S("AUDITBLD",.DVBTARGET,DVBOPTYPES)
;
Q ; Quit AUDITBLD
;
AUDITSPC(DVBNAMESPC,DVBACTION,DVBOPTYPES) ; Stuff 'D AUDIT^DVBAUDOA' into ENTRY ACTION
;
N X
; ZEXCEPT: DVBFLAG1,U
;
; IF the DVBAUDOA routine is not loaded in this environment
; exit the API.
S X="DVBAUDOA" X ^%ZOSF("TEST") Q:'$T
;
; Validate that the following files exist:
Q:'$$FIND1^DIC(1,"","BO","AMIE OPTION AUDIT EVENT")
Q:'$$FIND1^DIC(1,"","BO","AMIE AUDIT SUMMARY BY OPTION")
;
; Validate input variable DVBNAMESPC (namespace)
; DVBNAMESPC must be at least 1 characters in length & not null
Q:$L(DVBNAMESPC)<1
; Attach wildcard (*) to namespace if it doesn't exist
S:$E(DVBNAMESPC,$L(DVBNAMESPC),$L(DVBNAMESPC))'="*" DVBNAMESPC=DVBNAMESPC_"*"
;
; Validate input variable DVBACTION
S DVBACTION=$G(DVBACTION,"CREATE")
I DVBACTION'="CREATE",DVBACTION'="DELETE" Q ; Must be 'CREATE' or 'DELETE'
;
; Validate input variable DVBOPTYPES
S DVBOPTYPES=$G(DVBOPTYPES,$S(DVBACTION="CREATE":"AEIPRXSC",1:"AEIMPRXSC"))
I '$$OPTYPEOK(DVBOPTYPES) D Q
. W !?1,"Invalid Option TYPE encountered -- terminating processing..."
;
;Build DVBTARGET(DVBOPTNAME,DVBIEN19)="" array of Options based upon DVBNAMESPC
;
N DVBFLAG1,DVBTARGET
S DVBFLAG1=1 ; 1st time flag
D OPTBUILD^DVBAUDU2($T(+0),2,DVBOPTYPES,DVBNAMESPC) ; Bld DVBTARGET array
;
I DVBACTION="DELETE" D DELETE^DVBAUDU3S("AUDITSPC",.DVBTARGET,DVBOPTYPES)
I DVBACTION="DELETE",$O(DVBTARGET(""))="" D ;
. D MESSAGE^DVBAUDU3S("AUDITSPC")
. D CONTINUE^DVBAUDPRT1(2,"R")
Q:DVBACTION="DELETE" ; Remainder of code is for ACTION 'CREATE'
;
; At this point we know the ACTION="CREATE"
N DVBCNT,DVBMAXLEN,DVBOPTNAME,DVBQUIT
;
S DVBCNT("SEL")=0 ; Number of DVBTARGET options selected for auditing
S DVBCNT("CRE")=0 ; Number of DVBTARGET options where audits were created
S DVBQUIT=0 ;.... Quit/terminate flag, initialized to off (0)
S DVBMAXLEN=229 ;.. Maximum length of ENTRY ACTION and EXIT ACTION
S DVBOPTNAME=0
F S DVBOPTNAME=$O(DVBTARGET(DVBOPTNAME)) Q:(DVBOPTNAME="")!DVBQUIT D ;
. N DIERR,DVBENACTION,DVBEXACTION,DVBIEN19,DVBERRMSG
. S DVBIEN19=0 ; DVBIEN19 is the IEN of OPTION file #19
. F S DVBIEN19=$O(DVBTARGET(DVBOPTNAME,DVBIEN19)) Q:'DVBIEN19 D ;
. . N DIERR,DVBENACTION,DVBEXACTION,DVBOPT,DVBERRMSG
. . D OPTION^DVBAUDDIQ(DVBIEN19)
. . S DVBENACTION("BEF")=DVBOPT("ENTRYACTION") ; Capture ENTRY ACTION
. . S DVBEXACTION("BEF")=DVBOPT("EXITACTION") ;. Capture EXIT ACTION
. . ;
. . ; Prevent ENTRY ACTION from exceeding maximum length, display msg
. . I $L(DVBENACTION("BEF"))>DVBMAXLEN Q
. . ; Prevent EXIT ACTION from exceeding maximum length, display msg.
. . I $L(DVBEXACTION("BEF"))>DVBMAXLEN Q
. . ;
. . S DVBENACTION("AFT")="D AUDIT^DVBAUDOA" I DVBENACTION("BEF")'="" D ;
. . . S DVBENACTION("AFT")="D AUDIT^DVBAUDOA "_DVBENACTION("BEF")
. . ;
. . D EXITACT^DVBAUDU3S ; Format EXIT ACTION in DVBEXACTION("AFT")
. . ;
. . ; Edit the Option's ENTRY and EXIT ACTION fields
. . I DVBFLAG1=1,$O(DVBTARGET(""))]"" D MESSAGE^DVBAUDU3S("AUDITSPC")
. . S DVBCNT("SEL")=DVBCNT("SEL")+1 ; Number of options selected for audit
. . W !?3,$J(DVBCNT("SEL"),3),". ",?8,DVBOPTNAME
. . W ?40,$$GET1^DIQ(19,DVBIEN19,4,"E",,"DVBERRMSG")
. . D ENTRYACT^DVBAUDDIE(DVBIEN19,.DVBENACTION,.DVBEXACTION)
. . W ?57 W:DVBQUIT=0 "[Option Audit Added]"
. . I DVBQUIT=1 W ! Q
. . D DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","AUDITSPC^"_$T(+0)) Q:DVBQUIT
. . D SUMSTUB^DVBAUDDIE(DVBIEN19) ; Create the SUMMARY record stub
. . S DVBCNT("CRE")=DVBCNT("CRE")+1 ; Number of option audits created
. . Q:DVBQUIT
. S DVBQUIT=0
;
;
; If no DVBTARGET array of option audit candidates, display msg & quit
I $O(DVBTARGET(""))="" D MESSAGE^DVBAUDU3S("AUDITSPC") Q
;
W !
;
; If more than 1 eligible option was presented, display statistics
I DVBCNT("SEL")>1 D ;
. W !,"Number of options selected for auditing.: ",DVBCNT("SEL")
. W !,"Number of option audits actually created: ",DVBCNT("CRE")
. W !
. W !,"Editing process completed for the namespace of '",DVBNAMESPC,"'."
. D CONTINUE^DVBAUDPRT1(2,"R")
;
Q ; Quit AUDITSPC
;
BUNDLE(DVBXPDIEN,DVBOPTYPES,DVBACTION) ; Handles all of the KIDS Builds
; within a MULTI-PACKAGE bundle
N DVBXPDIEN1,DVBXPDNM
; ZEXCEPT: DVBFLAGMP
;
; Flag MP indicates MULTI PACKAGE, used to avoid too msny
; 'Press <Enter> to continue' prompts after each child package
S DVBFLAGMP=1
;
; Note: MULTIPLE BUILD (multiple) is node 10 of file #9.6
;
S DVBXPDIEN1=0
F S DVBXPDIEN1=$O(^XPD(9.6,DVBXPDIEN,10,DVBXPDIEN1)) Q:'DVBXPDIEN1 D ;
. N DVBIENS
. S DVBIENS=XPDIEN1_","_XPDIEN_","
. S DVBXPDNM=$$GET1^DIQ(9.63,DVBIENS,.01) Q:DVBXPDNM=""
. I '$O(^XPD(9.6,DVBXPDIEN,10,DVBXPDIEN1)) S DVBFLAGMP=0 ; Last package,
. D AUDITBLD(DVBXPDNM,DVBOPTYPES,DVBACTION) W !
;
Q ; Quit BUNDLE
;
OPTYPEOK(DVBOPTYPES) ; Extrinsic to verify DVBOPTYPES input variable
; Return 1 if DVBOPTYPES are OK
; 0 if any of the DVBOPTYPES are invalid
N DVBPOS,DVBVAL
I $L(DVBOPTYPES)'>0 Q 0
S DVBVAL=1 F DVBPOS=1:1:$L(DVBOPTYPES) D ;
. I "AEIMPRXSC"'[$E(DVBOPTYPES,DVBPOS,DVBPOS) S DVBVAL=0
Q DVBVAL ; Quit $$OPTOK extrinsic
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUDU3 9920 printed Sep 17, 2026@20:27:31 Page 2
DVBAUDU3 ;ALB/CP - API Calls Routine #3 for programmers ; 4/12/18 7:28pm
+1 ;;2.7;AMIE;**256**;;Build 19
+2 ; Per VHA Directive 6402 this routine should not be modified5
+3 ; $$FIND1^DIC ; IA # 2051
+4 ; $$GET1^DIQ ; IA # 2056
+5 ; ^%ZOSF( ; IA #10096
+6 ; ^DISV ; IA # 510
+7 ; ^XPD(9.6, ; IA # 1125
+8 ;
+9 ;
+10 ; You must execute a supported entry point
QUIT
+11 ;
AUDIT ; Interactive version of AUDITBLD or AUDITSPC designed to
+1 ; build/initiate or delete option audits for either a BUILD
+2 ; or NAMESPACE (See TYPE input var.)
+3 ;
+4 NEW DVBDRFAULT,DVBFLAG1
+5 ; ZEXCEPT: DUZ
+6 ;
+7 ; 1st time flag
SET DVBFLAG1=1
+8 ;
AUDIT1 ; Return here when the user wants to start over
+1 ;
+2 NEW DVBACTION,DVBSOURCE,DVBQUIT
+3 ;
+4 SET DVBQUIT=0
+5 ;
+6 ; *** Prompt for 'Which Option Audit ACTION' ***
+7 ;
+8 ;
SET DVBDRFAULT=$GET(^DISV(DUZ,$TEXT(+0),"DVBACTION"),1)
IF DVBFLAG1=0
Begin DoDot:1
+9 ; No DVBDRFAULT allows an easy exit on the 2nd time thru
SET DVBDRFAULT=""
End DoDot:1
+10 WRITE !
+11 WRITE !,"Which Option Audit ACTION"
+12 WRITE !,?3,"1) Create Option Audits"
+13 WRITE !,?3,"2) Delete Existing Option Audits"
+14 SET DVBACTION=$$ASKNUM^DVBAUDASK1(2,DVBDRFAULT,,2)
if DVBQUIT
GOTO AUDITEX
+15 IF DVBACTION="^"
SET DVBQUIT=1
GOTO AUDITEX
+16 SET ^DISV(DUZ,$TEXT(+0),"DVBACTION")=DVBACTION
+17 SET DVBACTION=$SELECT(DVBACTION=1:"CREATE",1:"DELETE")
+18 SET DVBFLAG1=0
+19 ;
+20 ; *** Prompt for 'Which Option Audit SOURCE' ***
+21 ;
+22 SET DVBDRFAULT=$GET(^DISV(DUZ,$TEXT(+0),"DVBSOURCE"),1)
+23 WRITE !
+24 WRITE !,"Which Option Audit SOURCE"
+25 WRITE !,?3,"1) Source is a KIDS BUILD"
+26 WRITE !,?3,"2) Source is a NAMESPACE"
+27 SET DVBSOURCE=$$ASKNUM^DVBAUDASK1(2,DVBDRFAULT,,2)
if DVBQUIT
GOTO AUDIT1
+28 ; Start over
IF DVBSOURCE="^"
SET DVBQUIT=1
GOTO AUDIT1
+29 SET ^DISV(DUZ,$TEXT(+0),"DVBSOURCE")=DVBSOURCE
+30 SET DVBSOURCE=$SELECT(DVBSOURCE=1:"BUILD",1:"NAMESPACE")
+31 ;
+32 ;
IF DVBSOURCE="BUILD"
WRITE !
Begin DoDot:1
+33 NEW DVBASK,DVBBUILD,DVBMSG,DVBOPTYPE
+34 DO BUILD^DVBAUDDIC
if DVBQUIT
QUIT
+35 DO SELTYPE^DVBAUDDIR($TEXT(+0))
if DVBQUIT
QUIT
+36 WRITE !
SET DVBMSG="Is it OK to implement these changes"
+37 IF $$ASKYESNO^DVBAUDASK1(DVBMSG,"NO")'="Y"
SET DVBQUIT=1
QUIT
+38 DO AUDITBLD(DVBBUILD,DVBACTION,DVBOPTYPE)
End DoDot:1
+39 ; Start over
if DVBQUIT
GOTO AUDIT1
+40 ;
+41 ;
IF DVBSOURCE="NAMESPACE"
Begin DoDot:1
+42 NEW DVBASK,DVBNAMSPC,DVBMSG,DVBOPTYPE
+43 DO SELWILD^DVBAUDU1(2)
if DVBQUIT
QUIT
+44 DO SELTYPE^DVBAUDDIR($TEXT(+0))
if DVBQUIT
QUIT
+45 WRITE !
SET DVBMSG="Is it OK to implement these changes"
+46 IF $$ASKYESNO^DVBAUDASK1(DVBMSG,"NO")'="Y"
SET DVBQUIT=1
QUIT
+47 DO AUDITSPC(DVBNAMSPC,DVBACTION,DVBOPTYPE)
End DoDot:1
+48 ; Start over
if DVBQUIT
GOTO AUDIT1
+49 ;
+50 ;
AUDITEX ; Exit the AUDIT api
+1 ;
+2 ; Quit AUDIT & AUDIT1
QUIT
+3 ;
AUDITBLD(DVBXPDNM,DVBACTION,DVBOPTYPES) ; Stuff 'D AUDIT^DVBAUDOA' into ENTRY ACTION
+1 ; of every eligible OPTION for a DVBXPDNM of the KIDS Build.
+2 NEW X,DVBOPTNAME,DVBXPDIEN,DVBXPDTYPE
+3 ; ZEXCEPT: U
+4 ;
+5 SET X="DVBAUDOA"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+6 ;
+7 ; Validate that the following files exist:
+8 if '$$FIND1^DIC(1,"","BO","AMIE OPTION AUDIT EVENT")
QUIT
+9 if '$$FIND1^DIC(1,"","BO","AMIE AUDIT SUMMARY BY OPTION")
QUIT
+10 ;
+11 ;
+12 ; Validate input variable ACTION
+13 SET DVBACTION=$GET(DVBACTION,"CREATE")
+14 ; Must be 'CREATE' or 'DELETE'
IF DVBACTION'="CREATE"
IF DVBACTION'="DELETE"
QUIT
+15 ; Validate input variable DVBXPDNM
+16 ; Quit if DVBXPDNM is not defined
if $GET(DVBXPDNM)=""
QUIT
+17 ; IEN?
SET DVBXPDIEN=+$$FIND1^DIC(9.6,"","BO",DVBXPDNM)
if DVBXPDIEN=0
QUIT
+18 ;
+19 ; Validate input variable DVBOPTYPES
+20 SET DVBOPTYPES=$GET(DVBOPTYPES,$SELECT(DVBACTION="CREATE":"AEIPRXSC",1:"AEIMPRXSC"))
+21 if '$$OPTYPEOK(DVBOPTYPES)
QUIT
+22 ;
+23 ; To avoid too many 'Press <Enter> to continue' prompts
NEW DVBFLAGMP
+24 SET DVBXPDTYPE=$$GET1^DIQ(9.6,DVBXPDIEN,2)
+25 IF DVBXPDTYPE="MULTI-PACKAGE"
DO BUNDLE(DVBXPDIEN,DVBOPTYPES,DVBACTION)
QUIT
+26 ;
+27 ; Quit, if this is a GLOBAL PACKAGE
if DVBXPDTYPE="GLOBAL PACKAGE"
QUIT
+28 ; Quit, if there are no OPTION components in this SINGLE PACKAGE
+29 if '$PIECE($GET(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM",0)),U,4)
QUIT
+30 ;
+31 ;
+32 ; Output array of OPTION candidates for Option Auditing
NEW DVBTARGET
+33 SET DVBOPTNAME=""
+34 ;
FOR
SET DVBOPTNAME=$ORDER(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM","B",DVBOPTNAME))
if DVBOPTNAME=""
QUIT
Begin DoDot:1
+35 NEW DVBXPDIEN2
+36 SET DVBXPDIEN2=0
+37 FOR
SET DVBXPDIEN2=$ORDER(^XPD(9.6,DVBXPDIEN,"KRN",19,"NM","B",DVBOPTNAME,DVBXPDIEN2))
if 'DVBXPDIEN2=""
QUIT
Begin DoDot:2
+38 NEW DVBACTION,DVBIEN19
+39 ;
+40 SET DVBIEN19=$$FIND1^DIC(19,"","BO",DVBOPTNAME)
if 'DVBIEN19
QUIT
+41 ;
+42 SET DVBACTION=$$GET1^DIQ(9.68,XPDIEN2_",19,"_XPDIEN_",",.03)
+43 if DVBACTION="DELETE AT SITE"
QUIT
+44 ;
+45 ; Place the option in the DVBTARGET array
+46 SET DVBTARGET(DVBOPTNAME,DVBIEN19)=DVBXPDIEN2
End DoDot:2
End DoDot:1
+47 ; No DVBTARGET option candidates found
if $ORDER(DVBTARGET(""))=""
QUIT
+48 ;
+49 IF DVBACTION="CREATE"
DO BUILD^DVBAUDU3S("AUDITBLD",.DVBTARGET,DVBOPTYPES)
+50 IF DVBACTION="DELETE"
DO DELETE^DVBAUDU3S("AUDITBLD",.DVBTARGET,DVBOPTYPES)
+51 ;
+52 ; Quit AUDITBLD
QUIT
+53 ;
AUDITSPC(DVBNAMESPC,DVBACTION,DVBOPTYPES) ; Stuff 'D AUDIT^DVBAUDOA' into ENTRY ACTION
+1 ;
+2 NEW X
+3 ; ZEXCEPT: DVBFLAG1,U
+4 ;
+5 ; IF the DVBAUDOA routine is not loaded in this environment
+6 ; exit the API.
+7 SET X="DVBAUDOA"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+8 ;
+9 ; Validate that the following files exist:
+10 if '$$FIND1^DIC(1,"","BO","AMIE OPTION AUDIT EVENT")
QUIT
+11 if '$$FIND1^DIC(1,"","BO","AMIE AUDIT SUMMARY BY OPTION")
QUIT
+12 ;
+13 ; Validate input variable DVBNAMESPC (namespace)
+14 ; DVBNAMESPC must be at least 1 characters in length & not null
+15 if $LENGTH(DVBNAMESPC)<1
QUIT
+16 ; Attach wildcard (*) to namespace if it doesn't exist
+17 if $EXTRACT(DVBNAMESPC,$LENGTH(DVBNAMESPC),$LENGTH(DVBNAMESPC))'="*"
SET DVBNAMESPC=DVBNAMESPC_"*"
+18 ;
+19 ; Validate input variable DVBACTION
+20 SET DVBACTION=$GET(DVBACTION,"CREATE")
+21 ; Must be 'CREATE' or 'DELETE'
IF DVBACTION'="CREATE"
IF DVBACTION'="DELETE"
QUIT
+22 ;
+23 ; Validate input variable DVBOPTYPES
+24 SET DVBOPTYPES=$GET(DVBOPTYPES,$SELECT(DVBACTION="CREATE":"AEIPRXSC",1:"AEIMPRXSC"))
+25 IF '$$OPTYPEOK(DVBOPTYPES)
Begin DoDot:1
+26 WRITE !?1,"Invalid Option TYPE encountered -- terminating processing..."
End DoDot:1
QUIT
+27 ;
+28 ;Build DVBTARGET(DVBOPTNAME,DVBIEN19)="" array of Options based upon DVBNAMESPC
+29 ;
+30 NEW DVBFLAG1,DVBTARGET
+31 ; 1st time flag
SET DVBFLAG1=1
+32 ; Bld DVBTARGET array
DO OPTBUILD^DVBAUDU2($TEXT(+0),2,DVBOPTYPES,DVBNAMESPC)
+33 ;
+34 IF DVBACTION="DELETE"
DO DELETE^DVBAUDU3S("AUDITSPC",.DVBTARGET,DVBOPTYPES)
+35 ;
IF DVBACTION="DELETE"
IF $ORDER(DVBTARGET(""))=""
Begin DoDot:1
+36 DO MESSAGE^DVBAUDU3S("AUDITSPC")
+37 DO CONTINUE^DVBAUDPRT1(2,"R")
End DoDot:1
+38 ; Remainder of code is for ACTION 'CREATE'
if DVBACTION="DELETE"
QUIT
+39 ;
+40 ; At this point we know the ACTION="CREATE"
+41 NEW DVBCNT,DVBMAXLEN,DVBOPTNAME,DVBQUIT
+42 ;
+43 ; Number of DVBTARGET options selected for auditing
SET DVBCNT("SEL")=0
+44 ; Number of DVBTARGET options where audits were created
SET DVBCNT("CRE")=0
+45 ;.... Quit/terminate flag, initialized to off (0)
SET DVBQUIT=0
+46 ;.. Maximum length of ENTRY ACTION and EXIT ACTION
SET DVBMAXLEN=229
+47 SET DVBOPTNAME=0
+48 ;
FOR
SET DVBOPTNAME=$ORDER(DVBTARGET(DVBOPTNAME))
if (DVBOPTNAME="")!DVBQUIT
QUIT
Begin DoDot:1
+49 NEW DIERR,DVBENACTION,DVBEXACTION,DVBIEN19,DVBERRMSG
+50 ; DVBIEN19 is the IEN of OPTION file #19
SET DVBIEN19=0
+51 ;
FOR
SET DVBIEN19=$ORDER(DVBTARGET(DVBOPTNAME,DVBIEN19))
if 'DVBIEN19
QUIT
Begin DoDot:2
+52 NEW DIERR,DVBENACTION,DVBEXACTION,DVBOPT,DVBERRMSG
+53 DO OPTION^DVBAUDDIQ(DVBIEN19)
+54 ; Capture ENTRY ACTION
SET DVBENACTION("BEF")=DVBOPT("ENTRYACTION")
+55 ;. Capture EXIT ACTION
SET DVBEXACTION("BEF")=DVBOPT("EXITACTION")
+56 ;
+57 ; Prevent ENTRY ACTION from exceeding maximum length, display msg
+58 IF $LENGTH(DVBENACTION("BEF"))>DVBMAXLEN
QUIT
+59 ; Prevent EXIT ACTION from exceeding maximum length, display msg.
+60 IF $LENGTH(DVBEXACTION("BEF"))>DVBMAXLEN
QUIT
+61 ;
+62 ;
SET DVBENACTION("AFT")="D AUDIT^DVBAUDOA"
IF DVBENACTION("BEF")'=""
Begin DoDot:3
+63 SET DVBENACTION("AFT")="D AUDIT^DVBAUDOA "_DVBENACTION("BEF")
End DoDot:3
+64 ;
+65 ; Format EXIT ACTION in DVBEXACTION("AFT")
DO EXITACT^DVBAUDU3S
+66 ;
+67 ; Edit the Option's ENTRY and EXIT ACTION fields
+68 IF DVBFLAG1=1
IF $ORDER(DVBTARGET(""))]""
DO MESSAGE^DVBAUDU3S("AUDITSPC")
+69 ; Number of options selected for audit
SET DVBCNT("SEL")=DVBCNT("SEL")+1
+70 WRITE !?3,$JUSTIFY(DVBCNT("SEL"),3),". ",?8,DVBOPTNAME
+71 WRITE ?40,$$GET1^DIQ(19,DVBIEN19,4,"E",,"DVBERRMSG")
+72 DO ENTRYACT^DVBAUDDIE(DVBIEN19,.DVBENACTION,.DVBEXACTION)
+73 WRITE ?57
if DVBQUIT=0
WRITE "[Option Audit Added]"
+74 IF DVBQUIT=1
WRITE !
QUIT
+75 DO DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","AUDITSPC^"_$TEXT(+0))
if DVBQUIT
QUIT
+76 ; Create the SUMMARY record stub
DO SUMSTUB^DVBAUDDIE(DVBIEN19)
+77 ; Number of option audits created
SET DVBCNT("CRE")=DVBCNT("CRE")+1
+78 if DVBQUIT
QUIT
End DoDot:2
+79 SET DVBQUIT=0
End DoDot:1
+80 ;
+81 ;
+82 ; If no DVBTARGET array of option audit candidates, display msg & quit
+83 IF $ORDER(DVBTARGET(""))=""
DO MESSAGE^DVBAUDU3S("AUDITSPC")
QUIT
+84 ;
+85 WRITE !
+86 ;
+87 ; If more than 1 eligible option was presented, display statistics
+88 ;
IF DVBCNT("SEL")>1
Begin DoDot:1
+89 WRITE !,"Number of options selected for auditing.: ",DVBCNT("SEL")
+90 WRITE !,"Number of option audits actually created: ",DVBCNT("CRE")
+91 WRITE !
+92 WRITE !,"Editing process completed for the namespace of '",DVBNAMESPC,"'."
+93 DO CONTINUE^DVBAUDPRT1(2,"R")
End DoDot:1
+94 ;
+95 ; Quit AUDITSPC
QUIT
+96 ;
BUNDLE(DVBXPDIEN,DVBOPTYPES,DVBACTION) ; Handles all of the KIDS Builds
+1 ; within a MULTI-PACKAGE bundle
+2 NEW DVBXPDIEN1,DVBXPDNM
+3 ; ZEXCEPT: DVBFLAGMP
+4 ;
+5 ; Flag MP indicates MULTI PACKAGE, used to avoid too msny
+6 ; 'Press <Enter> to continue' prompts after each child package
+7 SET DVBFLAGMP=1
+8 ;
+9 ; Note: MULTIPLE BUILD (multiple) is node 10 of file #9.6
+10 ;
+11 SET DVBXPDIEN1=0
+12 ;
FOR
SET DVBXPDIEN1=$ORDER(^XPD(9.6,DVBXPDIEN,10,DVBXPDIEN1))
if 'DVBXPDIEN1
QUIT
Begin DoDot:1
+13 NEW DVBIENS
+14 SET DVBIENS=XPDIEN1_","_XPDIEN_","
+15 SET DVBXPDNM=$$GET1^DIQ(9.63,DVBIENS,.01)
if DVBXPDNM=""
QUIT
+16 ; Last package,
IF '$ORDER(^XPD(9.6,DVBXPDIEN,10,DVBXPDIEN1))
SET DVBFLAGMP=0
+17 DO AUDITBLD(DVBXPDNM,DVBOPTYPES,DVBACTION)
WRITE !
End DoDot:1
+18 ;
+19 ; Quit BUNDLE
QUIT
+20 ;
OPTYPEOK(DVBOPTYPES) ; Extrinsic to verify DVBOPTYPES input variable
+1 ; Return 1 if DVBOPTYPES are OK
+2 ; 0 if any of the DVBOPTYPES are invalid
+3 NEW DVBPOS,DVBVAL
+4 IF $LENGTH(DVBOPTYPES)'>0
QUIT 0
+5 ;
SET DVBVAL=1
FOR DVBPOS=1:1:$LENGTH(DVBOPTYPES)
Begin DoDot:1
+6 IF "AEIMPRXSC"'[$EXTRACT(DVBOPTYPES,DVBPOS,DVBPOS)
SET DVBVAL=0
End DoDot:1
+7 ; Quit $$OPTOK extrinsic
QUIT DVBVAL
