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