IBCE837T ;EDE/JWS - RPC to setup test claims for non-production sites;12/23/2020
;;2.0;INTEGRATED BILLING;**650**;21-MAR-94;Build 21
;;Per VA Directive 6402, this routine should not be modified.
;
GET(RESULT,ARG) ;
;
N RES,DILOCKTM,DISYS,DT,DTIME,IO,X
N CT
K RESULT
;JWS;IB*2.0*650v9;remove setting of DUZ(0)
D DTNOLF^DICRW
;;S RES("site")=$P($$SITE^VASITE,U,3)
;
I $$PROD^XUPROD(1) S RES("STATUS")="This is a PRODUCTION environment, cannot setup 837 FHIR test claims" G RET
;
I '$$GET1^DIQ(350.9,"1,",8.21,"I") S RES("STATUS")="837 FHIR processing is not turned ON in this environment" G RET
;
I '$F(",2,3,7,*,",","_ARG("CLAIMTYPE")) S ARG("CLAIMTYPE")=""
I ARG("NUMCLAIMS")'?.N S ARG("NUMCLAIMS")=0
;
I '$D(ARG("REPEATS")) S ARG("REPEATS")=1
D SET(ARG("NUMCLAIMS"),ARG("REPEATS"),ARG("CLAIMTYPE"))
;
S RES("STATUS")=CT_" Claims setup for 837 FHIR transmission"
;
RET ; setup return JSON
; create JSON structured message
D ENCODE^XLFJSONE("RES","RESULT")
D FINISH^IBCE837I
Q
;
;
SET(XCT,REPEAT,XTYPE) ;
N IB364,IBXIEN,IBNF,IB0,IBAMT,IBTXST,IBNOTX,IBTXTEST,IBBTYP,IBQUE
I $G(REPEAT) K ^XTMP("IBCE837T")
I $G(XTYPE)="*" S XTYPE=""
S IB364="A"
F S IB364=$O(^IBA(364,IB364),-1) Q:IB364="" D Q:$G(CT)=XCT
. S X=$G(^IBA(364,IB364,0)) I +X="" Q
. I $P(X,"^",3)="Z" Q ;claim is closed
. S IBXIEN=+$G(^IBA(364,IB364,0)),IBNF=""
. I IB364'=$$LAST364^IBCEF4(IBXIEN) Q ;make sure we have the correct 364 entry.
. S IB0=$G(^DGCR(399,IBXIEN,0))
. S IBAMT=$P($G(^DGCR(399,IBXIEN,"U1")),"^")
. I IBAMT'>0 Q
. S IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
. Q:IBTXST="" ; no txmt
. I IB0="" Q
. ;JWS;IB*2.0*650v7;for consistenacy, do not include claims with no primary ins pointer
. I $P($G(^DGCR(399,IBXIEN,"M")),"^")="" Q
. I XTYPE'="",XTYPE'=$$FT^IBCEF(IBXIEN) Q
. S IBTXTEST=$S($G(IBTEST):2,1:+$$TEST^IBCEF4(IBXIEN))
. S IBBTYP=$P("P^I^D",U,$S($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
. I $$TESTPT^IBCEU($P(IB0,U,2)),'IBTXTEST Q
. I $P(IB0,U,13)>4 Q ;IF CANCELLED SKIP
. I '$D(^DGCR(399,IBXIEN,"CP")) Q
. I $D(^TMP($J,"BILL",$P(IB0,U))) Q ; do not send duplicates
. I '$G(REPEAT),$D(^XTMP("IBCE837T",$P(IB0,U))) Q
. ; 11/12/19 skip rebilled claim entries
. I $F($P(IB0,U),"-") Q
. S ^TMP($J,"BILL",$P(IB0,U))="",^XTMP("IBCE837T",$P(IB0,U))=""
. S IBQUE=$$GET1^DIQ(350.9,"1,",8.09)
. D SETCLM^IBCE837I(IB364,IBQUE,1) S CT=$I(CT)
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837T 2483 printed Apr 09, 2024@21:26:32 Page 2
IBCE837T ;EDE/JWS - RPC to setup test claims for non-production sites;12/23/2020
+1 ;;2.0;INTEGRATED BILLING;**650**;21-MAR-94;Build 21
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
GET(RESULT,ARG) ;
+1 ;
+2 NEW RES,DILOCKTM,DISYS,DT,DTIME,IO,X
+3 NEW CT
+4 KILL RESULT
+5 ;JWS;IB*2.0*650v9;remove setting of DUZ(0)
+6 DO DTNOLF^DICRW
+7 ;;S RES("site")=$P($$SITE^VASITE,U,3)
+8 ;
+9 IF $$PROD^XUPROD(1)
SET RES("STATUS")="This is a PRODUCTION environment, cannot setup 837 FHIR test claims"
GOTO RET
+10 ;
+11 IF '$$GET1^DIQ(350.9,"1,",8.21,"I")
SET RES("STATUS")="837 FHIR processing is not turned ON in this environment"
GOTO RET
+12 ;
+13 IF '$FIND(",2,3,7,*,",","_ARG("CLAIMTYPE"))
SET ARG("CLAIMTYPE")=""
+14 IF ARG("NUMCLAIMS")'?.N
SET ARG("NUMCLAIMS")=0
+15 ;
+16 IF '$DATA(ARG("REPEATS"))
SET ARG("REPEATS")=1
+17 DO SET(ARG("NUMCLAIMS"),ARG("REPEATS"),ARG("CLAIMTYPE"))
+18 ;
+19 SET RES("STATUS")=CT_" Claims setup for 837 FHIR transmission"
+20 ;
RET ; setup return JSON
+1 ; create JSON structured message
+2 DO ENCODE^XLFJSONE("RES","RESULT")
+3 DO FINISH^IBCE837I
+4 QUIT
+5 ;
+6 ;
SET(XCT,REPEAT,XTYPE) ;
+1 NEW IB364,IBXIEN,IBNF,IB0,IBAMT,IBTXST,IBNOTX,IBTXTEST,IBBTYP,IBQUE
+2 IF $GET(REPEAT)
KILL ^XTMP("IBCE837T")
+3 IF $GET(XTYPE)="*"
SET XTYPE=""
+4 SET IB364="A"
+5 FOR
SET IB364=$ORDER(^IBA(364,IB364),-1)
if IB364=""
QUIT
Begin DoDot:1
+6 SET X=$GET(^IBA(364,IB364,0))
IF +X=""
QUIT
+7 ;claim is closed
IF $PIECE(X,"^",3)="Z"
QUIT
+8 SET IBXIEN=+$GET(^IBA(364,IB364,0))
SET IBNF=""
+9 ;make sure we have the correct 364 entry.
IF IB364'=$$LAST364^IBCEF4(IBXIEN)
QUIT
+10 SET IB0=$GET(^DGCR(399,IBXIEN,0))
+11 SET IBAMT=$PIECE($GET(^DGCR(399,IBXIEN,"U1")),"^")
+12 IF IBAMT'>0
QUIT
+13 SET IBTXST=$$TXMT^IBCEF4(IBXIEN,.IBNOTX,IBNF)
+14 ; no txmt
if IBTXST=""
QUIT
+15 IF IB0=""
QUIT
+16 ;JWS;IB*2.0*650v7;for consistenacy, do not include claims with no primary ins pointer
+17 IF $PIECE($GET(^DGCR(399,IBXIEN,"M")),"^")=""
QUIT
+18 IF XTYPE'=""
IF XTYPE'=$$FT^IBCEF(IBXIEN)
QUIT
+19 SET IBTXTEST=$SELECT($GET(IBTEST):2,1:+$$TEST^IBCEF4(IBXIEN))
+20 SET IBBTYP=$PIECE("P^I^D",U,$SELECT($$FT^IBCEF(IBXIEN)=7:3,1:($$FT^IBCEF(IBXIEN)=3)+1))_"-"_IBTXTEST
+21 IF $$TESTPT^IBCEU($PIECE(IB0,U,2))
IF 'IBTXTEST
QUIT
+22 ;IF CANCELLED SKIP
IF $PIECE(IB0,U,13)>4
QUIT
+23 IF '$DATA(^DGCR(399,IBXIEN,"CP"))
QUIT
+24 ; do not send duplicates
IF $DATA(^TMP($JOB,"BILL",$PIECE(IB0,U)))
QUIT
+25 IF '$GET(REPEAT)
IF $DATA(^XTMP("IBCE837T",$PIECE(IB0,U)))
QUIT
+26 ; 11/12/19 skip rebilled claim entries
+27 IF $FIND($PIECE(IB0,U),"-")
QUIT
+28 SET ^TMP($JOB,"BILL",$PIECE(IB0,U))=""
SET ^XTMP("IBCE837T",$PIECE(IB0,U))=""
+29 SET IBQUE=$$GET1^DIQ(350.9,"1,",8.09)
+30 DO SETCLM^IBCE837I(IB364,IBQUE,1)
