DVBCTXML ;ALB/BG - CAPRI XML RPCS; FEB 6, 2023@16:20 ; 10/25/23 10:47am
;;2.7;AMIE;**250**;Apr 10, 1995;Build 19
; Per VHA Directive 6402 this routine should not be modified
; Reference to SUPPORTED PARAMETER TOOL ENTRY POINTS in ICR #2263
; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
Q
;
FAILIST(DVBFAIL,DVBDUZ) ; rpc entry to return list of failed xml transmissions
N DVBNCT,DVBAUTH,DVBALL,DVBLIST,DVBSTA,DVBNAME,DVBORG,DVBNOW,DVBCOMP,DVBPT,DVBIEN,DVBCT,DVBFLAG,DVBDATE,DVBPATCH
K ^TMP("CAPRI XML LIST",$J) S DVBNCT=""
S DVBALL=1 I '$D(DVBDUZ) S DVBALL=0
S DVBPATCH=3231025,DVBIEN=""
S DVBDATE=DVBPATCH F S DVBDATE=$O(^DVB(396.17,"C",DVBDATE)) Q:DVBDATE="" D
.S DVBIEN="" F S DVBIEN=$O(^DVB(396.17,"C",DVBDATE,DVBIEN)) Q:DVBIEN="" D
..I '$D(^DVB(396.17,DVBIEN,14,"B")) Q
..S DVBAUTH=$$GET1^DIQ(396.17,DVBIEN,"2","I") I (DVBALL=1)&($G(DVBDUZ)'=DVBAUTH) Q
..S DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
..S DVBCT=0 F S DVBCT=$O(^DVB(396.17,DVBIEN,14,"B",DVBCT)) Q:DVBCT="" D
...S DVBFLAG=0,DVBINN=""_DVBCT_","_DVBIEN_","_""
...S DVBSTA=$$GET1^DIQ(396.1726,DVBINN,".02","I")
...I DVBSTA="C" Q
...S DVBORG=$$GET1^DIQ(396.1726,DVBINN,".05","I")
...S DVBNAME=$$GET1^DIQ(396.1726,DVBINN,".03","E")
...S DVBNOW=$$NOW^XLFDT S DVBDT=$$FMDIFF^XLFDT(DVBNOW,DVBORG,3)
...S DVBCOMP=$P(DVBDT," ",1) I DVBCOMP>=1 S DVBFLAG=1
...S DVBORG=$$FMTE^XLFDT(DVBORG,1)
...S DVBLIST=DVBIEN_U_DVBCT_U_DVBNAME_U_DVBPT_U_DVBORG_U_DVBFLAG_";"
...S DVBNCT=DVBNCT+1 M ^TMP("CAPRI XML LIST",$J,DVBNCT)=DVBLIST
...Q
S DVBFAIL=$NA(^TMP("CAPRI XML LIST",$J))
Q
;
FAILXML(DVBXML,DVBIEN,DVBCT) ;
N DVBABCNT,DVBFXML,DVNCT,DVBFXML,DVBABIEN K ^TMP("DVBAXML",$J)
I '$D(^DVB(396.17,DVBIEN)) S DVBXML="0^NO RECORD EXISTS" Q
I '$D(^DVB(396.17,DVBIEN,14,DVBCT)) S DVBXML="0^NO RECORD EXISTS" Q
S DVBABCNT=1,DVBABIEN=0,DVNCT=0
S DVBRTN=$$LOCK(DVBIEN,DVBCT) I DVBRTN=0 S DVBXML="1^LOCKED RECORD" Q
F S DVBABIEN=$O(^DVB(396.17,DVBIEN,14,DVBCT,3,DVBABIEN)) Q:'DVBABIEN D
.S DVBFXML=$G(^DVB(396.17,DVBIEN,14,DVBCT,3,DVBABCNT,0))
.I DVBABCNT=1 S DVBFXML="1"_U_DVBFXML
.S DVBABCNT=DVBABCNT+1,DVNCT=DVNCT+1 M ^TMP("DVBAXML",$J,DVNCT)=DVBFXML
.Q
S DVBXML=$NA(^TMP("DVBAXML",$J))
D UNLOCK(DVBIEN,DVBCT)
Q
;
SAVEXML(DVBRTN,DVBNAME,DVBCT,DVBCNT,DVBXML,DVBSTAT,DVBRESP,DVBIEN) ;
I $G(DVBCT)="" S DVBCT=1
I $G(DVBCNT)="" S DVBCNT=1
S DVBRESP="Initial Save"
D STATUS(.DVBRTN,DVBIEN,DVBCT,DVBNAME,DVBSTAT,DVBRESP)
D FILEIN(.DVBRTN,DVBIEN,DVBCT,DVBCNT,.DVBXML)
K DIC,DIE,DA,DR,DLAYGO,X,Y
S DVBRTN=DVBRTN
Q
FILEIN(DVBRTN,DVBIEN,DVBCT,DVBCNT,DVBXML) ;
N DVBERR
D WP^DIE(396.1726,DVBCT_","_DVBIEN_",",.04,"K","DVBXML","DVBERR")
I $D(DVBERR) S DVBRTN=$G(DVBERR) Q
S DVBRTN=DVBRTN
Q
STATUS(DVBRTN,DVBIEN,DVBCT,DVBNAME,DVBSTAT,DVBRESP) ;
N DVBCNT,DVBDT,DVBNWIEN,DVBINN,DVBTRANS,DVBSTA
S DVBSTA=$S(DVBSTAT=1:"C",1:"E")
I '$D(DVBRESP)!(DVBRESP="")&(DVBSTA="C") S DVBRESP="TRANSMISSION COMPLETE"
S DVBDT=$$NOW^XLFDT,DVBCNT=""
S DVBCNT=$O(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT),-1)
S DVBCNT=$G(DVBCNT)+1
K DIC,DIE,DA,DR,DLAYGO,X,Y
S DA(2)=DVBIEN,DA(1)=DVBCT,X=DVBCNT
S (DLAYGO,DIC)="^DVB(396.17,"_DA(2)_",14,"_DA(1)_",10,",DIC(0)="L"
D ^DIC
S (DA,DVBNWIEN)=+Y
S DIE=DIC
S DR=".01////"_DVBNWIEN_";.02////"_DVBDT_";.03////"_DUZ_";.04////"_DVBRESP
D ^DIE K DIE,DIC,DA,DR,DLAYGO,X,Y
S DVBINN=""_DVBCT_","_DVBIEN_","_""
S DVBTRANS=$$GET1^DIQ(396.1726,DVBINN,".07","I")
I DVBRESP'="Initial Save" S DVBTRANS=$G(DVBTRANS)+1
S DA(1)=DVBIEN,DA=DVBCT
S (DLAYGO,DIC)="^DVB(396.17,"_DA(1)_",14,",DIC(0)="L"
D ^DIC
S DIE=DIC
S DR=".01////"_DVBCT_";.07////"_DVBTRANS_";.02////"_DVBSTA
D ^DIE
I DVBSTA="C" S DR=".09////"_DVBDT D ^DIE
I $G(DVBNAME)'="" S DR=".03////"_DVBNAME D ^DIE
I DVBRESP="Initial Save" S DR=".05////"_DVBDT D ^DIE
S DVBRTN=1 I $D(DIERR) S DVBRTN=0
D UNLOCK(DVBIEN,DVBCT)
K DIC,DIE,DIERR,DA,DR,DLAYGO,X
Q
;
LOCK(DVBIEN,DVBCT) ;
L +^DVB(396.17,DVBIEN,14,DVBCT,3):30
S DVBRTN=$T
Q DVBRTN
;
UNLOCK(DVBIEN,DVBCT) ;
L -^DVB(396.17,DVBIEN,14,DVBCT,3)
Q
;
FAILCHK(DVBRTN) ;
K DVBRTN S DVBRTN=0,DVBPATCH=3231025
S DVBDATE=DVBPATCH F S DVBDATE=$O(^DVB(396.17,"C",DVBDATE)) Q:(DVBDATE="")!(DVBRTN=1) D
.S DVBIEN="" F S DVBIEN=$O(^DVB(396.17,"C",DVBDATE,DVBIEN)) Q:(DVBIEN="")!(DVBRTN=1) D
..I $D(^DVB(396.17,DVBIEN,14,"B")) D
...S DVBCT=0 F S DVBCT=$O(^DVB(396.17,DVBIEN,14,"B",DVBCT)) Q:(DVBCT="")!(DVBRTN=1) D
....S DVBINN=""_DVBCT_","_DVBIEN_","_""
....S DVBSTA=$$GET1^DIQ(396.1726,DVBINN,".02","I")
....I DVBSTA'="C" S DVBRTN=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCTXML 4607 printed Oct 16, 2024@17:49:55 Page 2
DVBCTXML ;ALB/BG - CAPRI XML RPCS; FEB 6, 2023@16:20 ; 10/25/23 10:47am
+1 ;;2.7;AMIE;**250**;Apr 10, 1995;Build 19
+2 ; Per VHA Directive 6402 this routine should not be modified
+3 ; Reference to SUPPORTED PARAMETER TOOL ENTRY POINTS in ICR #2263
+4 ; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
+5 QUIT
+6 ;
FAILIST(DVBFAIL,DVBDUZ) ; rpc entry to return list of failed xml transmissions
+1 NEW DVBNCT,DVBAUTH,DVBALL,DVBLIST,DVBSTA,DVBNAME,DVBORG,DVBNOW,DVBCOMP,DVBPT,DVBIEN,DVBCT,DVBFLAG,DVBDATE,DVBPATCH
+2 KILL ^TMP("CAPRI XML LIST",$JOB)
SET DVBNCT=""
+3 SET DVBALL=1
IF '$DATA(DVBDUZ)
SET DVBALL=0
+4 SET DVBPATCH=3231025
SET DVBIEN=""
+5 SET DVBDATE=DVBPATCH
FOR
SET DVBDATE=$ORDER(^DVB(396.17,"C",DVBDATE))
if DVBDATE=""
QUIT
Begin DoDot:1
+6 SET DVBIEN=""
FOR
SET DVBIEN=$ORDER(^DVB(396.17,"C",DVBDATE,DVBIEN))
if DVBIEN=""
QUIT
Begin DoDot:2
+7 IF '$DATA(^DVB(396.17,DVBIEN,14,"B"))
QUIT
+8 SET DVBAUTH=$$GET1^DIQ(396.17,DVBIEN,"2","I")
IF (DVBALL=1)&($GET(DVBDUZ)'=DVBAUTH)
QUIT
+9 SET DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
+10 SET DVBCT=0
FOR
SET DVBCT=$ORDER(^DVB(396.17,DVBIEN,14,"B",DVBCT))
if DVBCT=""
QUIT
Begin DoDot:3
+11 SET DVBFLAG=0
SET DVBINN=""_DVBCT_","_DVBIEN_","_""
+12 SET DVBSTA=$$GET1^DIQ(396.1726,DVBINN,".02","I")
+13 IF DVBSTA="C"
QUIT
+14 SET DVBORG=$$GET1^DIQ(396.1726,DVBINN,".05","I")
+15 SET DVBNAME=$$GET1^DIQ(396.1726,DVBINN,".03","E")
+16 SET DVBNOW=$$NOW^XLFDT
SET DVBDT=$$FMDIFF^XLFDT(DVBNOW,DVBORG,3)
+17 SET DVBCOMP=$PIECE(DVBDT," ",1)
IF DVBCOMP>=1
SET DVBFLAG=1
+18 SET DVBORG=$$FMTE^XLFDT(DVBORG,1)
+19 SET DVBLIST=DVBIEN_U_DVBCT_U_DVBNAME_U_DVBPT_U_DVBORG_U_DVBFLAG_";"
+20 SET DVBNCT=DVBNCT+1
MERGE ^TMP("CAPRI XML LIST",$JOB,DVBNCT)=DVBLIST
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 SET DVBFAIL=$NAME(^TMP("CAPRI XML LIST",$JOB))
+23 QUIT
+24 ;
FAILXML(DVBXML,DVBIEN,DVBCT) ;
+1 NEW DVBABCNT,DVBFXML,DVNCT,DVBFXML,DVBABIEN
KILL ^TMP("DVBAXML",$JOB)
+2 IF '$DATA(^DVB(396.17,DVBIEN))
SET DVBXML="0^NO RECORD EXISTS"
QUIT
+3 IF '$DATA(^DVB(396.17,DVBIEN,14,DVBCT))
SET DVBXML="0^NO RECORD EXISTS"
QUIT
+4 SET DVBABCNT=1
SET DVBABIEN=0
SET DVNCT=0
+5 SET DVBRTN=$$LOCK(DVBIEN,DVBCT)
IF DVBRTN=0
SET DVBXML="1^LOCKED RECORD"
QUIT
+6 FOR
SET DVBABIEN=$ORDER(^DVB(396.17,DVBIEN,14,DVBCT,3,DVBABIEN))
if 'DVBABIEN
QUIT
Begin DoDot:1
+7 SET DVBFXML=$GET(^DVB(396.17,DVBIEN,14,DVBCT,3,DVBABCNT,0))
+8 IF DVBABCNT=1
SET DVBFXML="1"_U_DVBFXML
+9 SET DVBABCNT=DVBABCNT+1
SET DVNCT=DVNCT+1
MERGE ^TMP("DVBAXML",$JOB,DVNCT)=DVBFXML
+10 QUIT
End DoDot:1
+11 SET DVBXML=$NAME(^TMP("DVBAXML",$JOB))
+12 DO UNLOCK(DVBIEN,DVBCT)
+13 QUIT
+14 ;
SAVEXML(DVBRTN,DVBNAME,DVBCT,DVBCNT,DVBXML,DVBSTAT,DVBRESP,DVBIEN) ;
+1 IF $GET(DVBCT)=""
SET DVBCT=1
+2 IF $GET(DVBCNT)=""
SET DVBCNT=1
+3 SET DVBRESP="Initial Save"
+4 DO STATUS(.DVBRTN,DVBIEN,DVBCT,DVBNAME,DVBSTAT,DVBRESP)
+5 DO FILEIN(.DVBRTN,DVBIEN,DVBCT,DVBCNT,.DVBXML)
+6 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
+7 SET DVBRTN=DVBRTN
+8 QUIT
FILEIN(DVBRTN,DVBIEN,DVBCT,DVBCNT,DVBXML) ;
+1 NEW DVBERR
+2 DO WP^DIE(396.1726,DVBCT_","_DVBIEN_",",.04,"K","DVBXML","DVBERR")
+3 IF $DATA(DVBERR)
SET DVBRTN=$GET(DVBERR)
QUIT
+4 SET DVBRTN=DVBRTN
+5 QUIT
STATUS(DVBRTN,DVBIEN,DVBCT,DVBNAME,DVBSTAT,DVBRESP) ;
+1 NEW DVBCNT,DVBDT,DVBNWIEN,DVBINN,DVBTRANS,DVBSTA
+2 SET DVBSTA=$SELECT(DVBSTAT=1:"C",1:"E")
+3 IF '$DATA(DVBRESP)!(DVBRESP="")&(DVBSTA="C")
SET DVBRESP="TRANSMISSION COMPLETE"
+4 SET DVBDT=$$NOW^XLFDT
SET DVBCNT=""
+5 SET DVBCNT=$ORDER(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT),-1)
+6 SET DVBCNT=$GET(DVBCNT)+1
+7 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
+8 SET DA(2)=DVBIEN
SET DA(1)=DVBCT
SET X=DVBCNT
+9 SET (DLAYGO,DIC)="^DVB(396.17,"_DA(2)_",14,"_DA(1)_",10,"
SET DIC(0)="L"
+10 DO ^DIC
+11 SET (DA,DVBNWIEN)=+Y
+12 SET DIE=DIC
+13 SET DR=".01////"_DVBNWIEN_";.02////"_DVBDT_";.03////"_DUZ_";.04////"_DVBRESP
+14 DO ^DIE
KILL DIE,DIC,DA,DR,DLAYGO,X,Y
+15 SET DVBINN=""_DVBCT_","_DVBIEN_","_""
+16 SET DVBTRANS=$$GET1^DIQ(396.1726,DVBINN,".07","I")
+17 IF DVBRESP'="Initial Save"
SET DVBTRANS=$GET(DVBTRANS)+1
+18 SET DA(1)=DVBIEN
SET DA=DVBCT
+19 SET (DLAYGO,DIC)="^DVB(396.17,"_DA(1)_",14,"
SET DIC(0)="L"
+20 DO ^DIC
+21 SET DIE=DIC
+22 SET DR=".01////"_DVBCT_";.07////"_DVBTRANS_";.02////"_DVBSTA
+23 DO ^DIE
+24 IF DVBSTA="C"
SET DR=".09////"_DVBDT
DO ^DIE
+25 IF $GET(DVBNAME)'=""
SET DR=".03////"_DVBNAME
DO ^DIE
+26 IF DVBRESP="Initial Save"
SET DR=".05////"_DVBDT
DO ^DIE
+27 SET DVBRTN=1
IF $DATA(DIERR)
SET DVBRTN=0
+28 DO UNLOCK(DVBIEN,DVBCT)
+29 KILL DIC,DIE,DIERR,DA,DR,DLAYGO,X
+30 QUIT
+31 ;
LOCK(DVBIEN,DVBCT) ;
+1 LOCK +^DVB(396.17,DVBIEN,14,DVBCT,3):30
+2 SET DVBRTN=$TEST
+3 QUIT DVBRTN
+4 ;
UNLOCK(DVBIEN,DVBCT) ;
+1 LOCK -^DVB(396.17,DVBIEN,14,DVBCT,3)
+2 QUIT
+3 ;
FAILCHK(DVBRTN) ;
+1 KILL DVBRTN
SET DVBRTN=0
SET DVBPATCH=3231025
+2 SET DVBDATE=DVBPATCH
FOR
SET DVBDATE=$ORDER(^DVB(396.17,"C",DVBDATE))
if (DVBDATE="")!(DVBRTN=1)
QUIT
Begin DoDot:1
+3 SET DVBIEN=""
FOR
SET DVBIEN=$ORDER(^DVB(396.17,"C",DVBDATE,DVBIEN))
if (DVBIEN="")!(DVBRTN=1)
QUIT
Begin DoDot:2
+4 IF $DATA(^DVB(396.17,DVBIEN,14,"B"))
Begin DoDot:3
+5 SET DVBCT=0
FOR
SET DVBCT=$ORDER(^DVB(396.17,DVBIEN,14,"B",DVBCT))
if (DVBCT="")!(DVBRTN=1)
QUIT
Begin DoDot:4
+6 SET DVBINN=""_DVBCT_","_DVBIEN_","_""
+7 SET DVBSTA=$$GET1^DIQ(396.1726,DVBINN,".02","I")
+8 IF DVBSTA'="C"
SET DVBRTN=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
