DVBCTPD2 ;ALB/BG - CAPRI XML RPCS; FEB 6, 2023@16:20 ; 10/4/23 10:07am
;;2.7;AMIE;**250**;Apr 10, 1995;Build 19
; Per VHA Directive 6402 this routine should not be modified
; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
Q
;
TRANSRPT(DVBRTN,DVBIEN,DVBSDT,DVBEDT) ;
K ^TMP("CAPRI TRANSRPT",$J) S DVBCNNT=""
I DVBIEN'="" D
.S DVBCT=0 F S DVBCT=$O(^DVB(396.17,DVBIEN,14,"B",DVBCT)) Q:DVBCT="" D
..S DVBINN1=""_DVBCT_","_DVBIEN_","_""
..S DVBSTA=$$GET1^DIQ(396.1726,DVBINN1,".02","E")
..S DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","I")
..I DVBNAME?.N S DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","E")
..S DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
..S DVBCNT=0 F S DVBCNT=$O(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT)) Q:DVBCNT="" D
...S DVBINN2=""_DVBCNT_","_DVBCT_","_DVBIEN_","_""
...S DVBAUTH=$$GET1^DIQ(396.2026,DVBINN2,".03","E")
...S DVBTRDT=$$GET1^DIQ(396.2026,DVBINN2,".02","E")
...S DVBRESP=$$GET1^DIQ(396.2026,DVBINN2,".04","E")
...S DVBCNNT=DVBCNNT+1 S ^TMP("CAPRI TRANSRPT",$J,DVBNAME,DVBTRDT,DVBCNNT)=DVBNAME_U_DVBPT_U_DVBAUTH_U_DVBTRDT_U_DVBSTA_U_DVBRESP
...Q
.S DVBRTN=$NA(^TMP("CAPRI TRANSRPT",$J))
.Q
;;
I DVBIEN="" D
.S DVBDT=$$NOW^XLFDT
.I DVBSDT="",DVBEDT="" S DVBRTN="-1^MISSING DATE RANGE" Q
.S X=$G(DVBSDT) D ^%DT S DVBSDT=Y
.I DVBEDT'="" S X=DVBEDT D ^%DT S DVBEDT=Y
.I DVBEDT="" S DVBEDT=$P(DVBDT,".",1)
.S DVBIEN=0 F S DVBIEN=$O(^DVB(396.17,DVBIEN)) Q:DVBIEN="" D
..S DVBCT=0 F S DVBCT=$O(^DVB(396.17,DVBIEN,14,"B",DVBCT)) Q:DVBCT="" D
...S DVBINN1=""_DVBCT_","_DVBIEN_","_""
...S DVBCNT=0 F S DVBCNT=$O(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT)) Q:DVBCNT="" D
....S DVBINN2=""_DVBCNT_","_DVBCT_","_DVBIEN_","_""
....S DVBCHKDT=$$GET1^DIQ(396.2026,DVBINN2,".02","I")
....S DVBCHKDT=$P(DVBCHKDT,".",1)
....I DVBCHKDT<DVBSDT Q
....I DVBCHKDT>DVBEDT Q
....S DVBTRDT=$$GET1^DIQ(396.2026,DVBINN2,".02","E")
....S DVBSTA=$$GET1^DIQ(396.1726,DVBINN1,".02","E")
....S DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","I")
....I DVBNAME?.N S DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","E")
....S DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
....S DVBAUTH=$$GET1^DIQ(396.2026,DVBINN2,".03","E")
....S DVBRESP=$$GET1^DIQ(396.2026,DVBINN2,".04","E")
....S DVBCNNT=DVBCNNT+1 S ^TMP("CAPRI TRANSRPT",$J,DVBNAME,DVBTRDT,DVBCNNT)=DVBNAME_U_DVBPT_U_DVBAUTH_U_DVBTRDT_U_DVBSTA_U_DVBRESP
....Q
.S DVBRTN=$NA(^TMP("CAPRI TRANSRPT",$J))
.Q
K DVBCNNT,X,Y,DVBCT,DVBINN1,DVBSTA,DVBNAME,DVBPT,DVBCNT,DVBINN2,DVBAUTH,DVBTRDT,DVBRESP,DVBCHKDT,DVBDT
Q
ZIP(DVBRTN,DVBZIP,DVBUUID) ;
N DVBINS,DVBDATA,DVBNAME,DVBDNS,DVBPORT,DVBTELE K DVBRTN
S DVBINS="" S DVBINS=$O(^DIZ(396.98,"D",DVBZIP,DVBINS))
I '$D(DVBINS) S DVBRTN="0^NO INSTITUTION SERVICES THAT ZIPCODE" Q
S DVBNAME=$$GET1^DIQ(396.98,DVBINS,".01","E")
S DVBSTAT=$$GET1^DIQ(396.98,DVBINS,".01","I")
S DVBDNS=$$GET1^DIQ(396.98,DVBINS,"1","I")
S DVBPORT=$$GET1^DIQ(396.98,DVBINS,"2","I")
S DVBTELE=$$GET1^DIQ(396.98,DVBINS,"4","I")
S DVBRTN=DVBNAME_U_DVBSTAT_U_DVBDNS_U_DVBPORT_U_DVBTELE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCTPD2 3076 printed Apr 09, 2024@20:45:24 Page 2
DVBCTPD2 ;ALB/BG - CAPRI XML RPCS; FEB 6, 2023@16:20 ; 10/4/23 10:07am
+1 ;;2.7;AMIE;**250**;Apr 10, 1995;Build 19
+2 ; Per VHA Directive 6402 this routine should not be modified
+3 ; Reference to $$NOW^XLFDT and $$FMTE^XLFDT in ICR #10103
+4 QUIT
+5 ;
TRANSRPT(DVBRTN,DVBIEN,DVBSDT,DVBEDT) ;
+1 KILL ^TMP("CAPRI TRANSRPT",$JOB)
SET DVBCNNT=""
+2 IF DVBIEN'=""
Begin DoDot:1
+3 SET DVBCT=0
FOR
SET DVBCT=$ORDER(^DVB(396.17,DVBIEN,14,"B",DVBCT))
if DVBCT=""
QUIT
Begin DoDot:2
+4 SET DVBINN1=""_DVBCT_","_DVBIEN_","_""
+5 SET DVBSTA=$$GET1^DIQ(396.1726,DVBINN1,".02","E")
+6 SET DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","I")
+7 IF DVBNAME?.N
SET DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","E")
+8 SET DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
+9 SET DVBCNT=0
FOR
SET DVBCNT=$ORDER(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT))
if DVBCNT=""
QUIT
Begin DoDot:3
+10 SET DVBINN2=""_DVBCNT_","_DVBCT_","_DVBIEN_","_""
+11 SET DVBAUTH=$$GET1^DIQ(396.2026,DVBINN2,".03","E")
+12 SET DVBTRDT=$$GET1^DIQ(396.2026,DVBINN2,".02","E")
+13 SET DVBRESP=$$GET1^DIQ(396.2026,DVBINN2,".04","E")
+14 SET DVBCNNT=DVBCNNT+1
SET ^TMP("CAPRI TRANSRPT",$JOB,DVBNAME,DVBTRDT,DVBCNNT)=DVBNAME_U_DVBPT_U_DVBAUTH_U_DVBTRDT_U_DVBSTA_U_DVBRESP
+15 QUIT
End DoDot:3
End DoDot:2
+16 SET DVBRTN=$NAME(^TMP("CAPRI TRANSRPT",$JOB))
+17 QUIT
End DoDot:1
+18 ;;
+19 IF DVBIEN=""
Begin DoDot:1
+20 SET DVBDT=$$NOW^XLFDT
+21 IF DVBSDT=""
IF DVBEDT=""
SET DVBRTN="-1^MISSING DATE RANGE"
QUIT
+22 SET X=$GET(DVBSDT)
DO ^%DT
SET DVBSDT=Y
+23 IF DVBEDT'=""
SET X=DVBEDT
DO ^%DT
SET DVBEDT=Y
+24 IF DVBEDT=""
SET DVBEDT=$PIECE(DVBDT,".",1)
+25 SET DVBIEN=0
FOR
SET DVBIEN=$ORDER(^DVB(396.17,DVBIEN))
if DVBIEN=""
QUIT
Begin DoDot:2
+26 SET DVBCT=0
FOR
SET DVBCT=$ORDER(^DVB(396.17,DVBIEN,14,"B",DVBCT))
if DVBCT=""
QUIT
Begin DoDot:3
+27 SET DVBINN1=""_DVBCT_","_DVBIEN_","_""
+28 SET DVBCNT=0
FOR
SET DVBCNT=$ORDER(^DVB(396.17,DVBIEN,14,DVBCT,10,"B",DVBCNT))
if DVBCNT=""
QUIT
Begin DoDot:4
+29 SET DVBINN2=""_DVBCNT_","_DVBCT_","_DVBIEN_","_""
+30 SET DVBCHKDT=$$GET1^DIQ(396.2026,DVBINN2,".02","I")
+31 SET DVBCHKDT=$PIECE(DVBCHKDT,".",1)
+32 IF DVBCHKDT<DVBSDT
QUIT
+33 IF DVBCHKDT>DVBEDT
QUIT
+34 SET DVBTRDT=$$GET1^DIQ(396.2026,DVBINN2,".02","E")
+35 SET DVBSTA=$$GET1^DIQ(396.1726,DVBINN1,".02","E")
+36 SET DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","I")
+37 IF DVBNAME?.N
SET DVBNAME=$$GET1^DIQ(396.1726,DVBINN1,".03","E")
+38 SET DVBPT=$$GET1^DIQ(396.17,DVBIEN,".01","E")
+39 SET DVBAUTH=$$GET1^DIQ(396.2026,DVBINN2,".03","E")
+40 SET DVBRESP=$$GET1^DIQ(396.2026,DVBINN2,".04","E")
+41 SET DVBCNNT=DVBCNNT+1
SET ^TMP("CAPRI TRANSRPT",$JOB,DVBNAME,DVBTRDT,DVBCNNT)=DVBNAME_U_DVBPT_U_DVBAUTH_U_DVBTRDT_U_DVBSTA_U_DVBRESP
+42 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+43 SET DVBRTN=$NAME(^TMP("CAPRI TRANSRPT",$JOB))
+44 QUIT
End DoDot:1
+45 KILL DVBCNNT,X,Y,DVBCT,DVBINN1,DVBSTA,DVBNAME,DVBPT,DVBCNT,DVBINN2,DVBAUTH,DVBTRDT,DVBRESP,DVBCHKDT,DVBDT
+46 QUIT
ZIP(DVBRTN,DVBZIP,DVBUUID) ;
+1 NEW DVBINS,DVBDATA,DVBNAME,DVBDNS,DVBPORT,DVBTELE
KILL DVBRTN
+2 SET DVBINS=""
SET DVBINS=$ORDER(^DIZ(396.98,"D",DVBZIP,DVBINS))
+3 IF '$DATA(DVBINS)
SET DVBRTN="0^NO INSTITUTION SERVICES THAT ZIPCODE"
QUIT
+4 SET DVBNAME=$$GET1^DIQ(396.98,DVBINS,".01","E")
+5 SET DVBSTAT=$$GET1^DIQ(396.98,DVBINS,".01","I")
+6 SET DVBDNS=$$GET1^DIQ(396.98,DVBINS,"1","I")
+7 SET DVBPORT=$$GET1^DIQ(396.98,DVBINS,"2","I")
+8 SET DVBTELE=$$GET1^DIQ(396.98,DVBINS,"4","I")
+9 SET DVBRTN=DVBNAME_U_DVBSTAT_U_DVBDNS_U_DVBPORT_U_DVBTELE
+10 QUIT
+11 ;
