DVBCWKSHT ;ALB/CP/JD - CAPRI 2507 Worksheet Updates; July 11, 2023@14:08 ; 3/20/24 3:55pm
;;2.7;AMIE;**252,254**;Apr 10, 1995;Build 41
; Per VHA Directive 6402 this routine should not be modified
; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
; Reference to UP^XLFSTR in ICR #10104
; Reference to OWNSKEY^XUSRB ICR #3277: Verify Security Keys Assigned to a User
Q
;
;Added DVBF1 (Acceptable Clinical Evidence (ACE)) as a new parameter for CAPRI-13939. JD - 10/3/24
;Added DVBF12 (IEPD version number) as a new parameter - CAPRI-9566. JD - 4/23/24
;Adding check for Signed worksheet to block Document Manager Update CAPRI-12506 CP 7-31-24
WKSHTSAVE(DVBRTN,DVBIEN,DVBAUTH,DVBTRAN,DVBDBQ,DVBF19,DVBF20,DVBF21,DVBF12,DVBF1) ;
;RPC: DVBA CAPRI WORKSHEET UPDATE
;Updates CAPRI-16627 CP 3/10/25
;K DIC,DIE,DA,DR,DLAYGO,X,Y
N DVBERROR,DVBTEMPER,DVBLRTN,DVBDTTM,DVBLOCKDT
S DVBUPDFG=""
;
I DVBAUTH'="" D
. I DVBAUTH'?1.N S DVBRTN(1)="-1^Author Invalid Format" Q
. ;Adding check for Locked worksheet CAPRI-12506 CP 7-30-24
. S DVBLOCKDT=$P($G(^DVB(396.17,DVBIEN,0)),U,5)
. I DVBLOCKDT'="2800101" S DVBRTN(1)="-1^Worksheet is Signed and Locked, Can not Update Document Manager" Q
. S DVBAFDA(396.17,DVBIEN_",",2)=DVBAUTH
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(1)="1^Document Manager has been updated",DVBUPDFG=1
. Q
I DVBTRAN'="" D
. I DVBTRAN'?1.N S DVBRTN(2)="-1^Transcriber Invalid Format" Q
. S DVBAFDA(396.17,DVBIEN_",",10)=DVBTRAN
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(2)="1^Transcriber has been updated",DVBUPDFG=1
. Q
I DVBDBQ'="" D
. I "YN"'[DVBDBQ S DVBRTN(3)="-1^DBQ Referral Invalid Format" Q
. S DVBAFDA(396.17,DVBIEN_",",25)=DVBDBQ
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(3)="1^DBQ Referral has been updated",DVBUPDFG=1
. Q
I DVBF19'="" D
. I "01@"'[DVBF19 S DVBRTN(4)="-1^New Flag Invalid Format" Q
. S DVBAFDA(396.17,DVBIEN_",",19)=DVBF19
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(4)="1^New Flag has been updated",DVBUPDFG=1
. Q
I DVBF20'="" D
. I "01@"'[DVBF20 S DVBRTN(5)="-1^Green Flag Invalid Format" Q
. S DVBAFDA(396.17,DVBIEN_",",20)=DVBF20
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(5)="1^Green Flag has been updated",DVBUPDFG=1
. Q
I DVBF21'="" D
. I "01@"'[DVBF21 S DVBRTN(6)="-1^Exclamation Flag Invalid Format" Q
. S DVBAFDA(396.17,DVBIEN_",",21)=DVBF21
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(6)="1^Exclamation Flag has been updated",DVBUPDFG=1
. Q
;Next IF block is added for CAPRI-9566.
I DVBF12'="" D
. I $L(DVBF12)<2!($L(DVBF12)>250) S DVBRTN(7)="-1^IEPD version number is free text between 2 and 250 characters long" Q
. S DVBAFDA(396.17,DVBIEN_",",12)=DVBF12
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(7)="1^IEPD version number has been updated",DVBUPDFG=1
. Q
;Next IF block is added for CAPRI-13939.
I $G(DVBF1)'="" D
. N DVBF1S
. S DVBF1S=$$UP^XLFSTR($E(DVBF1))
. I "YN"'[DVBF1S S DVBRTN(8)="-1^Acceptable Clinical Evidence (ACE) is a Yes/No field. Received: "_DVBF1 Q
. S DVBAFDA(396.17,DVBIEN_",",1)=DVBF1S
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(8)="1^Acceptable Clinical Evidence (ACE) has been updated",DVBUPDFG=1
. Q
I DVBUPDFG'="" D
. S DVBDTTM=$$NOW^XLFDT
. S DVBAFDA(396.17,DVBIEN_",",4)=DVBDTTM
. K DVBTEMPER D FILE^DIE(,"DVBAFDA","DVBTEMPER")
. I $G(DVBTEMPER)'="" M DVBERROR=DVBTEMPER
. I $G(DVBTEMPER)="" S DVBRTN(0)="1^Updated Record Date/Time"
. Q
I $G(DVBERROR)'="" S DVBRTN("ERR")=DVBERROR
;Added DVBF12 to the list
;Added DVBF1 to the list
K DVBAFDA,DVBAUTH,DVBTRAN,DVBDBQ,DVBF1,DVBF12,DVBF19,DVBF20,DVBF21,DVBERROR,DVBTEMPER,DVBLRTN,DVBDTTM,DVBUPDFG,DVBLOCKDT
Q
OPENCHECK(DVBRTN,DVBIEN) ;
;RPC: DVBA CAPRI OPEN ACCESS CHECK
;CAPRI-18210 CP 4/17/25
N DVBKY,DVBDOCMAN,DVBTRANS,DVBWORKOG
;
I DVBIEN="" S DVBRTN="-1^Missing Worksheet Number." Q
I $D(^DVB(396.17,DVBIEN))<10 S DVBRTN="-1^No Worksheet data found." Q
S DVBRTN=0
;
D OWNSKEY^XUSRB(.DVBKY,"DVBAB CPWM REVIEWER",DUZ)
I $G(DVBKY(0)) S DVBRTN=1 Q
I $G(DUZ(0))="@" S DVBRTN=1 Q
;
S DVBDOCMAN=$P($G(^DVB(396.17,DVBIEN,0)),U,2)
I DVBDOCMAN="" S DVBRTN="-1^Missing Document Manager" Q
I DVBDOCMAN=DUZ S DVBRTN=1 Q
S DVBTRANS=$P($G(^DVB(396.17,DVBIEN,5)),U,1)
I DVBTRANS="" S DVBRTN="-1^Missing Transcriber" Q
I DVBTRANS=DUZ S DVBRTN=1 Q
S DVBWORKOG=$P($G(^DVB(396.17,DVBIEN,0)),U,6)
I DVBWORKOG="" S DVBRTN="-1^Missing Worksheet Originator" Q
I DVBWORKOG=DUZ S DVBRTN=1 Q
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCWKSHT 5172 printed Sep 23, 2025@19:28:16 Page 2
DVBCWKSHT ;ALB/CP/JD - CAPRI 2507 Worksheet Updates; July 11, 2023@14:08 ; 3/20/24 3:55pm
+1 ;;2.7;AMIE;**252,254**;Apr 10, 1995;Build 41
+2 ; Per VHA Directive 6402 this routine should not be modified
+3 ; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
+4 ; Reference to UP^XLFSTR in ICR #10104
+5 ; Reference to OWNSKEY^XUSRB ICR #3277: Verify Security Keys Assigned to a User
+6 QUIT
+7 ;
+8 ;Added DVBF1 (Acceptable Clinical Evidence (ACE)) as a new parameter for CAPRI-13939. JD - 10/3/24
+9 ;Added DVBF12 (IEPD version number) as a new parameter - CAPRI-9566. JD - 4/23/24
+10 ;Adding check for Signed worksheet to block Document Manager Update CAPRI-12506 CP 7-31-24
WKSHTSAVE(DVBRTN,DVBIEN,DVBAUTH,DVBTRAN,DVBDBQ,DVBF19,DVBF20,DVBF21,DVBF12,DVBF1) ;
+1 ;RPC: DVBA CAPRI WORKSHEET UPDATE
+2 ;Updates CAPRI-16627 CP 3/10/25
+3 ;K DIC,DIE,DA,DR,DLAYGO,X,Y
+4 NEW DVBERROR,DVBTEMPER,DVBLRTN,DVBDTTM,DVBLOCKDT
+5 SET DVBUPDFG=""
+6 ;
+7 IF DVBAUTH'=""
Begin DoDot:1
+8 IF DVBAUTH'?1.N
SET DVBRTN(1)="-1^Author Invalid Format"
QUIT
+9 ;Adding check for Locked worksheet CAPRI-12506 CP 7-30-24
+10 SET DVBLOCKDT=$PIECE($GET(^DVB(396.17,DVBIEN,0)),U,5)
+11 IF DVBLOCKDT'="2800101"
SET DVBRTN(1)="-1^Worksheet is Signed and Locked, Can not Update Document Manager"
QUIT
+12 SET DVBAFDA(396.17,DVBIEN_",",2)=DVBAUTH
+13 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+14 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+15 IF $GET(DVBTEMPER)=""
SET DVBRTN(1)="1^Document Manager has been updated"
SET DVBUPDFG=1
+16 QUIT
End DoDot:1
+17 IF DVBTRAN'=""
Begin DoDot:1
+18 IF DVBTRAN'?1.N
SET DVBRTN(2)="-1^Transcriber Invalid Format"
QUIT
+19 SET DVBAFDA(396.17,DVBIEN_",",10)=DVBTRAN
+20 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+21 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+22 IF $GET(DVBTEMPER)=""
SET DVBRTN(2)="1^Transcriber has been updated"
SET DVBUPDFG=1
+23 QUIT
End DoDot:1
+24 IF DVBDBQ'=""
Begin DoDot:1
+25 IF "YN"'[DVBDBQ
SET DVBRTN(3)="-1^DBQ Referral Invalid Format"
QUIT
+26 SET DVBAFDA(396.17,DVBIEN_",",25)=DVBDBQ
+27 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+28 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+29 IF $GET(DVBTEMPER)=""
SET DVBRTN(3)="1^DBQ Referral has been updated"
SET DVBUPDFG=1
+30 QUIT
End DoDot:1
+31 IF DVBF19'=""
Begin DoDot:1
+32 IF "01@"'[DVBF19
SET DVBRTN(4)="-1^New Flag Invalid Format"
QUIT
+33 SET DVBAFDA(396.17,DVBIEN_",",19)=DVBF19
+34 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+35 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+36 IF $GET(DVBTEMPER)=""
SET DVBRTN(4)="1^New Flag has been updated"
SET DVBUPDFG=1
+37 QUIT
End DoDot:1
+38 IF DVBF20'=""
Begin DoDot:1
+39 IF "01@"'[DVBF20
SET DVBRTN(5)="-1^Green Flag Invalid Format"
QUIT
+40 SET DVBAFDA(396.17,DVBIEN_",",20)=DVBF20
+41 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+42 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+43 IF $GET(DVBTEMPER)=""
SET DVBRTN(5)="1^Green Flag has been updated"
SET DVBUPDFG=1
+44 QUIT
End DoDot:1
+45 IF DVBF21'=""
Begin DoDot:1
+46 IF "01@"'[DVBF21
SET DVBRTN(6)="-1^Exclamation Flag Invalid Format"
QUIT
+47 SET DVBAFDA(396.17,DVBIEN_",",21)=DVBF21
+48 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+49 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+50 IF $GET(DVBTEMPER)=""
SET DVBRTN(6)="1^Exclamation Flag has been updated"
SET DVBUPDFG=1
+51 QUIT
End DoDot:1
+52 ;Next IF block is added for CAPRI-9566.
+53 IF DVBF12'=""
Begin DoDot:1
+54 IF $LENGTH(DVBF12)<2!($LENGTH(DVBF12)>250)
SET DVBRTN(7)="-1^IEPD version number is free text between 2 and 250 characters long"
QUIT
+55 SET DVBAFDA(396.17,DVBIEN_",",12)=DVBF12
+56 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+57 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+58 IF $GET(DVBTEMPER)=""
SET DVBRTN(7)="1^IEPD version number has been updated"
SET DVBUPDFG=1
+59 QUIT
End DoDot:1
+60 ;Next IF block is added for CAPRI-13939.
+61 IF $GET(DVBF1)'=""
Begin DoDot:1
+62 NEW DVBF1S
+63 SET DVBF1S=$$UP^XLFSTR($EXTRACT(DVBF1))
+64 IF "YN"'[DVBF1S
SET DVBRTN(8)="-1^Acceptable Clinical Evidence (ACE) is a Yes/No field. Received: "_DVBF1
QUIT
+65 SET DVBAFDA(396.17,DVBIEN_",",1)=DVBF1S
+66 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+67 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+68 IF $GET(DVBTEMPER)=""
SET DVBRTN(8)="1^Acceptable Clinical Evidence (ACE) has been updated"
SET DVBUPDFG=1
+69 QUIT
End DoDot:1
+70 IF DVBUPDFG'=""
Begin DoDot:1
+71 SET DVBDTTM=$$NOW^XLFDT
+72 SET DVBAFDA(396.17,DVBIEN_",",4)=DVBDTTM
+73 KILL DVBTEMPER
DO FILE^DIE(,"DVBAFDA","DVBTEMPER")
+74 IF $GET(DVBTEMPER)'=""
MERGE DVBERROR=DVBTEMPER
+75 IF $GET(DVBTEMPER)=""
SET DVBRTN(0)="1^Updated Record Date/Time"
+76 QUIT
End DoDot:1
+77 IF $GET(DVBERROR)'=""
SET DVBRTN("ERR")=DVBERROR
+78 ;Added DVBF12 to the list
+79 ;Added DVBF1 to the list
+80 KILL DVBAFDA,DVBAUTH,DVBTRAN,DVBDBQ,DVBF1,DVBF12,DVBF19,DVBF20,DVBF21,DVBERROR,DVBTEMPER,DVBLRTN,DVBDTTM,DVBUPDFG,DVBLOCKDT
+81 QUIT
OPENCHECK(DVBRTN,DVBIEN) ;
+1 ;RPC: DVBA CAPRI OPEN ACCESS CHECK
+2 ;CAPRI-18210 CP 4/17/25
+3 NEW DVBKY,DVBDOCMAN,DVBTRANS,DVBWORKOG
+4 ;
+5 IF DVBIEN=""
SET DVBRTN="-1^Missing Worksheet Number."
QUIT
+6 IF $DATA(^DVB(396.17,DVBIEN))<10
SET DVBRTN="-1^No Worksheet data found."
QUIT
+7 SET DVBRTN=0
+8 ;
+9 DO OWNSKEY^XUSRB(.DVBKY,"DVBAB CPWM REVIEWER",DUZ)
+10 IF $GET(DVBKY(0))
SET DVBRTN=1
QUIT
+11 IF $GET(DUZ(0))="@"
SET DVBRTN=1
QUIT
+12 ;
+13 SET DVBDOCMAN=$PIECE($GET(^DVB(396.17,DVBIEN,0)),U,2)
+14 IF DVBDOCMAN=""
SET DVBRTN="-1^Missing Document Manager"
QUIT
+15 IF DVBDOCMAN=DUZ
SET DVBRTN=1
QUIT
+16 SET DVBTRANS=$PIECE($GET(^DVB(396.17,DVBIEN,5)),U,1)
+17 IF DVBTRANS=""
SET DVBRTN="-1^Missing Transcriber"
QUIT
+18 IF DVBTRANS=DUZ
SET DVBRTN=1
QUIT
+19 SET DVBWORKOG=$PIECE($GET(^DVB(396.17,DVBIEN,0)),U,6)
+20 IF DVBWORKOG=""
SET DVBRTN="-1^Missing Worksheet Originator"
QUIT
+21 IF DVBWORKOG=DUZ
SET DVBRTN=1
QUIT
+22 ;
+23 QUIT
