BPSOS57 ;BHAM ISC/FCS/DRS/FLS - BPS Log of Transactions Utils ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
; Numerous BPS Log of Transaction functions are here
; Each assumes that IEN57 is defined
; Originally copied from BPSOSQ
;
DRGDFN() ; EP - BPS Log of Transaction field
N RXI
S RXI=$$RXI
I 'RXI Q ""
Q $$RXAPI1^BPSUTIL1(RXI,6,"I") ; Given IEN57, return DRGDFN
DRGNAME() ; EP - BPS Log of Transaction field
N RXI
S RXI=$$RXI
I 'RXI Q ""
Q $$RXAPI1^BPSUTIL1(RXI,6,"E") ; Given IEN57, return DRGNAME
RELDATE() ;EP - BPS Log of Transaction field
N RXI,RXR
S RXI=$$RXI,RXR=$$RXR
I 'RXI Q ""
I RXR Q $$REFAPI1^BPSUTIL1(RXI,RXR,17,"I")
Q $$RXAPI1^BPSUTIL1(RXI,31,"I")
RXI() Q $P(^BPSTL(IEN57,1),U,11) ; Given IEN57, return RXI
RXR() Q $P(^BPSTL(IEN57,1),U,1) ; Given IEN57, return RXR
NDC() Q $P(^BPSTL(IEN57,1),U,2)
QTY() Q $P(^BPSTL(IEN57,5),U) ; Given IEN57, return quantity
AMT() Q $P(^BPSTL(IEN57,5),U,5) ; return total $amount
CHG() Q $P(^BPSTL(IEN57,5),U,5) ; Given IEN57, ret total charge
INSIEN() Q $P(^BPSTL(IEN57,1),U,6)
PATIENT() Q $P(^BPSTL(IEN57,0),U,6)
HRN() ; Health record number and facility abbreviation
; Called by BPS Log of Transaction field
Q 0
USER() N X S X=$P(^BPSTL(IEN57,0),U,10) S:'X X=$G(DUZ) Q X
NOW() N %,%H,%I,X D NOW^%DTC Q %
ISREVERS(N) ;EP - BPSOSIY
; Returns reversal claim #, else false
N X S X=$G(^BPSTL(N,4)) Q:X="" 0
I X Q $P(X,U) ; reversal of electronic claim
Q 0
REVACC(N) ;EP - BPSOSIY
; was this an accepted reversal? return true or false
; Treat Duplicate of Accepted Reversal ("S") as accepted
N X
S X=$$REVRESP(N)
Q X="A"!(X="S")
REVRESP(N) ;
N RESP S RESP=$P(^BPSTL(N,4),U,2)
I 'RESP Q "?"
N X S X=$$RESP500^BPSOSQ4(RESP,"I")
Q X ; Should be "A" or "R" - can be "S" (Duplicate of Accepted Reversal)
;
POSITION() ; return pointer to position within claim (D1)
Q $P($G(^BPSTL(IEN57,0)),U,9)
IEN02() ; return pointer to claim
Q $P($G(^BPSTL(IEN57,0)),U,4)
IEN03() ; return pointer to response
Q $P($G(^BPSTL(IEN57,0)),U,5)
REVIEN02() ; return pointer to reversal claim
Q $P($G(^BPSTL(IEN57,4)),U)
REVIEN03() ; return pointer to reversal response
Q $P($G(^BPSTL(IEN57,4)),U,2)
FIELD(F,REV) ; EP - BPS Log of Transaction fields
; Retrieve field F from claim or response - Given IEN57
; Returns value
; Special for reject codes: F=511 gets ","-delimited string of codes
; F=511.01 gets first code, F=511.02 gets second one, etc.
N X,IEN02,IEN03,POS,IEN57 S IEN57=D0
S POS=$$POSITION,IEN02=$$IEN02,IEN03=$$IEN03
I $G(REV) S IEN02=$$REVIEN02,IEN03=$$REVIEN03
;
; Validate IENs
I 'IEN02 Q ""
I 'POS,F=308!(F>401) Q ""
I 'IEN03,F>500 Q ""
;
; Get Data
I F<402,F'=308 S X=$$GET1^DIQ(9002313.02,IEN02_",",F,"I")
E I F=308!(F>401&(F<500)) S X=$$GET1^DIQ(9002313.0201,POS_","_IEN02_",",F,"I")
E I F=501!(F=524) S X=$$GET1^DIQ(9002313.03,IEN03_",",F,"I")
E I F\1=511 D REJCODES S:F#1 X=$G(X(F#1*100))
E S X=$$GET1^DIQ(9002313.0301,POS_","_IEN03_",",F,"I")
;
; Do format conversions
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
D STRIPID ; strip field ID, if any
D MONEY ; money fields, where appropriate
D OTHER ; other special conversions
Q X
;
REJCODES ; rejection codes for IEN03
; X = ","-delimited string of two-char codes
; X(j)=code_" "_description
K X S X=""
N I,J S (I,J)=0
F S I=$O(^BPSR(IEN03,1000,POS,511,I)) Q:'I D
. N A S A=$P(^BPSR(IEN03,1000,POS,511,I,0),U) Q:'A
. S A=$O(^BPSF(9002313.93,"B",A,0)) Q:'A
. S A=^BPSF(9002313.93,A,0)
. S:X]"" X=X_"," S X=X_$P(A,U)
. S J=J+1,X(J)=$P(A,U)_" "_$P(A,U,2)
Q
;
STRIPID ; some fields have two-character field ID
Q:F<307 Q:F=308
I F>401,F<500 Q:F<410 Q:F=411 Q:F=414 Q:F=415 Q:F=419 Q:F=420 Q:F=426
I F>500 Q:F<512 Q:F=525 Q:F=526
S X=$E(X,3,$L(X))
Q
MONEY ; some fields are money fields in signed overpunch format
Q:F<402
I F>401,F<500 I F'=409,F'=410,F'=426,F'=430,F'=431,F'=433,F'=438,F'=428,F'=412 Q
I F>500 Q:F<505 Q:F=510 Q:F\1=511 Q:F=522 Q:F>523
S X=+$$DFF2EXT^BPSECFM(X)
I X=0 S X="" ; so [CAPTIONED] doesn't print it
Q
OTHER ; other special conversions
I F=442 S X=X/1000 Q ; metric decimal quantity
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOS57 4332 printed Apr 09, 2024@20:58:49 Page 2
BPSOS57 ;BHAM ISC/FCS/DRS/FLS - BPS Log of Transactions Utils ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ; Numerous BPS Log of Transaction functions are here
+5 ; Each assumes that IEN57 is defined
+6 ; Originally copied from BPSOSQ
+7 ;
DRGDFN() ; EP - BPS Log of Transaction field
+1 NEW RXI
+2 SET RXI=$$RXI
+3 IF 'RXI
QUIT ""
+4 ; Given IEN57, return DRGDFN
QUIT $$RXAPI1^BPSUTIL1(RXI,6,"I")
DRGNAME() ; EP - BPS Log of Transaction field
+1 NEW RXI
+2 SET RXI=$$RXI
+3 IF 'RXI
QUIT ""
+4 ; Given IEN57, return DRGNAME
QUIT $$RXAPI1^BPSUTIL1(RXI,6,"E")
RELDATE() ;EP - BPS Log of Transaction field
+1 NEW RXI,RXR
+2 SET RXI=$$RXI
SET RXR=$$RXR
+3 IF 'RXI
QUIT ""
+4 IF RXR
QUIT $$REFAPI1^BPSUTIL1(RXI,RXR,17,"I")
+5 QUIT $$RXAPI1^BPSUTIL1(RXI,31,"I")
RXI() ; Given IEN57, return RXI
QUIT $PIECE(^BPSTL(IEN57,1),U,11)
RXR() ; Given IEN57, return RXR
QUIT $PIECE(^BPSTL(IEN57,1),U,1)
NDC() QUIT $PIECE(^BPSTL(IEN57,1),U,2)
QTY() ; Given IEN57, return quantity
QUIT $PIECE(^BPSTL(IEN57,5),U)
AMT() ; return total $amount
QUIT $PIECE(^BPSTL(IEN57,5),U,5)
CHG() ; Given IEN57, ret total charge
QUIT $PIECE(^BPSTL(IEN57,5),U,5)
INSIEN() QUIT $PIECE(^BPSTL(IEN57,1),U,6)
PATIENT() QUIT $PIECE(^BPSTL(IEN57,0),U,6)
HRN() ; Health record number and facility abbreviation
+1 ; Called by BPS Log of Transaction field
+2 QUIT 0
USER() NEW X
SET X=$PIECE(^BPSTL(IEN57,0),U,10)
if 'X
SET X=$GET(DUZ)
QUIT X
NOW() NEW %,%H,%I,X
DO NOW^%DTC
QUIT %
ISREVERS(N) ;EP - BPSOSIY
+1 ; Returns reversal claim #, else false
+2 NEW X
SET X=$GET(^BPSTL(N,4))
if X=""
QUIT 0
+3 ; reversal of electronic claim
IF X
QUIT $PIECE(X,U)
+4 QUIT 0
REVACC(N) ;EP - BPSOSIY
+1 ; was this an accepted reversal? return true or false
+2 ; Treat Duplicate of Accepted Reversal ("S") as accepted
+3 NEW X
+4 SET X=$$REVRESP(N)
+5 QUIT X="A"!(X="S")
REVRESP(N) ;
+1 NEW RESP
SET RESP=$PIECE(^BPSTL(N,4),U,2)
+2 IF 'RESP
QUIT "?"
+3 NEW X
SET X=$$RESP500^BPSOSQ4(RESP,"I")
+4 ; Should be "A" or "R" - can be "S" (Duplicate of Accepted Reversal)
QUIT X
+5 ;
POSITION() ; return pointer to position within claim (D1)
+1 QUIT $PIECE($GET(^BPSTL(IEN57,0)),U,9)
IEN02() ; return pointer to claim
+1 QUIT $PIECE($GET(^BPSTL(IEN57,0)),U,4)
IEN03() ; return pointer to response
+1 QUIT $PIECE($GET(^BPSTL(IEN57,0)),U,5)
REVIEN02() ; return pointer to reversal claim
+1 QUIT $PIECE($GET(^BPSTL(IEN57,4)),U)
REVIEN03() ; return pointer to reversal response
+1 QUIT $PIECE($GET(^BPSTL(IEN57,4)),U,2)
FIELD(F,REV) ; EP - BPS Log of Transaction fields
+1 ; Retrieve field F from claim or response - Given IEN57
+2 ; Returns value
+3 ; Special for reject codes: F=511 gets ","-delimited string of codes
+4 ; F=511.01 gets first code, F=511.02 gets second one, etc.
+5 NEW X,IEN02,IEN03,POS,IEN57
SET IEN57=D0
+6 SET POS=$$POSITION
SET IEN02=$$IEN02
SET IEN03=$$IEN03
+7 IF $GET(REV)
SET IEN02=$$REVIEN02
SET IEN03=$$REVIEN03
+8 ;
+9 ; Validate IENs
+10 IF 'IEN02
QUIT ""
+11 IF 'POS
IF F=308!(F>401)
QUIT ""
+12 IF 'IEN03
IF F>500
QUIT ""
+13 ;
+14 ; Get Data
+15 IF F<402
IF F'=308
SET X=$$GET1^DIQ(9002313.02,IEN02_",",F,"I")
+16 IF '$TEST
IF F=308!(F>401&(F<500))
SET X=$$GET1^DIQ(9002313.0201,POS_","_IEN02_",",F,"I")
+17 IF '$TEST
IF F=501!(F=524)
SET X=$$GET1^DIQ(9002313.03,IEN03_",",F,"I")
+18 IF '$TEST
IF F\1=511
DO REJCODES
if F#1
SET X=$GET(X(F#1*100))
+19 IF '$TEST
SET X=$$GET1^DIQ(9002313.0301,POS_","_IEN03_",",F,"I")
+20 ;
+21 ; Do format conversions
+22 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+23 ; strip field ID, if any
DO STRIPID
+24 ; money fields, where appropriate
DO MONEY
+25 ; other special conversions
DO OTHER
+26 QUIT X
+27 ;
REJCODES ; rejection codes for IEN03
+1 ; X = ","-delimited string of two-char codes
+2 ; X(j)=code_" "_description
+3 KILL X
SET X=""
+4 NEW I,J
SET (I,J)=0
+5 FOR
SET I=$ORDER(^BPSR(IEN03,1000,POS,511,I))
if 'I
QUIT
Begin DoDot:1
+6 NEW A
SET A=$PIECE(^BPSR(IEN03,1000,POS,511,I,0),U)
if 'A
QUIT
+7 SET A=$ORDER(^BPSF(9002313.93,"B",A,0))
if 'A
QUIT
+8 SET A=^BPSF(9002313.93,A,0)
+9 if X]""
SET X=X_","
SET X=X_$PIECE(A,U)
+10 SET J=J+1
SET X(J)=$PIECE(A,U)_" "_$PIECE(A,U,2)
End DoDot:1
+11 QUIT
+12 ;
STRIPID ; some fields have two-character field ID
+1 if F<307
QUIT
if F=308
QUIT
+2 IF F>401
IF F<500
if F<410
QUIT
if F=411
QUIT
if F=414
QUIT
if F=415
QUIT
if F=419
QUIT
if F=420
QUIT
if F=426
QUIT
+3 IF F>500
if F<512
QUIT
if F=525
QUIT
if F=526
QUIT
+4 SET X=$EXTRACT(X,3,$LENGTH(X))
+5 QUIT
MONEY ; some fields are money fields in signed overpunch format
+1 if F<402
QUIT
+2 IF F>401
IF F<500
IF F'=409
IF F'=410
IF F'=426
IF F'=430
IF F'=431
IF F'=433
IF F'=438
IF F'=428
IF F'=412
QUIT
+3 IF F>500
if F<505
QUIT
if F=510
QUIT
if F\1=511
QUIT
if F=522
QUIT
if F>523
QUIT
+4 SET X=+$$DFF2EXT^BPSECFM(X)
+5 ; so [CAPTIONED] doesn't print it
IF X=0
SET X=""
+6 QUIT
OTHER ; other special conversions
+1 ; metric decimal quantity
IF F=442
SET X=X/1000
QUIT
+2 QUIT
