DVBAUDDIC ;ALB/CP - FM DIC API Subroutine Calls ; 3/27/18 3:33pm
;;2.7;AMIE;**256**;;Build 19
; Per VHA Directive 6402 this routine should not be modified
; ^DIC ; IA #10006
; $$GET1^DIQ ; IA # 2056
;
Q
BUILD ; Prompt for "Select BUILD NAME: "
;
N @($$DIC^DVBAUDNEW1())
; ZEXCEPT: DVBBUILD,DVBQUIT
;
S DVBQUIT=0 ; Default to successful lookup
S DIC="^XPD(9.6,",DIC(0)="AEMQ"
D ^DIC I Y<0 S DVBQUIT=1
S DVBBUILD=$P(Y,U,2)
;
Q ; Quit BUILD
;
ENTRIES(DVBCNT) ; Internal subroutine
; Display number of unique entries when DVBCNT>1
; Input:
; DVBCNT ; Required ; Number of unique entries selected via DIC call
;
N DVBMSG Q:DVBCNT'>1
; ZEXCEPT: IOM
;
S DVBMSG="Number of unique entries selected: "_DVBCNT
D CENTER^DVBAUDPRT1(DVBMSG,2,IOM,1) ;Center message using reverse video
;
Q ; Quit ENTRIES
;
OPTSIN(DVBRTN,DVBEDIT,DVBOPTYPE) ; FM DIC API to select multiple OPTIONs
;
N @($$DIC^DVBAUDNEW1())
N DVBDST,DVBDIALLVAL,DVBPOS
; ZEXCEPT: DIC,DVBQUIT,DVBTARGET,X,Y
;
S DVBQUIT=0 ; Initialize quit status variable to No (for successful).
K DVBTARGET ; Refresh output array of selected options
;
; Verify that required input variables are passed.
I $G(DVBRTN)="" S DVBQUIT=1 Q ; Routine name missing
I $G(DVBEDIT)'=1 S DVBQUIT=1 Q ; Missing or invalid DVBEDIT (can only be one)
I $L($G(DVBOPTYPE))'>0 S DVBQUIT=1 Q
F DVBPOS=1:1:$L(DVBOPTYPE) I "AEIMPRXSC"'[$E(DVBOPTYPE,DVBPOS,DVBPOS) S DVBQUIT=1 Q
;
;
S DIC("S")="N DVBTYPE S DVBTYPE=$$GET1^DIQ(19,+Y,4,""I"") I DVBTYPE]""""" ;Screen 1
S DIC("S")=DIC("S")_",DVBOPTYPE[DVBTYPE" ; User selected Option TYPE ;..Screen 2
S DIC("S")=DIC("S")_",'$D(DVBTARGET($$GET1^DIQ(19,+Y,.01)))" ;.......Screen 3
I DVBRTN="DVBAUDOA" D ; Routine to apply the AMIE audit
. S DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,2)=""""" ;.................Screen 4
. S DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,20)'[""AUDIT^DVBAUDOA""" ;..Screen 5
I DVBRTN="DVBAUDOAD" D ; Routine to delete AMIE audit
. S DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,20)[""AUDIT^DVBAUDOA""" ;...Screen 6
;
S DIC="^DIC(19," ; OPTION file #19
S DIC("A")=" Select OPTION NAME: "
S DIC(0)="AEQM"
S DVBTARGET("CNT")=0
;
W !
F D Q:DVBQUIT
. D ^DIC
. I Y<1 S DVBQUIT=1 Q ; User entered a "^" to exit.
. S DVBTARGET($P(Y,U,2),+Y)=$$GET1^DIQ(19,+Y,4) ; 4 = DVBTYPE (external)
. S DVBTARGET("CNT")=DVBTARGET("CNT")+1
. ; Modify prompt text after first Option entry is selected.
. I DVBTARGET("CNT")=1 S DIC("A")=" Another OPTION: "
I X="^" S DVBQUIT=1 K DVBTARGET Q
I $O(DVBTARGET(""))']"" S DVBQUIT=1 K DVBTARGET Q
;
D ENTRIES(DVBTARGET("CNT")) ; Display num. of unique entries selected
S DVBQUIT=0
;
Q ; Quit OPTSIN
;
OPTSOUT(DVBDIC0,DVBLIMIT,DVBSCREEN,DVBPROMPT) ; Prompt for one to many entries
; from the AMIE AUDIT SUMMARY BY OPTION file #396.9991
;
; From:
; PROMPT^DVBAUDUU ; Audited Option User Utilization
;
N @($$DIC^DVBAUDNEW1())
N DVBDST,DVBIEN19,DVBCNT,DVBNAME
; ZEXCEPT: DIC,DLAYGO,DVBOPT,DVBQUIT,X,Y
;
S DVBCNT=0 ;.... Initialize number of selected records to zero
S DVBQUIT=0 ;... Initialize quit status variable to No
;
; Verify that required input variables were passed
I $G(DVBDIC0)']"" S DVBQUIT=1 Q
I $A($E($G(DVBLIMIT)))'>47 S DVBQUIT=1 Q
;
K DVBOPT ; Refresh output array
S DVBOPT("CNT")=0 ; Initialize output count to zero
;
S DIC(0)=DVBDIC0 ; Attributes are required on parameter passing input
;
; DVBLIMIT must be an integer, zero or greater than 0
I '$$POSINT^DVBAUDSTR1(DVBLIMIT) S DVBQUIT=2 Q
;
S DVBSCREEN=$G(DVBSCREEN,0)
I DVBSCREEN=0 K DIC("S")
I DVBSCREEN=1 S DIC("S")="I '$D(DVBOPT(Y))" ; OPTION not prev. selected
;
S DIC="^DVB(396.9991,"
I DIC(0)["L" S DLAYGO=396.9991 ; Set DLAYGO to add a record
;
S DVBPROMPT=$G(DVBPROMPT,"Select Audited OPTION NAME: ")
S DIC("A")=DVBPROMPT
;
W !
F D Q:DVBQUIT
. N DIERR,DVBERRMSG ; FM database server call error indicator
. D ^DIC I X["^" S DVBQUIT=2 Q ; DVBQUIT=2 on user '^'
. I Y<0 S DVBQUIT=1 Q ; User is finished selecting records
. S DVBIEN19=$P(Y,U) ; Entries are DINUMed to New Person file
. S DVBNAME=$$GET1^DIQ(396.9991,DVBIEN19,.01,"E",,"DVBERRMSG")
. D DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","OPTION^"_$T(+0)) Q:DVBQUIT
. Q:$D(DVBOPT(DVBIEN19)) ; Entry already selected
. S DVBOPT(DVBIEN19)=DVBNAME ; Selected record IEN list
. S DVBOPT("B",DVBNAME,DVBIEN19)="" ; Alphabetic name 'B' x-ref
. S DVBCNT=DVBCNT+1 ; Count of the number of unique entries selected
. I DVBLIMIT>0,DVBCNT=DVBLIMIT S DVBQUIT=1
. I $O(DVBOPT(0)) S DIC("A")=" Another OPTION NAME: "
;
Q:DVBQUIT=2 ;. User entered "^" to quit
I $O(DVBOPT(0)) S DVBQUIT=0 ; User's selection, no '^', don't quit
S DVBOPT("CNT")=DVBCNT ; Count of uniques selected
;
D ENTRIES(DVBCNT) ; Display number of unique entries selected
;
Q ; Quit OPTSOUT
;
USER(DVBDIC0,DVBLIMIT,DVBSCREEN,DVBPROMPT) ; Prompt for one to many entries
; from the AMIE AUDIT SUMMARY BY USER file #396.9992
;
; PROMPT^DVBAUDUI ; User Audit Summary Inquiry
;
N @($$DIC^DVBAUDNEW1())
N DVBDST,DVBIEN200,DVBCNT,DVBNAME
; ZEXCEPT: DIC,DLAYGO,DVBUSER,DVBQUIT,X,Y
;
S DVBCNT=0 ;.... Initialize number of selected records to zero
S DVBQUIT=0 ;... Initialize quit status variable to No
;
; Verify that required input variables were passed
I $G(DVBDIC0)']"" S DVBQUIT=1 Q
I $A($E($G(DVBLIMIT)))'>47 S DVBQUIT=1 Q
;
K DVBUSER ; Refresh output array
S DVBUSER("CNT")=0 ; Initialize output count to zero
;
S DIC(0)=DVBDIC0 ; Attributes are required on parameter passing input
;
; DVBLIMIT must be an integer, zero or greater than 0
I '$$POSINT^DVBAUDSTR1(DVBLIMIT) S DVBQUIT=2 Q
;
S DVBSCREEN=$G(DVBSCREEN,0)
I DVBSCREEN=0 K DIC("S")
I DVBSCREEN=1 S DIC("S")="I $$ACTIVE^XUSER(Y)" ; Only active users
;
S DIC="^DVB(396.9992,"
I DIC(0)["L" S DLAYGO=396.9992 ; Set DLAYGO when adding to the database.
;
S DVBPROMPT=$G(DVBPROMPT,"Select USERNAME: ")
S DIC("A")=DVBPROMPT
;
W !
F D Q:DVBQUIT
. N DIERR,DVBERRMSG ; FM database server call error indicator
. D ^DIC I X["^" S DVBQUIT=2 Q ; DVBQUIT=2 on user '^'
. I Y<0 S DVBQUIT=1 Q ; User is finished selecting records
. S DVBIEN200=$P(Y,U) ; Entries are DINUMed to New Person file
. S DVBNAME=$$GET1^DIQ(200,DVBIEN200,.01,"E",,"DVBERRMSG")
. D DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","USER^"_$T(+0)) Q:DVBQUIT
. Q:$D(DVBUSER(DVBIEN200)) ; Entry already selected
. S DVBUSER(DVBIEN200)=DVBNAME ; Selected record IEN list
. S DVBUSER("B",DVBNAME,DVBIEN200)="" ; Alphabetic name 'B' x-ref
. S DVBCNT=DVBCNT+1 ; Count of the number of unique entries selected
. I DVBLIMIT>0,DVBCNT=DVBLIMIT S DVBQUIT=1
. I $O(DVBUSER(0)) S DIC("A")=" Another USER: "
;
Q:DVBQUIT=2 ;. User entered "^" to quit
I $O(DVBUSER(0)) S DVBQUIT=0 ; User's selection, no '^', don't quit
S DVBUSER("CNT")=DVBCNT ; Count of uniques selected
;
D ENTRIES(DVBCNT) ; Display number of unique entries selected
;
Q ; Quit USER
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUDDIC 7131 printed Sep 17, 2026@20:27:15 Page 2
DVBAUDDIC ;ALB/CP - FM DIC API Subroutine Calls ; 3/27/18 3:33pm
+1 ;;2.7;AMIE;**256**;;Build 19
+2 ; Per VHA Directive 6402 this routine should not be modified
+3 ; ^DIC ; IA #10006
+4 ; $$GET1^DIQ ; IA # 2056
+5 ;
+6 QUIT
BUILD ; Prompt for "Select BUILD NAME: "
+1 ;
+2 NEW @($$DIC^DVBAUDNEW1())
+3 ; ZEXCEPT: DVBBUILD,DVBQUIT
+4 ;
+5 ; Default to successful lookup
SET DVBQUIT=0
+6 SET DIC="^XPD(9.6,"
SET DIC(0)="AEMQ"
+7 DO ^DIC
IF Y<0
SET DVBQUIT=1
+8 SET DVBBUILD=$PIECE(Y,U,2)
+9 ;
+10 ; Quit BUILD
QUIT
+11 ;
ENTRIES(DVBCNT) ; Internal subroutine
+1 ; Display number of unique entries when DVBCNT>1
+2 ; Input:
+3 ; DVBCNT ; Required ; Number of unique entries selected via DIC call
+4 ;
+5 NEW DVBMSG
if DVBCNT'>1
QUIT
+6 ; ZEXCEPT: IOM
+7 ;
+8 SET DVBMSG="Number of unique entries selected: "_DVBCNT
+9 ;Center message using reverse video
DO CENTER^DVBAUDPRT1(DVBMSG,2,IOM,1)
+10 ;
+11 ; Quit ENTRIES
QUIT
+12 ;
OPTSIN(DVBRTN,DVBEDIT,DVBOPTYPE) ; FM DIC API to select multiple OPTIONs
+1 ;
+2 NEW @($$DIC^DVBAUDNEW1())
+3 NEW DVBDST,DVBDIALLVAL,DVBPOS
+4 ; ZEXCEPT: DIC,DVBQUIT,DVBTARGET,X,Y
+5 ;
+6 ; Initialize quit status variable to No (for successful).
SET DVBQUIT=0
+7 ; Refresh output array of selected options
KILL DVBTARGET
+8 ;
+9 ; Verify that required input variables are passed.
+10 ; Routine name missing
IF $GET(DVBRTN)=""
SET DVBQUIT=1
QUIT
+11 ; Missing or invalid DVBEDIT (can only be one)
IF $GET(DVBEDIT)'=1
SET DVBQUIT=1
QUIT
+12 IF $LENGTH($GET(DVBOPTYPE))'>0
SET DVBQUIT=1
QUIT
+13 FOR DVBPOS=1:1:$LENGTH(DVBOPTYPE)
IF "AEIMPRXSC"'[$EXTRACT(DVBOPTYPE,DVBPOS,DVBPOS)
SET DVBQUIT=1
QUIT
+14 ;
+15 ;
+16 ;Screen 1
SET DIC("S")="N DVBTYPE S DVBTYPE=$$GET1^DIQ(19,+Y,4,""I"") I DVBTYPE]"""""
+17 ; User selected Option TYPE ;..Screen 2
SET DIC("S")=DIC("S")_",DVBOPTYPE[DVBTYPE"
+18 ;.......Screen 3
SET DIC("S")=DIC("S")_",'$D(DVBTARGET($$GET1^DIQ(19,+Y,.01)))"
+19 ; Routine to apply the AMIE audit
IF DVBRTN="DVBAUDOA"
Begin DoDot:1
+20 ;.................Screen 4
SET DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,2)="""""
+21 ;..Screen 5
SET DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,20)'[""AUDIT^DVBAUDOA"""
End DoDot:1
+22 ; Routine to delete AMIE audit
IF DVBRTN="DVBAUDOAD"
Begin DoDot:1
+23 ;...Screen 6
SET DIC("S")=DIC("S")_",$$GET1^DIQ(19,+Y,20)[""AUDIT^DVBAUDOA"""
End DoDot:1
+24 ;
+25 ; OPTION file #19
SET DIC="^DIC(19,"
+26 SET DIC("A")=" Select OPTION NAME: "
+27 SET DIC(0)="AEQM"
+28 SET DVBTARGET("CNT")=0
+29 ;
+30 WRITE !
+31 FOR
Begin DoDot:1
+32 DO ^DIC
+33 ; User entered a "^" to exit.
IF Y<1
SET DVBQUIT=1
QUIT
+34 ; 4 = DVBTYPE (external)
SET DVBTARGET($PIECE(Y,U,2),+Y)=$$GET1^DIQ(19,+Y,4)
+35 SET DVBTARGET("CNT")=DVBTARGET("CNT")+1
+36 ; Modify prompt text after first Option entry is selected.
+37 IF DVBTARGET("CNT")=1
SET DIC("A")=" Another OPTION: "
End DoDot:1
if DVBQUIT
QUIT
+38 IF X="^"
SET DVBQUIT=1
KILL DVBTARGET
QUIT
+39 IF $ORDER(DVBTARGET(""))']""
SET DVBQUIT=1
KILL DVBTARGET
QUIT
+40 ;
+41 ; Display num. of unique entries selected
DO ENTRIES(DVBTARGET("CNT"))
+42 SET DVBQUIT=0
+43 ;
+44 ; Quit OPTSIN
QUIT
+45 ;
OPTSOUT(DVBDIC0,DVBLIMIT,DVBSCREEN,DVBPROMPT) ; Prompt for one to many entries
+1 ; from the AMIE AUDIT SUMMARY BY OPTION file #396.9991
+2 ;
+3 ; From:
+4 ; PROMPT^DVBAUDUU ; Audited Option User Utilization
+5 ;
+6 NEW @($$DIC^DVBAUDNEW1())
+7 NEW DVBDST,DVBIEN19,DVBCNT,DVBNAME
+8 ; ZEXCEPT: DIC,DLAYGO,DVBOPT,DVBQUIT,X,Y
+9 ;
+10 ;.... Initialize number of selected records to zero
SET DVBCNT=0
+11 ;... Initialize quit status variable to No
SET DVBQUIT=0
+12 ;
+13 ; Verify that required input variables were passed
+14 IF $GET(DVBDIC0)']""
SET DVBQUIT=1
QUIT
+15 IF $ASCII($EXTRACT($GET(DVBLIMIT)))'>47
SET DVBQUIT=1
QUIT
+16 ;
+17 ; Refresh output array
KILL DVBOPT
+18 ; Initialize output count to zero
SET DVBOPT("CNT")=0
+19 ;
+20 ; Attributes are required on parameter passing input
SET DIC(0)=DVBDIC0
+21 ;
+22 ; DVBLIMIT must be an integer, zero or greater than 0
+23 IF '$$POSINT^DVBAUDSTR1(DVBLIMIT)
SET DVBQUIT=2
QUIT
+24 ;
+25 SET DVBSCREEN=$GET(DVBSCREEN,0)
+26 IF DVBSCREEN=0
KILL DIC("S")
+27 ; OPTION not prev. selected
IF DVBSCREEN=1
SET DIC("S")="I '$D(DVBOPT(Y))"
+28 ;
+29 SET DIC="^DVB(396.9991,"
+30 ; Set DLAYGO to add a record
IF DIC(0)["L"
SET DLAYGO=396.9991
+31 ;
+32 SET DVBPROMPT=$GET(DVBPROMPT,"Select Audited OPTION NAME: ")
+33 SET DIC("A")=DVBPROMPT
+34 ;
+35 WRITE !
+36 FOR
Begin DoDot:1
+37 ; FM database server call error indicator
NEW DIERR,DVBERRMSG
+38 ; DVBQUIT=2 on user '^'
DO ^DIC
IF X["^"
SET DVBQUIT=2
QUIT
+39 ; User is finished selecting records
IF Y<0
SET DVBQUIT=1
QUIT
+40 ; Entries are DINUMed to New Person file
SET DVBIEN19=$PIECE(Y,U)
+41 SET DVBNAME=$$GET1^DIQ(396.9991,DVBIEN19,.01,"E",,"DVBERRMSG")
+42 DO DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","OPTION^"_$TEXT(+0))
if DVBQUIT
QUIT
+43 ; Entry already selected
if $DATA(DVBOPT(DVBIEN19))
QUIT
+44 ; Selected record IEN list
SET DVBOPT(DVBIEN19)=DVBNAME
+45 ; Alphabetic name 'B' x-ref
SET DVBOPT("B",DVBNAME,DVBIEN19)=""
+46 ; Count of the number of unique entries selected
SET DVBCNT=DVBCNT+1
+47 IF DVBLIMIT>0
IF DVBCNT=DVBLIMIT
SET DVBQUIT=1
+48 IF $ORDER(DVBOPT(0))
SET DIC("A")=" Another OPTION NAME: "
End DoDot:1
if DVBQUIT
QUIT
+49 ;
+50 ;. User entered "^" to quit
if DVBQUIT=2
QUIT
+51 ; User's selection, no '^', don't quit
IF $ORDER(DVBOPT(0))
SET DVBQUIT=0
+52 ; Count of uniques selected
SET DVBOPT("CNT")=DVBCNT
+53 ;
+54 ; Display number of unique entries selected
DO ENTRIES(DVBCNT)
+55 ;
+56 ; Quit OPTSOUT
QUIT
+57 ;
USER(DVBDIC0,DVBLIMIT,DVBSCREEN,DVBPROMPT) ; Prompt for one to many entries
+1 ; from the AMIE AUDIT SUMMARY BY USER file #396.9992
+2 ;
+3 ; PROMPT^DVBAUDUI ; User Audit Summary Inquiry
+4 ;
+5 NEW @($$DIC^DVBAUDNEW1())
+6 NEW DVBDST,DVBIEN200,DVBCNT,DVBNAME
+7 ; ZEXCEPT: DIC,DLAYGO,DVBUSER,DVBQUIT,X,Y
+8 ;
+9 ;.... Initialize number of selected records to zero
SET DVBCNT=0
+10 ;... Initialize quit status variable to No
SET DVBQUIT=0
+11 ;
+12 ; Verify that required input variables were passed
+13 IF $GET(DVBDIC0)']""
SET DVBQUIT=1
QUIT
+14 IF $ASCII($EXTRACT($GET(DVBLIMIT)))'>47
SET DVBQUIT=1
QUIT
+15 ;
+16 ; Refresh output array
KILL DVBUSER
+17 ; Initialize output count to zero
SET DVBUSER("CNT")=0
+18 ;
+19 ; Attributes are required on parameter passing input
SET DIC(0)=DVBDIC0
+20 ;
+21 ; DVBLIMIT must be an integer, zero or greater than 0
+22 IF '$$POSINT^DVBAUDSTR1(DVBLIMIT)
SET DVBQUIT=2
QUIT
+23 ;
+24 SET DVBSCREEN=$GET(DVBSCREEN,0)
+25 IF DVBSCREEN=0
KILL DIC("S")
+26 ; Only active users
IF DVBSCREEN=1
SET DIC("S")="I $$ACTIVE^XUSER(Y)"
+27 ;
+28 SET DIC="^DVB(396.9992,"
+29 ; Set DLAYGO when adding to the database.
IF DIC(0)["L"
SET DLAYGO=396.9992
+30 ;
+31 SET DVBPROMPT=$GET(DVBPROMPT,"Select USERNAME: ")
+32 SET DIC("A")=DVBPROMPT
+33 ;
+34 WRITE !
+35 FOR
Begin DoDot:1
+36 ; FM database server call error indicator
NEW DIERR,DVBERRMSG
+37 ; DVBQUIT=2 on user '^'
DO ^DIC
IF X["^"
SET DVBQUIT=2
QUIT
+38 ; User is finished selecting records
IF Y<0
SET DVBQUIT=1
QUIT
+39 ; Entries are DINUMed to New Person file
SET DVBIEN200=$PIECE(Y,U)
+40 SET DVBNAME=$$GET1^DIQ(200,DVBIEN200,.01,"E",,"DVBERRMSG")
+41 DO DIERR^DVBAUDDILG1(60,5,"DVBERRMSG","USER^"_$TEXT(+0))
if DVBQUIT
QUIT
+42 ; Entry already selected
if $DATA(DVBUSER(DVBIEN200))
QUIT
+43 ; Selected record IEN list
SET DVBUSER(DVBIEN200)=DVBNAME
+44 ; Alphabetic name 'B' x-ref
SET DVBUSER("B",DVBNAME,DVBIEN200)=""
+45 ; Count of the number of unique entries selected
SET DVBCNT=DVBCNT+1
+46 IF DVBLIMIT>0
IF DVBCNT=DVBLIMIT
SET DVBQUIT=1
+47 IF $ORDER(DVBUSER(0))
SET DIC("A")=" Another USER: "
End DoDot:1
if DVBQUIT
QUIT
+48 ;
+49 ;. User entered "^" to quit
if DVBQUIT=2
QUIT
+50 ; User's selection, no '^', don't quit
IF $ORDER(DVBUSER(0))
SET DVBQUIT=0
+51 ; Count of uniques selected
SET DVBUSER("CNT")=DVBCNT
+52 ;
+53 ; Display number of unique entries selected
DO ENTRIES(DVBCNT)
+54 ;
+55 ; Quit USER
QUIT
