RCXVDC3 ;DAOU/ALA-AR Data Extraction Data Creation ; 23 Jul 2007 10:32 AM
;;4.5;Accounts Receivable;**201,227,228,232,248,251,270**;Mar 20, 1995;Build 25
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; CLAIMS (# 399)
Q
D399 ;
NEW RCXVD,RCXVBC,RCXVDT,RCXVD1,RCXVD2,RCXVD3
NEW RCXVD4,RCXVD5,RCXVD6,RCXVD7,RCXVDA,RCXVDB,RCXVDC,RCXVDD
NEW RCXVP1,RCXVP2,RCXVD0C,RCXVP3,RCXVP4,RCXVP5,RCXVCFL,RCXVPAY
NEW RCXVINS,RCXVVAN,RCXVDRG,RCXVCAN,RCXVSNR,IBD,X1,X2,RCXVNPI
;
;WCJ;PRCA*4.5*270;Start
;I $P(RCXVBLNA,"-",2)="" Q
;S RCXVD0=$O(^DGCR(399,"B",$P(RCXVBLNA,"-",2),""))
;I RCXVD0="" Q
Q:'+$G(RCXVBLN)
S RCXVD0=RCXVBLN
;WCJ;PRCA*4.5*270;End
;
S RCXVD1=$G(^DGCR(399,RCXVD0,0))
Q:RCXVD1="" ;WCJ;PRCA*4.5*270
I $G(DFN)="" S DFN=$P(RCXVD1,U,2)
Q:'DFN ;WCJ;PRCA*4.5*270
S RCXVD2=$G(^DGCR(399,RCXVD0,"S"))
S RCXVD3=$G(^DGCR(399,RCXVD0,"U"))
S RCXVD7=$G(^DGCR(399,RCXVD0,"TX"))
S RCXVDA=$P(RCXVD1,U,1) ; BILL #
S (RCXVEVDT,RCXVDT)=$P($P(RCXVD1,U,3),".",1)
;S RCXVDA=RCXVBLNB_RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; EVNT DT
S RCXVDA=RCXVBLNA_RCXVU_$P(^DPT(DFN,0),U,9) ; SSN
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; EVNT DT
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,5) ; BILL CLASS
S RCXVP1=$P(RCXVD1,U,7),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^DGCR(399.3,RCXVP1,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; RATE TYPE (P)
S RCXVP1=$P(RCXVD2,U,11),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^VA(200,RCXVP1,2,0)),U,1)_RCXVP1 ; SITE_IEN
S RCXVDA=RCXVDA_RCXVU_RCXVSITE_RCXVP2 ; Authorizer (P)
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,13) ; Stat
S RCXVDT=$P(RCXVD1,U,14)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Stat DT
S RCXVP1=$P(RCXVD1,U,22),RCXVP2="",RCXVNPI=""
I RCXVP1'="" S RCXVP2=$$GET1^DIQ(40.8,RCXVP1,1) ;$P($G(^DG(40.8,RCXVP1,0)),U,2)
S:$G(RCXVP1)'="" RCXVNPI=$P($$NPI^XUSNPI("Organization_ID",$$GET1^DIQ(40.8,RCXVP1,.07,"I")),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" ;Default Division NPI
S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI ; Default division^Default division NPI
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,24) ; UB92 Location
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,27) ; Bill Chrg type
S RCXVDT=$P(RCXVD2,U,10)
S RCXVDB=$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Auth. DT
S RCXVDT=$P(RCXVD2,U,12)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT 1st printed
S (RCXVP1,RCXVD0C)=$P($G(^DGCR(399,RCXVD0,"M")),U,1),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^DIC(36,RCXVP1,0)),U,1)
S RCXVDB=RCXVDB_RCXVU_RCXVP2 ; PRIM. INSR (P)
;
; Type of Plan
S RCXVP2="",RCXVI=0,RCXVP3="",RCXVP4="",RCXVP5=""
S IBD=$$IBAREXT^IBRFN4(RCXVD0,.IBD)
S RCXVP2=$P(IBD("IN"),U),RCXVP5=$P(IBD("IN"),U,2),RCXVP3=$P(IBD("IN"),U,3),RCXVP4=$P(IBD("IN"),U,4)
S RCXVDB=RCXVDB_RCXVU_RCXVP2_RCXVU_RCXVP5_RCXVU_RCXVP3_RCXVU_RCXVP4,RCXVD5="",RCXVD6=""
;
; 36, 36.3 ADDRESS/EDI
I RCXVD0C S RCXVD5=$G(^DIC(36,RCXVD0C,.11))
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,1) ; STRT ADD 1
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,2) ; STRT ADD 2
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,4) ; CITY
S RCXVP1=$P(RCXVD5,U,5),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^DIC(5,RCXVP1,0)),U,1)
S RCXVDB=RCXVDB_RCXVU_RCXVP2 ; STATE (P)
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,6) ; ZIP
I RCXVD0C'="" S RCXVD6=$G(^DIC(36,RCXVD0C,3))
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD6,U,2) ; EDI - PROF
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD6,U,4) ; EDI - INST
S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(36,RCXVD0C_",",1,"I") ; REIMBURSE?
;
S RCXVPFDT=$P(RCXVD3,U,1)
S RCXVDC=$$HLDATE^HLFNC(RCXVPFDT) ; STMT COVERS FROM
S RCXVPTDT=$P(RCXVD3,U,2)
S RCXVDC=RCXVDC_RCXVU_$$HLDATE^HLFNC(RCXVPTDT) ; STMT COVERS TO
S RCXVP1=$P(RCXVD3,U,11),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^DGCR(399.1,RCXVP1,0)),U,1)
S RCXVDC=RCXVDC_RCXVU_RCXVP2 ; DISCH. BED SEC.
S RCXVD4=$G(^DGCR(399,RCXVD0,"U1"))
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD4,U,1) ; TOT CHRG
;
S RCXVP1=$P($G(^DGCR(399,RCXVD0,"U2")),U,10),RCXVP2="",RCXVNPI=""
I RCXVP1'="" S RCXVP2=$P($G(^IBA(355.93,RCXVP1,0)),U,1)
S:$G(RCXVP2)'="" RCXVNPI=$P($$NPI^XUSNPI("Non_VA_Provider_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI=""
I RCXVNPI="",$G(RCXVP2)'="" S RCXVNPI=$$GET1^DIQ(355.93,RCXVP1,41.01,"I") ;This line is used if the XUSNPI API does not work
S RCXVDC=RCXVDC_RCXVU_RCXVP2_RCXVU_RCXVNPI ; NON VA FAC (P)^NON VA FAC NPI
;
; Get VACARE or NONVACARE flag
NEW RCXVIEN
D CARE^RCXVUTIL(RCXVD0)
S RCXVDC=RCXVDC_RCXVU_$S(RCXVCFL=1:"VACARE",1:"NONVACARE")
; MRA data
S RCXVDT=$P(IBD,U,2)
S RCXVDD=$E($$HLDATE^HLFNC(RCXVDT),1,8) ; MRA Requested DT
S RCXVDT=$P(IBD,U,3)
S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Last Electronic Extract Date
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,4) ;Printed VIA EDI
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,5) ;Force Claim To Print
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,6) ;Claim MRA Status
S RCXVDT=$P(IBD,U,7)
S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;MRA Recorded Date
S RCXVDT=$P(IBD,U,8)
S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Date Cancelled
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,9) ;Form Type
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,16)_RCXVU_$P(IBD,U,15) ;PAYER&VA NAT.ID #
S RCXVDRG=$P(IBD,U,11)
S RCXVDD=RCXVDD_RCXVU_RCXVDRG ;DRG
S RCXVSNR=$P(IBD,U,14) ;Days site not responsible for MRA request
S RCXVDD=RCXVDD_RCXVU_RCXVSNR
S RCXVDD=RCXVDD_RCXVU_$P($P(IBD,U,12),";") ;ECME #
S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,17) ;Offset Amount
S ^TMP($J,RCXVBLN,"3-399A")=RCXVDA
S ^TMP($J,RCXVBLN,"3-399B")=RCXVDB
S ^TMP($J,RCXVBLN,"3-399C")=RCXVDC
S ^TMP($J,RCXVBLN,"3-399D")=RCXVDD
Q
;
REJ() ;Checks for reject on a claim
S X="NO"
S X1=$P(RCXVD1,U,15) S D0=RCXVD0
F D G REJQ:'D0
. S I=0 F S I=$O(^IBM(361,"B",D0,I)) Q:'I D Q:'D0
..S X2=$P($G(^IBM(361,I,0)),U,3)
..I X2="R" S X="YES",D0=""
..Q
.I X="YES" Q
.I X1=D0 S D0="" Q
.S D0=X1 Q:'D0 S X1=$P($G(^DGCR(399,X1,0)),U,15)
.Q
K I
REJQ Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC3 5915 printed Nov 22, 2024@16:59:44 Page 2
RCXVDC3 ;DAOU/ALA-AR Data Extraction Data Creation ; 23 Jul 2007 10:32 AM
+1 ;;4.5;Accounts Receivable;**201,227,228,232,248,251,270**;Mar 20, 1995;Build 25
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; CLAIMS (# 399)
+5 QUIT
D399 ;
+1 NEW RCXVD,RCXVBC,RCXVDT,RCXVD1,RCXVD2,RCXVD3
+2 NEW RCXVD4,RCXVD5,RCXVD6,RCXVD7,RCXVDA,RCXVDB,RCXVDC,RCXVDD
+3 NEW RCXVP1,RCXVP2,RCXVD0C,RCXVP3,RCXVP4,RCXVP5,RCXVCFL,RCXVPAY
+4 NEW RCXVINS,RCXVVAN,RCXVDRG,RCXVCAN,RCXVSNR,IBD,X1,X2,RCXVNPI
+5 ;
+6 ;WCJ;PRCA*4.5*270;Start
+7 ;I $P(RCXVBLNA,"-",2)="" Q
+8 ;S RCXVD0=$O(^DGCR(399,"B",$P(RCXVBLNA,"-",2),""))
+9 ;I RCXVD0="" Q
+10 if '+$GET(RCXVBLN)
QUIT
+11 SET RCXVD0=RCXVBLN
+12 ;WCJ;PRCA*4.5*270;End
+13 ;
+14 SET RCXVD1=$GET(^DGCR(399,RCXVD0,0))
+15 ;WCJ;PRCA*4.5*270
if RCXVD1=""
QUIT
+16 IF $GET(DFN)=""
SET DFN=$PIECE(RCXVD1,U,2)
+17 ;WCJ;PRCA*4.5*270
if 'DFN
QUIT
+18 SET RCXVD2=$GET(^DGCR(399,RCXVD0,"S"))
+19 SET RCXVD3=$GET(^DGCR(399,RCXVD0,"U"))
+20 SET RCXVD7=$GET(^DGCR(399,RCXVD0,"TX"))
+21 ; BILL #
SET RCXVDA=$PIECE(RCXVD1,U,1)
+22 SET (RCXVEVDT,RCXVDT)=$PIECE($PIECE(RCXVD1,U,3),".",1)
+23 ;S RCXVDA=RCXVBLNB_RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; EVNT DT
+24 ; SSN
SET RCXVDA=RCXVBLNA_RCXVU_$PIECE(^DPT(DFN,0),U,9)
+25 ; EVNT DT
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+26 ; BILL CLASS
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,5)
+27 SET RCXVP1=$PIECE(RCXVD1,U,7)
SET RCXVP2=""
+28 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^DGCR(399.3,RCXVP1,0)),U,1)
+29 ; RATE TYPE (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+30 SET RCXVP1=$PIECE(RCXVD2,U,11)
SET RCXVP2=""
+31 ; SITE_IEN
IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^VA(200,RCXVP1,2,0)),U,1)_RCXVP1
+32 ; Authorizer (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVSITE_RCXVP2
+33 ; Stat
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,13)
+34 SET RCXVDT=$PIECE(RCXVD1,U,14)
+35 ; Stat DT
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+36 SET RCXVP1=$PIECE(RCXVD1,U,22)
SET RCXVP2=""
SET RCXVNPI=""
+37 ;$P($G(^DG(40.8,RCXVP1,0)),U,2)
IF RCXVP1'=""
SET RCXVP2=$$GET1^DIQ(40.8,RCXVP1,1)
+38 ;Default Division NPI
if $GET(RCXVP1)'=""
SET RCXVNPI=$PIECE($$NPI^XUSNPI("Organization_ID",$$GET1^DIQ(40.8,RCXVP1,.07,"I")),RCXVU,1)
if +RCXVNPI<1
SET RCXVNPI=""
+39 ; Default division^Default division NPI
SET RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI
+40 ; UB92 Location
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,24)
+41 ; Bill Chrg type
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,27)
+42 SET RCXVDT=$PIECE(RCXVD2,U,10)
+43 ; Auth. DT
SET RCXVDB=$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+44 SET RCXVDT=$PIECE(RCXVD2,U,12)
+45 ; DT 1st printed
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+46 SET (RCXVP1,RCXVD0C)=$PIECE($GET(^DGCR(399,RCXVD0,"M")),U,1)
SET RCXVP2=""
+47 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^DIC(36,RCXVP1,0)),U,1)
+48 ; PRIM. INSR (P)
SET RCXVDB=RCXVDB_RCXVU_RCXVP2
+49 ;
+50 ; Type of Plan
+51 SET RCXVP2=""
SET RCXVI=0
SET RCXVP3=""
SET RCXVP4=""
SET RCXVP5=""
+52 SET IBD=$$IBAREXT^IBRFN4(RCXVD0,.IBD)
+53 SET RCXVP2=$PIECE(IBD("IN"),U)
SET RCXVP5=$PIECE(IBD("IN"),U,2)
SET RCXVP3=$PIECE(IBD("IN"),U,3)
SET RCXVP4=$PIECE(IBD("IN"),U,4)
+54 SET RCXVDB=RCXVDB_RCXVU_RCXVP2_RCXVU_RCXVP5_RCXVU_RCXVP3_RCXVU_RCXVP4
SET RCXVD5=""
SET RCXVD6=""
+55 ;
+56 ; 36, 36.3 ADDRESS/EDI
+57 IF RCXVD0C
SET RCXVD5=$GET(^DIC(36,RCXVD0C,.11))
+58 ; STRT ADD 1
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD5,U,1)
+59 ; STRT ADD 2
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD5,U,2)
+60 ; CITY
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD5,U,4)
+61 SET RCXVP1=$PIECE(RCXVD5,U,5)
SET RCXVP2=""
+62 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^DIC(5,RCXVP1,0)),U,1)
+63 ; STATE (P)
SET RCXVDB=RCXVDB_RCXVU_RCXVP2
+64 ; ZIP
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD5,U,6)
+65 IF RCXVD0C'=""
SET RCXVD6=$GET(^DIC(36,RCXVD0C,3))
+66 ; EDI - PROF
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD6,U,2)
+67 ; EDI - INST
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD6,U,4)
+68 ; REIMBURSE?
SET RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(36,RCXVD0C_",",1,"I")
+69 ;
+70 SET RCXVPFDT=$PIECE(RCXVD3,U,1)
+71 ; STMT COVERS FROM
SET RCXVDC=$$HLDATE^HLFNC(RCXVPFDT)
+72 SET RCXVPTDT=$PIECE(RCXVD3,U,2)
+73 ; STMT COVERS TO
SET RCXVDC=RCXVDC_RCXVU_$$HLDATE^HLFNC(RCXVPTDT)
+74 SET RCXVP1=$PIECE(RCXVD3,U,11)
SET RCXVP2=""
+75 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^DGCR(399.1,RCXVP1,0)),U,1)
+76 ; DISCH. BED SEC.
SET RCXVDC=RCXVDC_RCXVU_RCXVP2
+77 SET RCXVD4=$GET(^DGCR(399,RCXVD0,"U1"))
+78 ; TOT CHRG
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD4,U,1)
+79 ;
+80 SET RCXVP1=$PIECE($GET(^DGCR(399,RCXVD0,"U2")),U,10)
SET RCXVP2=""
SET RCXVNPI=""
+81 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^IBA(355.93,RCXVP1,0)),U,1)
+82 if $GET(RCXVP2)'=""
SET RCXVNPI=$PIECE($$NPI^XUSNPI("Non_VA_Provider_ID",RCXVP1),RCXVU,1)
if +RCXVNPI<1
SET RCXVNPI=""
+83 ;This line is used if the XUSNPI API does not work
IF RCXVNPI=""
IF $GET(RCXVP2)'=""
SET RCXVNPI=$$GET1^DIQ(355.93,RCXVP1,41.01,"I")
+84 ; NON VA FAC (P)^NON VA FAC NPI
SET RCXVDC=RCXVDC_RCXVU_RCXVP2_RCXVU_RCXVNPI
+85 ;
+86 ; Get VACARE or NONVACARE flag
+87 NEW RCXVIEN
+88 DO CARE^RCXVUTIL(RCXVD0)
+89 SET RCXVDC=RCXVDC_RCXVU_$SELECT(RCXVCFL=1:"VACARE",1:"NONVACARE")
+90 ; MRA data
+91 SET RCXVDT=$PIECE(IBD,U,2)
+92 ; MRA Requested DT
SET RCXVDD=$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+93 SET RCXVDT=$PIECE(IBD,U,3)
+94 ;Last Electronic Extract Date
SET RCXVDD=RCXVDD_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+95 ;Printed VIA EDI
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,4)
+96 ;Force Claim To Print
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,5)
+97 ;Claim MRA Status
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,6)
+98 SET RCXVDT=$PIECE(IBD,U,7)
+99 ;MRA Recorded Date
SET RCXVDD=RCXVDD_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+100 SET RCXVDT=$PIECE(IBD,U,8)
+101 ;Date Cancelled
SET RCXVDD=RCXVDD_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+102 ;Form Type
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,9)
+103 ;PAYER&VA NAT.ID #
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,16)_RCXVU_$PIECE(IBD,U,15)
+104 SET RCXVDRG=$PIECE(IBD,U,11)
+105 ;DRG
SET RCXVDD=RCXVDD_RCXVU_RCXVDRG
+106 ;Days site not responsible for MRA request
SET RCXVSNR=$PIECE(IBD,U,14)
+107 SET RCXVDD=RCXVDD_RCXVU_RCXVSNR
+108 ;ECME #
SET RCXVDD=RCXVDD_RCXVU_$PIECE($PIECE(IBD,U,12),";")
+109 ;Offset Amount
SET RCXVDD=RCXVDD_RCXVU_$PIECE(IBD,U,17)
+110 SET ^TMP($JOB,RCXVBLN,"3-399A")=RCXVDA
+111 SET ^TMP($JOB,RCXVBLN,"3-399B")=RCXVDB
+112 SET ^TMP($JOB,RCXVBLN,"3-399C")=RCXVDC
+113 SET ^TMP($JOB,RCXVBLN,"3-399D")=RCXVDD
+114 QUIT
+115 ;
REJ() ;Checks for reject on a claim
+1 SET X="NO"
+2 SET X1=$PIECE(RCXVD1,U,15)
SET D0=RCXVD0
+3 FOR
Begin DoDot:1
+4 SET I=0
FOR
SET I=$ORDER(^IBM(361,"B",D0,I))
if 'I
QUIT
Begin DoDot:2
+5 SET X2=$PIECE($GET(^IBM(361,I,0)),U,3)
+6 IF X2="R"
SET X="YES"
SET D0=""
+7 QUIT
End DoDot:2
if 'D0
QUIT
+8 IF X="YES"
QUIT
+9 IF X1=D0
SET D0=""
QUIT
+10 SET D0=X1
if 'D0
QUIT
SET X1=$PIECE($GET(^DGCR(399,X1,0)),U,15)
+11 QUIT
End DoDot:1
if 'D0
GOTO REJQ
+12 KILL I
REJQ QUIT X
+1 ;
