- 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 Jan 18, 2025@02:50:18 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