DVBCPUSH ;ALB/AKG/JD - CAPRI PUSH UTILITY RPC; APR 25, 2022@9:30am ; 5/19/23 9:07am
;;2.7;AMIE;**238,242,248,252,254**;Apr 10, 1995;Build 41
;Per VHA Directive 6402 this routine should not be modified
;ICR #2263 Supports all calls to Parameter File and XPAR usage
;
Q
;
PARAMS(DVBLIST) ;returns data on the entire DVBA parameter list
;rpc returns all CAPRI namespaced Parameters
;RPC: DVBA CAPRI PARAM INQ
;Updated code to allow for multi-instance parameters for CAPRI-13378. JD - 9/10/24
;Update to return word processing parameters CAPRI-16484 2/24/25 CP
;
K DVBLIST
N DVBCNT,DVBD,DVBI,DVBPARAM,DVBPAR,DVBVAL,DVBERR,DVBTYP
S DVBCNT=0
S DVBPARAM="" F S DVBPARAM=$O(^XTV(8989.51,"B",DVBPARAM)) Q:DVBPARAM="" D
.I $P($P(DVBPARAM,U,1)," ")'["DVBA" Q
.S DVBPAR="" F S DVBPAR=$O(^XTV(8989.51,"B",DVBPARAM,DVBPAR)) Q:DVBPAR="" D
..S DVBTYP=$$GET1^DIQ(8989.51,DVBPAR,"1.1","I")
..I DVBTYP'="W" D
...D GETLST^XPAR(.DVBVAL,"PKG",DVBPARAM,"Q")
...S (DVBD,DVBI)=""
...F S DVBI=$O(DVBVAL(DVBI)) Q:DVBI="" S DVBD=DVBD_"|"_$P(DVBVAL(DVBI),U,2)
...S DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_$P(DVBD,"|",2,9999)
...S DVBCNT=DVBCNT+1
...Q
..I DVBTYP="W" D
...D GETWP^XPAR(.DVBVAL,"PKG",DVBPARAM,1)
...S (DVBD,DVBI)=""
...F S DVBI=$O(DVBVAL(DVBI)) Q:DVBI="" S DVBD=DVBD_"|"_$G(DVBVAL(DVBI,0))
...S DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_$P(DVBD,"|",2,9999)
...S DVBCNT=DVBCNT+1
...Q
Q
;
PARAMED(DVBMSG,DVBNAME,DVBVAL) ;
;edits exiting parameter value from CAPRI Push Utility
;RPC: DVBA CAPRI PARAM UPDATE
;Updated code to allow for multi-instance parameters for CAPRI-13378. JD - 9/11/24
;Update to allow saving of word processing parameters CAPRI-16484 2/24/25 CP
;
I $G(DVBNAME)="" S DVBMSG="Missing parameter name" Q
K DVBMSG S DVBMSG=""
N DVBCNF,DVBCNS,DVBCNT,DVBDLER,DVBERR,DVBF,DVBI,DVBPI,DVBVALV
N DVBTYP,DVBLEN,DVBI,DVBUPD,DVBTMP
S (DVBCNF,DVBCNS,DVBCNT,DVBDLER,DVBERR)=0
S DVBPI=$O(^XTV(8989.51,"B",DVBNAME,""))
S DVBTYP=$$GET1^DIQ(8989.51,DVBPI,"1.1","I")
I $D(^XTV(8989.5,"AC",DVBPI))>0 D NDEL^XPAR("PKG",DVBNAME,.DVBDLER)
I DVBDLER'=0 S DVBMSG=DVBDLER Q
I $G(DVBVAL)="" S DVBMSG="The entire parameter list has been deleted" Q
I DVBTYP'="W" D
.S DVBF=""
.F DVBI=1:1:$L(DVBVAL,"|") D
..S DVBVALV=$P(DVBVAL,"|",DVBI)
..D EN^XPAR("PKG.AUTOMATED MED INFO EXCHANGE",DVBNAME,DVBI,DVBVALV,.DVBERR)
..S DVBCNT=DVBCNT+1
..I DVBERR D Q
...S DVBCNF=DVBCNF+1
...S DVBF=DVBF_"|"_DVBI_","_$P(DVBERR,U,2)
..S DVBCNS=DVBCNS+1
.S DVBMSG=DVBCNS_"/"_DVBCNT_" "_$S(DVBCNS=1:"was",1:"were")_" successful"_DVBF
I DVBTYP="W" D
. S DVBLEN=$L(DVBVAL,"|")
. I DVBLEN>1 F DVBI=1:1:DVBLEN S DVBUPD(DVBI)=$P(DVBVAL,"|",DVBI)
. I DVBLEN=1,$L(DVBVAL)>250 D SPLIT(.DVBUPD,DVBVAL)
. I DVBLEN=1,$L(DVBVAL)<250 S DVBUPD(1)=$G(DVBVAL)
. I DVBLEN=1,$D(DVBUPD)<10 S DVBMSG="Issue trying to split Data" Q
. I DVBNAME="DVBAB CAPRI GITHUB TOKEN" D
. . S DVBCNT=$O(DVBUPD(""),-1)
. . S DVBTMP(1)="-----BEGIN RSA PRIVATE KEY-----"
. . F DVBI=1:1:DVBCNT S DVBTMP(DVBI+1)=DVBUPD(DVBI)
. . S DVBTMP(DVBCNT+2)="-----END RSA PRIVATE KEY-----"
. . K DVBUPD M DVBUPD=DVBTMP
. . Q
. D EN^XPAR("PKG",DVBNAME,1,.DVBUPD,.DVBERR)
. I DVBERR'=0 S DVBMSG=DVBERR Q
. S DVBMSG=DVBNAME_" was updated successfully" Q
. Q
Q
;
PARADESC(DVBRTN,DVBIEN) ;
;RPC; DVBA CAPRI GET PAR DESC
;returns description for selected parameter
N DVBX,DVBTWP,DVBERR,DVBCT,DVBRT,DVBIENS,DVBTMP
I $G(DVBIEN)="" S DVBRTN="Missing Parameter IEN" Q
D GETS^DIQ(8989.51,DVBIEN,20,"","DVBTWP","DVBERR")
I $D(DVBERR) S DVBRTN=DVBERR Q
K DVBTMP M DVBTMP=DVBTWP
S DVBIENS=""_DVBIEN_","
I $D(DVBTMP) D
.S DVBCT="",DVBX="" F S DVBX=$O(DVBTMP(8989.51,DVBIENS,20,DVBX)) Q:DVBX="" D
..S DVBCT=DVBCT+1
..S DVBRT(DVBCT)=DVBTMP(8989.51,DVBIENS,20,DVBX)
M DVBRTN=DVBRT
K DVBRT,DVBTWP
Q
;
EFOLDMET(DVBRTN,DVBAUTH,DVBPIEN,DVBTRANS,DVBSTAT,DVBERR,DVBRPD) ;
;RPC: DVBA CAPRI SET METRICS
;Input: DVBAUTH=Authorized User IEN
; DVBPIEN=Patient IEN
; DVBTRANS=Transmission Path
; DVBSTAT=Transmission Status
; DVBERR=Transmission Error Code
; DVBRPD=Report Details
;Output: RTN=0 for Failure and 1 for Success
;
N DVBDT,DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DVBI,DVBRPC,DVBN1,DVBAIEN,DVBNUM
I DVBAUTH="" S DVBRTN="0^MISSING AUTHORIZED USER IEN" Q
I DVBPIEN="" S DVBRTN="0^MISSING PATIENT IEN" Q
I DVBTRANS="" S DVBRTN="0^MISSING TRANSMISSION PATH" Q
I DVBSTAT="" S DVBRTN="0^MISSING TRANSMISSION STATUS" Q
S DVBDT=$$NOW^XLFDT()
K DIC,DIE,DR,DA
S (DIC,DIE)="^DVB(396.21,",DIC(0)="L",DLAYGO=396.21 S X=DVBDT
D ^DIC S DA=+Y K DIC
I DA=-1 S DVBRTN=0 Q
S DVBRTN=1
S DR=".02////"_DVBAUTH_";.03////"_DVBPIEN_";1////"_DVBTRANS D ^DIE
S DR="1.1////"_DVBSTAT_";1.2////"_DVBERR D ^DIE
S DVBNUM=DA
S DVBI="" F S DVBI=$O(DVBRPD(DVBI)) Q:DVBI="" D
.S DA(1)=DVBNUM
.S DIC="^DVB(396.21,"_DA(1)_",2,",DIC(0)="L"
.D ^DIC S DA=+Y
.S DIE=DIC
.S DVBRPC=$P(DVBRPD(DVBI),U),DVBAIEN=$P(DVBRPD(DVBI),U,2)
.S DVBN1=$P(DVBRPD(DVBI),U,3,100)
.S DR=".01////"_DVBRPC_";.02////"_DVBAIEN_";.03////"_DVBN1
.D ^DIE
K DIC,DIE,DA,DR,DIRUT
Q
;
PURGEMET(DVBRTN,DUZ,DVBDTP) ;
;RPC: DVBA CAPRI PURGE MET
;input: DUZ user must have the DVBA METRICS DATA PURGE key
; : Date to purge up to
N DVBDT,DVBDA,DVBKEY,DVBDATE
I DUZ="" S DVBRTN="0^Missing DUZ" Q
I DVBDTP="" S DVBRTN="0^Missing Date" Q
S X=DVBDTP D ^%DT S DVBDATE=Y
D OWNSKEY^XUSRB(.DVBKEY,"DVBA CAPRI METRICS PURGE",DUZ)
I DVBKEY(0)=0 S DVBRTN="0^Missing security key" Q
S DVBDT="" F S DVBDT=$O(^DVB(396.21,"B",DVBDT)) Q:DVBDT="" D
.S DVBDA="" F S DVBDA=$O(^DVB(396.21,"B",DVBDT,DVBDA)) Q:DVBDA="" D
..I $P(DVBDT,".")>DVBDATE Q
..K DIC,DA,DIK
..S DIC="^DVB(396.21,",DA=DVBDA
..S DIK=DIC D ^DIK K DIK,DIC
..S DVBRTN=1
I $G(DVBRTN)'=1 S DVBRTN="-1"
Q
PURGEOPT ;
W !!,"CAPRI CLINICAL DOCUMENTS EFOLDER METRIC DATA PURGE",!!
S DIR("?")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file up to. For Example, to purge from today and older enter today's date"
S DIR("A")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file."
S DIR(0)="D" D ^DIR K DIR Q:$D(DIRUT)!($D(DTOUT))
D PURGEMET(.DVBRTN,DUZ,Y)
I DVBRTN["Miss" W !!,"Missing Security Key, please check with your manager for additional assistance" Q
I DVBRTN'=1 W !!,"No records were purged",!! D PURGEOPT Q
I DVBRTN=1 W !!,"Purge completed"
Q
ALL(DVBLIST) ;
;RPC: DVBA CAPRI GET ALL PARAM
K DVBLIST
N DVBCNT,DVBPARAM,DVBVAL,DVBPAR,DVBSIY,DVBSIEN,DVBZ,DVBERR
S DVBCNT=0
S DVBPARAM="" F S DVBPARAM=$O(^XTV(8989.51,"B",DVBPARAM)) Q:DVBPARAM="" D
.S DVBPAR="" F S DVBPAR=$O(^XTV(8989.51,"B",DVBPARAM,DVBPAR)) Q:DVBPAR="" D
..S DVBZ="30*" K DVBSIY D GETS^DIQ(8989.51,DVBPAR,DVBZ,"I","DVBSIY","DVBERR") I $D(DVBERR) Q
..S DVBSIEN="" F S DVBSIEN=$O(DVBSIY(8989.513,DVBSIEN)) Q:DVBSIEN="" D
...N DVBENT S DVBENT=DVBSIY(8989.513,DVBSIEN,.02,"I") I DVBENT'=9.4 Q
...I DVBPARAM["XPAR" Q
...S DVBVAL=$$GET^XPAR("ALL",DVBPARAM,1,"Q")
...S DVBLIST(DVBCNT)=DVBPARAM_U_DVBVAL
...S DVBCNT=DVBCNT+1
Q
SPECADD(DVBMSG,DVBNAME) ;
;RPC: DVBA CAPRI SPEC ADD
;adds entry to Special Considerations
I $G(DVBNAME)="" S DVBMSG="0^Missing Special Considerations name" Q
K DVBMSG S DVBMSG="",DVBIEN=0
F S DVBIEN=$O(^DVB(396.25,DVBIEN)) Q:DVBIEN=""!('DVBIEN) D
.I $P(^DVB(396.25,DVBIEN,0),U,1)=DVBNAME S DVBMSG="0^Duplicate"
.Q
I DVBMSG="" D
.K DIC,DO,DIE,DA,DR,DLAYGO,X,Y
.N DIERR
.S DIC=396.25,DIC(0)="Z",X=DVBNAME D FILE^DICN
.S (DA)=+Y,DIE=DIC
.S DR=".02////1" D ^DIE
.I $D(DIERR) S DVBMSG="0^Record not added"
.I '$D(DIERR) S DVBMSG="1^Record added"
.K DIC,DO,DIE,DA,DR,DLAYGO,X,Y
.Q
Q
SPECDIS(DVBMSG,DVBIEN,DVBSTAT) ;
;RPC: DVBA CAPRI SPEC STATUS
;disables entry in Special Considerations
N DIERR
K DIC,DIE,DA,DR,DLAYGO,X,Y
I $G(DVBIEN)="" S DVBMSG="0^Missing IEN" Q
I $G(DVBSTAT)="" S DVBMSG="0^Missing Status" Q
S DA=DVBIEN,(DLAYGO,DIE)="^DVB(396.25,",DIC(0)="L"
S DR=".02////"_DVBSTAT D ^DIE
I $D(DIERR) S DVBMSG="0^Record not disabled"
I '$D(DIERR) S DVBMSG="1^Record disabled"
K DIC,DIE,DA,DR,DLAYGO,X,Y
Q
LISTSC(DVBMSG) ;
;RPC: DVBA CAPRI SPEC INACTIVE
;list inactive Special Considerations
N DVBIEN,DVBCNT,DVBRET
K ^TMP("DVBLSTSC",$J)
S DVBIEN=0,DVBCNT=0
F S DVBIEN=$O(^DVB(396.25,DVBIEN)) Q:DVBIEN=""!('DVBIEN) D
.Q:$G(^DVB(396.25,DVBIEN,0))=""
.Q:$P($G(^DVB(396.25,DVBIEN,0)),U,2)'=0
.S DVBRET(DVBCNT)=$P(^DVB(396.25,DVBIEN,0),"^",1)_"^"_DVBIEN
.M ^TMP("DVBLSTSC",$J,DVBCNT)=DVBRET(DVBCNT)
.S DVBCNT=DVBCNT+1
S DVBMSG=$NA(^TMP("DVBLSTSC",$J))
Q
SPLIT(DVBUPD,DVBDATA) ;
N DVBTOT,DVBPARTS,DVBPLUS,DVBST,DVBEND,DVBRTN,DVBCNT
S DVBTOT=$L(DVBDATA),DVBPARTS=DVBTOT\100,DVBPLUS=DVBTOT#100
I DVBPLUS'=0 S DVBPARTS=DVBPARTS+1
S DVBST=1,DVBEND=100
F DVBCNT=1:1:DVBPARTS D
. S DVBUPD(DVBCNT)=$E(DVBDATA,DVBST,DVBEND)
. S DVBST=DVBST+100,DVBEND=DVBEND+100
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPUSH 9025 printed Sep 23, 2025@19:21:27 Page 2
DVBCPUSH ;ALB/AKG/JD - CAPRI PUSH UTILITY RPC; APR 25, 2022@9:30am ; 5/19/23 9:07am
+1 ;;2.7;AMIE;**238,242,248,252,254**;Apr 10, 1995;Build 41
+2 ;Per VHA Directive 6402 this routine should not be modified
+3 ;ICR #2263 Supports all calls to Parameter File and XPAR usage
+4 ;
+5 QUIT
+6 ;
PARAMS(DVBLIST) ;returns data on the entire DVBA parameter list
+1 ;rpc returns all CAPRI namespaced Parameters
+2 ;RPC: DVBA CAPRI PARAM INQ
+3 ;Updated code to allow for multi-instance parameters for CAPRI-13378. JD - 9/10/24
+4 ;Update to return word processing parameters CAPRI-16484 2/24/25 CP
+5 ;
+6 KILL DVBLIST
+7 NEW DVBCNT,DVBD,DVBI,DVBPARAM,DVBPAR,DVBVAL,DVBERR,DVBTYP
+8 SET DVBCNT=0
+9 SET DVBPARAM=""
FOR
SET DVBPARAM=$ORDER(^XTV(8989.51,"B",DVBPARAM))
if DVBPARAM=""
QUIT
Begin DoDot:1
+10 IF $PIECE($PIECE(DVBPARAM,U,1)," ")'["DVBA"
QUIT
+11 SET DVBPAR=""
FOR
SET DVBPAR=$ORDER(^XTV(8989.51,"B",DVBPARAM,DVBPAR))
if DVBPAR=""
QUIT
Begin DoDot:2
+12 SET DVBTYP=$$GET1^DIQ(8989.51,DVBPAR,"1.1","I")
+13 IF DVBTYP'="W"
Begin DoDot:3
+14 DO GETLST^XPAR(.DVBVAL,"PKG",DVBPARAM,"Q")
+15 SET (DVBD,DVBI)=""
+16 FOR
SET DVBI=$ORDER(DVBVAL(DVBI))
if DVBI=""
QUIT
SET DVBD=DVBD_"|"_$PIECE(DVBVAL(DVBI),U,2)
+17 SET DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_$PIECE(DVBD,"|",2,9999)
+18 SET DVBCNT=DVBCNT+1
+19 QUIT
End DoDot:3
+20 IF DVBTYP="W"
Begin DoDot:3
+21 DO GETWP^XPAR(.DVBVAL,"PKG",DVBPARAM,1)
+22 SET (DVBD,DVBI)=""
+23 FOR
SET DVBI=$ORDER(DVBVAL(DVBI))
if DVBI=""
QUIT
SET DVBD=DVBD_"|"_$GET(DVBVAL(DVBI,0))
+24 SET DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_$PIECE(DVBD,"|",2,9999)
+25 SET DVBCNT=DVBCNT+1
+26 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
PARAMED(DVBMSG,DVBNAME,DVBVAL) ;
+1 ;edits exiting parameter value from CAPRI Push Utility
+2 ;RPC: DVBA CAPRI PARAM UPDATE
+3 ;Updated code to allow for multi-instance parameters for CAPRI-13378. JD - 9/11/24
+4 ;Update to allow saving of word processing parameters CAPRI-16484 2/24/25 CP
+5 ;
+6 IF $GET(DVBNAME)=""
SET DVBMSG="Missing parameter name"
QUIT
+7 KILL DVBMSG
SET DVBMSG=""
+8 NEW DVBCNF,DVBCNS,DVBCNT,DVBDLER,DVBERR,DVBF,DVBI,DVBPI,DVBVALV
+9 NEW DVBTYP,DVBLEN,DVBI,DVBUPD,DVBTMP
+10 SET (DVBCNF,DVBCNS,DVBCNT,DVBDLER,DVBERR)=0
+11 SET DVBPI=$ORDER(^XTV(8989.51,"B",DVBNAME,""))
+12 SET DVBTYP=$$GET1^DIQ(8989.51,DVBPI,"1.1","I")
+13 IF $DATA(^XTV(8989.5,"AC",DVBPI))>0
DO NDEL^XPAR("PKG",DVBNAME,.DVBDLER)
+14 IF DVBDLER'=0
SET DVBMSG=DVBDLER
QUIT
+15 IF $GET(DVBVAL)=""
SET DVBMSG="The entire parameter list has been deleted"
QUIT
+16 IF DVBTYP'="W"
Begin DoDot:1
+17 SET DVBF=""
+18 FOR DVBI=1:1:$LENGTH(DVBVAL,"|")
Begin DoDot:2
+19 SET DVBVALV=$PIECE(DVBVAL,"|",DVBI)
+20 DO EN^XPAR("PKG.AUTOMATED MED INFO EXCHANGE",DVBNAME,DVBI,DVBVALV,.DVBERR)
+21 SET DVBCNT=DVBCNT+1
+22 IF DVBERR
Begin DoDot:3
+23 SET DVBCNF=DVBCNF+1
+24 SET DVBF=DVBF_"|"_DVBI_","_$PIECE(DVBERR,U,2)
End DoDot:3
QUIT
+25 SET DVBCNS=DVBCNS+1
End DoDot:2
+26 SET DVBMSG=DVBCNS_"/"_DVBCNT_" "_$SELECT(DVBCNS=1:"was",1:"were")_" successful"_DVBF
End DoDot:1
+27 IF DVBTYP="W"
Begin DoDot:1
+28 SET DVBLEN=$LENGTH(DVBVAL,"|")
+29 IF DVBLEN>1
FOR DVBI=1:1:DVBLEN
SET DVBUPD(DVBI)=$PIECE(DVBVAL,"|",DVBI)
+30 IF DVBLEN=1
IF $LENGTH(DVBVAL)>250
DO SPLIT(.DVBUPD,DVBVAL)
+31 IF DVBLEN=1
IF $LENGTH(DVBVAL)<250
SET DVBUPD(1)=$GET(DVBVAL)
+32 IF DVBLEN=1
IF $DATA(DVBUPD)<10
SET DVBMSG="Issue trying to split Data"
QUIT
+33 IF DVBNAME="DVBAB CAPRI GITHUB TOKEN"
Begin DoDot:2
+34 SET DVBCNT=$ORDER(DVBUPD(""),-1)
+35 SET DVBTMP(1)="-----BEGIN RSA PRIVATE KEY-----"
+36 FOR DVBI=1:1:DVBCNT
SET DVBTMP(DVBI+1)=DVBUPD(DVBI)
+37 SET DVBTMP(DVBCNT+2)="-----END RSA PRIVATE KEY-----"
+38 KILL DVBUPD
MERGE DVBUPD=DVBTMP
+39 QUIT
End DoDot:2
+40 DO EN^XPAR("PKG",DVBNAME,1,.DVBUPD,.DVBERR)
+41 IF DVBERR'=0
SET DVBMSG=DVBERR
QUIT
+42 SET DVBMSG=DVBNAME_" was updated successfully"
QUIT
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
PARADESC(DVBRTN,DVBIEN) ;
+1 ;RPC; DVBA CAPRI GET PAR DESC
+2 ;returns description for selected parameter
+3 NEW DVBX,DVBTWP,DVBERR,DVBCT,DVBRT,DVBIENS,DVBTMP
+4 IF $GET(DVBIEN)=""
SET DVBRTN="Missing Parameter IEN"
QUIT
+5 DO GETS^DIQ(8989.51,DVBIEN,20,"","DVBTWP","DVBERR")
+6 IF $DATA(DVBERR)
SET DVBRTN=DVBERR
QUIT
+7 KILL DVBTMP
MERGE DVBTMP=DVBTWP
+8 SET DVBIENS=""_DVBIEN_","
+9 IF $DATA(DVBTMP)
Begin DoDot:1
+10 SET DVBCT=""
SET DVBX=""
FOR
SET DVBX=$ORDER(DVBTMP(8989.51,DVBIENS,20,DVBX))
if DVBX=""
QUIT
Begin DoDot:2
+11 SET DVBCT=DVBCT+1
+12 SET DVBRT(DVBCT)=DVBTMP(8989.51,DVBIENS,20,DVBX)
End DoDot:2
End DoDot:1
+13 MERGE DVBRTN=DVBRT
+14 KILL DVBRT,DVBTWP
+15 QUIT
+16 ;
EFOLDMET(DVBRTN,DVBAUTH,DVBPIEN,DVBTRANS,DVBSTAT,DVBERR,DVBRPD) ;
+1 ;RPC: DVBA CAPRI SET METRICS
+2 ;Input: DVBAUTH=Authorized User IEN
+3 ; DVBPIEN=Patient IEN
+4 ; DVBTRANS=Transmission Path
+5 ; DVBSTAT=Transmission Status
+6 ; DVBERR=Transmission Error Code
+7 ; DVBRPD=Report Details
+8 ;Output: RTN=0 for Failure and 1 for Success
+9 ;
+10 NEW DVBDT,DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DVBI,DVBRPC,DVBN1,DVBAIEN,DVBNUM
+11 IF DVBAUTH=""
SET DVBRTN="0^MISSING AUTHORIZED USER IEN"
QUIT
+12 IF DVBPIEN=""
SET DVBRTN="0^MISSING PATIENT IEN"
QUIT
+13 IF DVBTRANS=""
SET DVBRTN="0^MISSING TRANSMISSION PATH"
QUIT
+14 IF DVBSTAT=""
SET DVBRTN="0^MISSING TRANSMISSION STATUS"
QUIT
+15 SET DVBDT=$$NOW^XLFDT()
+16 KILL DIC,DIE,DR,DA
+17 SET (DIC,DIE)="^DVB(396.21,"
SET DIC(0)="L"
SET DLAYGO=396.21
SET X=DVBDT
+18 DO ^DIC
SET DA=+Y
KILL DIC
+19 IF DA=-1
SET DVBRTN=0
QUIT
+20 SET DVBRTN=1
+21 SET DR=".02////"_DVBAUTH_";.03////"_DVBPIEN_";1////"_DVBTRANS
DO ^DIE
+22 SET DR="1.1////"_DVBSTAT_";1.2////"_DVBERR
DO ^DIE
+23 SET DVBNUM=DA
+24 SET DVBI=""
FOR
SET DVBI=$ORDER(DVBRPD(DVBI))
if DVBI=""
QUIT
Begin DoDot:1
+25 SET DA(1)=DVBNUM
+26 SET DIC="^DVB(396.21,"_DA(1)_",2,"
SET DIC(0)="L"
+27 DO ^DIC
SET DA=+Y
+28 SET DIE=DIC
+29 SET DVBRPC=$PIECE(DVBRPD(DVBI),U)
SET DVBAIEN=$PIECE(DVBRPD(DVBI),U,2)
+30 SET DVBN1=$PIECE(DVBRPD(DVBI),U,3,100)
+31 SET DR=".01////"_DVBRPC_";.02////"_DVBAIEN_";.03////"_DVBN1
+32 DO ^DIE
End DoDot:1
+33 KILL DIC,DIE,DA,DR,DIRUT
+34 QUIT
+35 ;
PURGEMET(DVBRTN,DUZ,DVBDTP) ;
+1 ;RPC: DVBA CAPRI PURGE MET
+2 ;input: DUZ user must have the DVBA METRICS DATA PURGE key
+3 ; : Date to purge up to
+4 NEW DVBDT,DVBDA,DVBKEY,DVBDATE
+5 IF DUZ=""
SET DVBRTN="0^Missing DUZ"
QUIT
+6 IF DVBDTP=""
SET DVBRTN="0^Missing Date"
QUIT
+7 SET X=DVBDTP
DO ^%DT
SET DVBDATE=Y
+8 DO OWNSKEY^XUSRB(.DVBKEY,"DVBA CAPRI METRICS PURGE",DUZ)
+9 IF DVBKEY(0)=0
SET DVBRTN="0^Missing security key"
QUIT
+10 SET DVBDT=""
FOR
SET DVBDT=$ORDER(^DVB(396.21,"B",DVBDT))
if DVBDT=""
QUIT
Begin DoDot:1
+11 SET DVBDA=""
FOR
SET DVBDA=$ORDER(^DVB(396.21,"B",DVBDT,DVBDA))
if DVBDA=""
QUIT
Begin DoDot:2
+12 IF $PIECE(DVBDT,".")>DVBDATE
QUIT
+13 KILL DIC,DA,DIK
+14 SET DIC="^DVB(396.21,"
SET DA=DVBDA
+15 SET DIK=DIC
DO ^DIK
KILL DIK,DIC
+16 SET DVBRTN=1
End DoDot:2
End DoDot:1
+17 IF $GET(DVBRTN)'=1
SET DVBRTN="-1"
+18 QUIT
PURGEOPT ;
+1 WRITE !!,"CAPRI CLINICAL DOCUMENTS EFOLDER METRIC DATA PURGE",!!
+2 SET DIR("?")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file up to. For Example, to purge from today and older enter today's date"
+3 SET DIR("A")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file."
+4 SET DIR(0)="D"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+5 DO PURGEMET(.DVBRTN,DUZ,Y)
+6 IF DVBRTN["Miss"
WRITE !!,"Missing Security Key, please check with your manager for additional assistance"
QUIT
+7 IF DVBRTN'=1
WRITE !!,"No records were purged",!!
DO PURGEOPT
QUIT
+8 IF DVBRTN=1
WRITE !!,"Purge completed"
+9 QUIT
ALL(DVBLIST) ;
+1 ;RPC: DVBA CAPRI GET ALL PARAM
+2 KILL DVBLIST
+3 NEW DVBCNT,DVBPARAM,DVBVAL,DVBPAR,DVBSIY,DVBSIEN,DVBZ,DVBERR
+4 SET DVBCNT=0
+5 SET DVBPARAM=""
FOR
SET DVBPARAM=$ORDER(^XTV(8989.51,"B",DVBPARAM))
if DVBPARAM=""
QUIT
Begin DoDot:1
+6 SET DVBPAR=""
FOR
SET DVBPAR=$ORDER(^XTV(8989.51,"B",DVBPARAM,DVBPAR))
if DVBPAR=""
QUIT
Begin DoDot:2
+7 SET DVBZ="30*"
KILL DVBSIY
DO GETS^DIQ(8989.51,DVBPAR,DVBZ,"I","DVBSIY","DVBERR")
IF $DATA(DVBERR)
QUIT
+8 SET DVBSIEN=""
FOR
SET DVBSIEN=$ORDER(DVBSIY(8989.513,DVBSIEN))
if DVBSIEN=""
QUIT
Begin DoDot:3
+9 NEW DVBENT
SET DVBENT=DVBSIY(8989.513,DVBSIEN,.02,"I")
IF DVBENT'=9.4
QUIT
+10 IF DVBPARAM["XPAR"
QUIT
+11 SET DVBVAL=$$GET^XPAR("ALL",DVBPARAM,1,"Q")
+12 SET DVBLIST(DVBCNT)=DVBPARAM_U_DVBVAL
+13 SET DVBCNT=DVBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
SPECADD(DVBMSG,DVBNAME) ;
+1 ;RPC: DVBA CAPRI SPEC ADD
+2 ;adds entry to Special Considerations
+3 IF $GET(DVBNAME)=""
SET DVBMSG="0^Missing Special Considerations name"
QUIT
+4 KILL DVBMSG
SET DVBMSG=""
SET DVBIEN=0
+5 FOR
SET DVBIEN=$ORDER(^DVB(396.25,DVBIEN))
if DVBIEN=""!('DVBIEN)
QUIT
Begin DoDot:1
+6 IF $PIECE(^DVB(396.25,DVBIEN,0),U,1)=DVBNAME
SET DVBMSG="0^Duplicate"
+7 QUIT
End DoDot:1
+8 IF DVBMSG=""
Begin DoDot:1
+9 KILL DIC,DO,DIE,DA,DR,DLAYGO,X,Y
+10 NEW DIERR
+11 SET DIC=396.25
SET DIC(0)="Z"
SET X=DVBNAME
DO FILE^DICN
+12 SET (DA)=+Y
SET DIE=DIC
+13 SET DR=".02////1"
DO ^DIE
+14 IF $DATA(DIERR)
SET DVBMSG="0^Record not added"
+15 IF '$DATA(DIERR)
SET DVBMSG="1^Record added"
+16 KILL DIC,DO,DIE,DA,DR,DLAYGO,X,Y
+17 QUIT
End DoDot:1
+18 QUIT
SPECDIS(DVBMSG,DVBIEN,DVBSTAT) ;
+1 ;RPC: DVBA CAPRI SPEC STATUS
+2 ;disables entry in Special Considerations
+3 NEW DIERR
+4 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
+5 IF $GET(DVBIEN)=""
SET DVBMSG="0^Missing IEN"
QUIT
+6 IF $GET(DVBSTAT)=""
SET DVBMSG="0^Missing Status"
QUIT
+7 SET DA=DVBIEN
SET (DLAYGO,DIE)="^DVB(396.25,"
SET DIC(0)="L"
+8 SET DR=".02////"_DVBSTAT
DO ^DIE
+9 IF $DATA(DIERR)
SET DVBMSG="0^Record not disabled"
+10 IF '$DATA(DIERR)
SET DVBMSG="1^Record disabled"
+11 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
+12 QUIT
LISTSC(DVBMSG) ;
+1 ;RPC: DVBA CAPRI SPEC INACTIVE
+2 ;list inactive Special Considerations
+3 NEW DVBIEN,DVBCNT,DVBRET
+4 KILL ^TMP("DVBLSTSC",$JOB)
+5 SET DVBIEN=0
SET DVBCNT=0
+6 FOR
SET DVBIEN=$ORDER(^DVB(396.25,DVBIEN))
if DVBIEN=""!('DVBIEN)
QUIT
Begin DoDot:1
+7 if $GET(^DVB(396.25,DVBIEN,0))=""
QUIT
+8 if $PIECE($GET(^DVB(396.25,DVBIEN,0)),U,2)'=0
QUIT
+9 SET DVBRET(DVBCNT)=$PIECE(^DVB(396.25,DVBIEN,0),"^",1)_"^"_DVBIEN
+10 MERGE ^TMP("DVBLSTSC",$JOB,DVBCNT)=DVBRET(DVBCNT)
+11 SET DVBCNT=DVBCNT+1
End DoDot:1
+12 SET DVBMSG=$NAME(^TMP("DVBLSTSC",$JOB))
+13 QUIT
SPLIT(DVBUPD,DVBDATA) ;
+1 NEW DVBTOT,DVBPARTS,DVBPLUS,DVBST,DVBEND,DVBRTN,DVBCNT
+2 SET DVBTOT=$LENGTH(DVBDATA)
SET DVBPARTS=DVBTOT\100
SET DVBPLUS=DVBTOT#100
+3 IF DVBPLUS'=0
SET DVBPARTS=DVBPARTS+1
+4 SET DVBST=1
SET DVBEND=100
+5 FOR DVBCNT=1:1:DVBPARTS
Begin DoDot:1
+6 SET DVBUPD(DVBCNT)=$EXTRACT(DVBDATA,DVBST,DVBEND)
+7 SET DVBST=DVBST+100
SET DVBEND=DVBEND+100
+8 QUIT
End DoDot:1
+9 QUIT
