BPSUSCR2 ;ALB ISC/SS - STRANDED SUBMISSIONS SCREEN (cont) ;02-MAY-2008
;;1.0;E CLAIMS MGMT ENGINE;**7,10,11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
;Stranded requests with BPS TRANSACTION record
; Input:
; BPARR - Date Range
; Output:
; ^TMP("BPSUSCR",$J)
; ^TMP($J,2)
COLACTRQ(BPARR) ;
N KEY1,KEY2,BPIEN77,BPRX,FILL,COB
N TFILE,CFILE,STATUS,IEN59,VART,LSTUDT,CD0
N NAME,SSN,INSCO,DOS,BPTYPE
N BPBDT,BPEDT
S TFILE=9002313.59,CFILE=9002313.02
S BPBDT=BPARR("BDT") ;start date and time
S BPEDT=BPARR("EDT") ;end date and time
S KEY1=0
F S KEY1=$O(^BPS(9002313.77,"AC",2,KEY1)) Q:+KEY1=0 D
.S KEY2=""
.F S KEY2=$O(^BPS(9002313.77,"AC",2,KEY1,KEY2)) Q:KEY2="" D
.. S BPIEN77=+$O(^BPS(9002313.77,"AC",2,KEY1,KEY2,0))
.. S COB=$$GET1^DIQ(9002313.77,BPIEN77,.03,"I")
.. S IEN59=$$IEN59^BPSOSRX(KEY1,KEY2,COB)
.. S VART=$G(^BPST(IEN59,0))
.. ; If the transaction is missing, get the data from the request
.. I VART="" D REQSTTMP Q
.. ; If the Request pointer in the transaction is not the same as the
.. ; original request from the request file, get the data from the request
.. S BPTYPE=$P(VART,"^",15)
.. I BPIEN77'=0,BPIEN77'=+$$GETRQST^BPSUTIL2(IEN59) D REQSTTMP Q
.. S LSTUDT=$$GET1^DIQ(TFILE,IEN59,7,"I")
.. I LSTUDT<BPBDT!(LSTUDT>BPEDT) Q
.. S LSTUDT=$P(LSTUDT,".",1)
.. I LSTUDT="" Q
.. S BPTYPE=$P(VART,"^",15)
.. S BPTYPE=$S(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4)
.. I $D(^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,+IEN59)) Q ;already has it
.. S BPRX=$$GET1^DIQ(TFILE,IEN59,1.11,"E")
.. S FILL=$$GET1^DIQ(TFILE,IEN59,9)
.. S STATUS=$P(VART,"^",2)
.. S CD0=$$GET1^DIQ(TFILE,IEN59,3,"I")
.. I CD0'="" D
... S DOS=$$HL7TFM^XLFDT($$GET1^DIQ(CFILE,CD0,401))
.. I CD0="" D
... S DOS=$P($G(^BPST(IEN59,12)),"^",2)
.. S NAME=$$GET1^DIQ(TFILE,IEN59,5,"E")
.. S SSN=""
.. I $P(VART,"^",6)]"" S SSN=$P($G(^DPT($P(VART,"^",6),0)),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
.. S INSCO=$P($G(^BPST(IEN59,10,1,0)),"^",7)
.. S ^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS
Q
;
;Stranded requests without BPS TRANSACTION record
;Note the IEN59 here is a calculated ien only - the record doesn't exist
REQSTTMP ;
N BPDFN,BPIEN78,BPX
I BPIEN77=0 Q
S STATUS=-96
S LSTUDT=$$GET1^DIQ(9002313.77,BPIEN77,6.05,"I")
I LSTUDT<BPBDT!(LSTUDT>BPEDT) Q
S LSTUDT=$P(LSTUDT,".",1)
I LSTUDT="" Q
S BPTYPE=$$GET1^DIQ(9002313.77,BPIEN77,1.04,"I")
S BPTYPE=$S(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4)
I $D(^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,+IEN59)) Q ;already has it
S BPRX=$$GET1^DIQ(9002313.77,BPIEN77,1.13,"E")
S FILL=$$GET1^DIQ(9002313.77,BPIEN77,1.14)
S DOS=$$GET1^DIQ(9002313.77,BPIEN77,2.01,"I")
S NAME=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"E")
S BPDFN=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"I")
; Older request might not have the Patient Name so get it from
; the RX
I BPDFN="",BPRX D
. S NAME=$$RXAPI1^BPSUTIL1(BPRX,2,"E")
. S BPDFN=$$RXAPI1^BPSUTIL1(BPRX,2,"I")
S SSN=""
I BPDFN>0 S SSN=$P($G(^DPT(BPDFN,0)),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))
S BPX=$O(^BPS(9002313.77,BPIEN77,5,0))
I BPX>0 S BPIEN78=+$P($G(^BPS(9002313.77,BPIEN77,5,BPX,0)),U,3),INSCO=$$GET1^DIQ(9002313.78,BPIEN78,.07,"E")
E S INSCO="UNKNOWN"
S ^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS_U_BPIEN77
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSUSCR2 3473 printed Apr 09, 2024@20:57:01 Page 2
BPSUSCR2 ;ALB ISC/SS - STRANDED SUBMISSIONS SCREEN (cont) ;02-MAY-2008
+1 ;;1.0;E CLAIMS MGMT ENGINE;**7,10,11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;Stranded requests with BPS TRANSACTION record
+7 ; Input:
+8 ; BPARR - Date Range
+9 ; Output:
+10 ; ^TMP("BPSUSCR",$J)
+11 ; ^TMP($J,2)
COLACTRQ(BPARR) ;
+1 NEW KEY1,KEY2,BPIEN77,BPRX,FILL,COB
+2 NEW TFILE,CFILE,STATUS,IEN59,VART,LSTUDT,CD0
+3 NEW NAME,SSN,INSCO,DOS,BPTYPE
+4 NEW BPBDT,BPEDT
+5 SET TFILE=9002313.59
SET CFILE=9002313.02
+6 ;start date and time
SET BPBDT=BPARR("BDT")
+7 ;end date and time
SET BPEDT=BPARR("EDT")
+8 SET KEY1=0
+9 FOR
SET KEY1=$ORDER(^BPS(9002313.77,"AC",2,KEY1))
if +KEY1=0
QUIT
Begin DoDot:1
+10 SET KEY2=""
+11 FOR
SET KEY2=$ORDER(^BPS(9002313.77,"AC",2,KEY1,KEY2))
if KEY2=""
QUIT
Begin DoDot:2
+12 SET BPIEN77=+$ORDER(^BPS(9002313.77,"AC",2,KEY1,KEY2,0))
+13 SET COB=$$GET1^DIQ(9002313.77,BPIEN77,.03,"I")
+14 SET IEN59=$$IEN59^BPSOSRX(KEY1,KEY2,COB)
+15 SET VART=$GET(^BPST(IEN59,0))
+16 ; If the transaction is missing, get the data from the request
+17 IF VART=""
DO REQSTTMP
QUIT
+18 ; If the Request pointer in the transaction is not the same as the
+19 ; original request from the request file, get the data from the request
+20 SET BPTYPE=$PIECE(VART,"^",15)
+21 IF BPIEN77'=0
IF BPIEN77'=+$$GETRQST^BPSUTIL2(IEN59)
DO REQSTTMP
QUIT
+22 SET LSTUDT=$$GET1^DIQ(TFILE,IEN59,7,"I")
+23 IF LSTUDT<BPBDT!(LSTUDT>BPEDT)
QUIT
+24 SET LSTUDT=$PIECE(LSTUDT,".",1)
+25 IF LSTUDT=""
QUIT
+26 SET BPTYPE=$PIECE(VART,"^",15)
+27 SET BPTYPE=$SELECT(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4)
+28 ;already has it
IF $DATA(^TMP("BPSUSCR-1",$JOB,BPTYPE,LSTUDT,+IEN59))
QUIT
+29 SET BPRX=$$GET1^DIQ(TFILE,IEN59,1.11,"E")
+30 SET FILL=$$GET1^DIQ(TFILE,IEN59,9)
+31 SET STATUS=$PIECE(VART,"^",2)
+32 SET CD0=$$GET1^DIQ(TFILE,IEN59,3,"I")
+33 IF CD0'=""
Begin DoDot:3
+34 SET DOS=$$HL7TFM^XLFDT($$GET1^DIQ(CFILE,CD0,401))
End DoDot:3
+35 IF CD0=""
Begin DoDot:3
+36 SET DOS=$PIECE($GET(^BPST(IEN59,12)),"^",2)
End DoDot:3
+37 SET NAME=$$GET1^DIQ(TFILE,IEN59,5,"E")
+38 SET SSN=""
+39 IF $PIECE(VART,"^",6)]""
SET SSN=$PIECE($GET(^DPT($PIECE(VART,"^",6),0)),"^",9)
SET SSN=$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
+40 SET INSCO=$PIECE($GET(^BPST(IEN59,10,1,0)),"^",7)
+41 SET ^TMP("BPSUSCR-1",$JOB,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
+44 ;Stranded requests without BPS TRANSACTION record
+45 ;Note the IEN59 here is a calculated ien only - the record doesn't exist
REQSTTMP ;
+1 NEW BPDFN,BPIEN78,BPX
+2 IF BPIEN77=0
QUIT
+3 SET STATUS=-96
+4 SET LSTUDT=$$GET1^DIQ(9002313.77,BPIEN77,6.05,"I")
+5 IF LSTUDT<BPBDT!(LSTUDT>BPEDT)
QUIT
+6 SET LSTUDT=$PIECE(LSTUDT,".",1)
+7 IF LSTUDT=""
QUIT
+8 SET BPTYPE=$$GET1^DIQ(9002313.77,BPIEN77,1.04,"I")
+9 SET BPTYPE=$SELECT(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4)
+10 ;already has it
IF $DATA(^TMP("BPSUSCR-1",$JOB,BPTYPE,LSTUDT,+IEN59))
QUIT
+11 SET BPRX=$$GET1^DIQ(9002313.77,BPIEN77,1.13,"E")
+12 SET FILL=$$GET1^DIQ(9002313.77,BPIEN77,1.14)
+13 SET DOS=$$GET1^DIQ(9002313.77,BPIEN77,2.01,"I")
+14 SET NAME=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"E")
+15 SET BPDFN=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"I")
+16 ; Older request might not have the Patient Name so get it from
+17 ; the RX
+18 IF BPDFN=""
IF BPRX
Begin DoDot:1
+19 SET NAME=$$RXAPI1^BPSUTIL1(BPRX,2,"E")
+20 SET BPDFN=$$RXAPI1^BPSUTIL1(BPRX,2,"I")
End DoDot:1
+21 SET SSN=""
+22 IF BPDFN>0
SET SSN=$PIECE($GET(^DPT(BPDFN,0)),"^",9)
SET SSN=$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
+23 SET BPX=$ORDER(^BPS(9002313.77,BPIEN77,5,0))
+24 IF BPX>0
SET BPIEN78=+$PIECE($GET(^BPS(9002313.77,BPIEN77,5,BPX,0)),U,3)
SET INSCO=$$GET1^DIQ(9002313.78,BPIEN78,.07,"E")
+25 IF '$TEST
SET INSCO="UNKNOWN"
+26 SET ^TMP("BPSUSCR-1",$JOB,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS_U_BPIEN77
+27 QUIT
