BPSSCRCL ;BHAM ISC/SS - ECME SCREEN CLOSE CLAIMS ;05-APR-05
;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,11,15,19,20,30,31**;JUN 2004;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to FIND^PSOREJUT supported by ICR #4706
;
Q
;
CLO ;entry point to close claims
N BPRET,BPSARR59
I '$D(@(VALMAR)) Q
D FULL^VALM1
W !,"Enter the line numbers for the claim(s) to be closed."
S BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,VALMAR)
I BPRET="^" S VALMBCK="R" Q
;close claims
;update the content of the screen
;only if at least one claim was closed
I $$CLOSE(.BPSARR59) D REDRAW^BPSSCRUD("Updating screen for closed claims...")
E S VALMBCK="R"
Q
;
;close claims
;input:
; BP59ARR - array with ptrs to BPS TRANSACTION FILE
; BP59ARR(ien59)="ien in TMP ^ number on the user screen"
;returns:
; BPCLTOT - number of closed claims
CLOSE(BP59ARR) ;
N BPNEWARR,BPRETV,BPREJFLG,X
N BPDFN,BP59,BPIFANY,BPQ,BPCLST,BPS52,BPSRF,BPSZ,BPSECOND
N BPREAS,BPCOMM,BP90ANSW,BPRCOPAY,BPRXINFO,BPCOP,BPCLTOT,BPINS,BPINSNM,BP59FRST
S BPRETV=$$MKNEWARR^BPSSCR05(.BP59ARR,.BPNEWARR,.BPINS)
S BPQ="",BPIFANY=0,BPREJFLG=1,BPSECOND=0
S BPDFN=""
F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D Q:BPQ="^"
. W !!,"You've chosen to close the following prescription(s) for",!,$E($$PATNAME^BPSSCRU2(BPDFN),1,13)_" :"
. S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D Q:BPQ="^"
. . I $Y>20 D PAUSE^VALM1 W @IOF I X="^" S BPQ="^" Q
. . S BPIFANY=1,BPQ=""
. . S BPREJFLG=+$P($G(BPNEWARR(BPDFN,BP59)),U,3)
. . W !,@VALMAR@(+$G(BPNEWARR(BPDFN,BP59)),0)
. . D DISPREJ^BPSSCRU6(BP59)
. . ;
. . ; don't allow the selection of non-billable entries here
. . I $$NB^BPSSCR03(BP59) D S BPQ="^" Q
. . . W !?6,$$EREJTXT^BPSSCR03(BP59)
. . . W !,"Entry is NON BILLABLE. There is no claim to close."
. . . Q
. . ;
. . ;can't close a closed claim. The user must reopen first.
. . I $$CLOSED02^BPSSCR03($P($G(^BPST(BP59,0)),U,4)) W !,"This claim is already closed." S BPQ="^" Q
. . ; Check for unresolved rejects - BPS*1*19
. . S BPSZ=$$RXREF^BPSSCRU2(BP59)
. . I $$FIND^PSOREJUT($P(BPSZ,U),$P(BPSZ,U,2)) D Q
. . . W !,"The Prescription is currently open in the pharmacist's Third Party Payer"
. . . W !,"Reject Worklist. The claim cannot be closed until action is taken by the"
. . . W !,"pharmacist."
. . . S BPQ="^"
. . ;get claim status from transaction
. . S BPCLST=$$CLAIMST^BPSSCRU3(BP59)
. . ;Is this a secondary claim?
. . I $P($G(^BPST(BP59,0)),U,14)=2 S BPSECOND=1
. . I $P($G(^BPST(BP59,0)),U,14)<2,$$PAYABLE^BPSOSRX5($P(BPCLST,U)),$$PAYBLSEC^BPSUTIL2(BP59) D S BPQ="^" Q
. . . W !,"The claim cannot be closed if the secondary claim is payable.",!,"Please reverse the secondary claim first."
. . I BPSECOND,BPCLST'["E REJECTED",BPCLST'["E REVERSAL ACCEPTED" D S BPQ="^" Q
. . . W !,"The CLOSE action can only be applied to an E REJECTED or E REVERSAL ACCEPTED",!,"secondary claim. This claim is ",$P(BPCLST,U),".",!,"The secondary claim is also closed when the primary claim is closed."
. . W:BPREJFLG=0 !,"Claim Neither Rejected Nor Reversed and cannot be Closed."
I +BPRETV=0 Q $$QUITCL()
I BPQ="^" Q $$QUITCL()
;
; check 2nd insurance, but only if closing a Primary claim.
S BPQ=""
I 'BPSECOND D
. S BPDFN="" F S BPDFN=$O(BPINS(BPDFN)) Q:BPDFN="" D Q:BPQ="^"
. . S BPINSNM="" F S BPINSNM=$O(BPINS(BPDFN,BPINSNM)) Q:BPINSNM="" D Q:BPQ="^"
. . . S BP59FRST=0
. . . S BP59=""
. . . K BPRXINFO
. . . F S BP59=$O(BPINS(BPDFN,BPINSNM,BP59)) Q:BP59="" D Q:BPQ="^"
. . . . S:BP59FRST=0 BP59FRST=BP59
. . . . S BPRXINFO(BP59)=$E($G(@VALMAR@(+$G(BP59ARR(BP59)),0)),7,99)
. . . ; Only check 2nd if the RX/Fill is released
. . . S BPSZ=$$RXREF^BPSSCRU2(BP59FRST)
. . . S BPS52=$P(BPSZ,U),BPSRF=$P(BPSZ,U,2)
. . . Q:$$RELDATE^BPSBCKJ(BPS52,BPSRF)']""
. . . ; call CH2NDINS^BPSSCRU5 only once for all claims for this patient and insurance
. . . ; you can use one BP59FRST for the group of claims here as a parameter since
. . . ; they all are all identical from the "patient-insurance pair" point of view
. . . D:BP59FRST>0 CH2NDINS^BPSSCRU5(BP59FRST,$E($$PATNAME^BPSSCRU2(BPDFN),1,13),BPINSNM,.BPRXINFO)
;
I BPQ="^" Q $$QUITCL()
;
W !!,"ALL Selected Rxs will be CLOSED using the same information gathered in the",!,"following prompts.",!
S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
I BPQ'=1 Q $$QUITCL() ;
; ask questions for all of them
W !!
I $$ASKQUEST(+$P(BPRETV,U,2),.BPREAS,.BPCOMM,.BP90ANSW,.BPRCOPAY)'=1 Q $$QUITCL()
;
W @IOF
;and finally close all
S BPCLTOT=0
S BPDFN="" F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D
. S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D
. . I $P($G(BPNEWARR(BPDFN,BP59)),U,3)=0 Q ;can't be closed
. . S BPCOP=0
. . I +BPRCOPAY=1,$P($G(BPNEWARR(BPDFN,BP59)),U,4)=1 S BPCOP=1 ;release copay
. . I $$CLOSEIT(BP59,$P(BPREAS,U,2),BPCOMM,BP90ANSW,BPCOP)>0 D
. . . S BPCLTOT=BPCLTOT+1
;
W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been closed.",!
D PAUSE^VALM1
Q BPCLTOT
;
QUITCL() ;
W !!,"0 claims have been closed."
D PAUSE^VALM1
Q 0
;/**
;Ask all necessary questions
;Input
; BPRELCOP - ask release copay question
; .BPREAZ - ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG
; .BPCOMZ - close comment (string)
; .BP90ANSZ - "", "D"(drop to paper) or "N" (non-billable)
; .BPRCOPAZ - 1(Yes) or 0(No) , answer to "release copay" question
;Output:
; 0 - cancel process
; ^ - emergency quit (cancel process)
; 1 - ok, can proceed
ASKQUEST(BPRELCOP,BPREAZ,BPCOMZ,BP90ANSZ,BPRCOPAZ) ;*/
S BPCOMZ=""
S BP90ANSZ=""
S BPRCOPAZ=0
;ask the user to choose the close reason from #356.8
;using set of close reasons in IB file 356.8
S BPREAZ=$$REASON()
I BPREAZ="^" Q "^"
I ($P(BPREAZ,U,4)=1) D ;if has ECME PAPER FLAG
. ;ask if the claim is still billable thru paper?
. S BP90ANSZ=$$PROMPT^BPSSCRCV("S^N:NON-BILLABLE;D:DROP TO PAPER","Treat as (N)on-Billable Episode or (D)rop Bill to Paper?","")
I BP90ANSZ=-1 Q "^"
S BPCOMZ=$$COMMENT("Comment ",40)
I (BPCOMZ="^") Q "^"
I $L(BPCOMZ)>0,BPCOMZ?1" "." " S BPCOMZ=""
;check copay
;ask "release copay?" in all NON-BILLABLE cases, i.e. except user answered "DROP TO PAPER"
;(even in cases when he was not asked about it)
I BP90ANSZ'="D",BPRELCOP D
. ; Ask user if s/he wants to release a copay
. S BPRCOPAZ=$$YESNO^BPSSCRRS("Release Patient CoPay(Y/N)")
I BPRCOPAZ=-1 Q "^"
;
S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
I BPQ=-1 Q "^" ;quit by "^"
I BPQ'=1 Q 0 ;doesn't want to proceed
Q 1 ; answers can be used
;
;/**
;ask for the close reason
;return:
; ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG ^ CODE ^ INACTIVE
;
; Allow the user to select an entry that has ECME FLAG set to 1 and INACTIVE flag not set to 1
REASON() ;
N DIC,BPREASNM,BP3568,Y
; - Asks for REASON for Closing
S DIC="^IBE(356.8,",DIC(0)="AEQMZ"
S DIC("S")="I ($P(^(0),U,2)=1),($P(^(0),U,5)'=1)"
D ^DIC
I Y=-1 Q "^"
Q +Y_U_Y(0)
;/**
;enter the comment
;BPSTR -prompt string
;BPMLEN -maxlen
N DIR,DTOUT,DUOUT,BPQ
I '$D(BPSTR) S BPSTR="Comment "
I '$D(BPMLEN) S BPMLEN=40
S DIR(0)="FO^0:250"
S DIR("A")=BPSTR
S DIR("?",1)="This response must have no more than "_BPMLEN_" characters"
S DIR("?")="and must not contain embedded up arrow."
S BPQ=0
F D Q:+BPQ'=0
. D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S BPQ=-1 Q
. I $L(Y)'>BPMLEN S BPQ=1 Q
. W !!,"This response must have no more than "_BPMLEN_" characters"
. W !,"and must not contain embedded uparrow.",!
. S DIR("B")=$E(Y,1,BPMLEN)
Q:BPQ<0 "^"
Q Y
;/**
;close the claim
;the approach and code partially borrowed from IHS code CLOSE^BPSOS6N
;BPSTRA - ptr to #9002313.59
;REASON - text name of the close reason
;BPSCLCM - comment
;BPDROP:
; "D" - DROP BILL TO PAPER
; "N" - NON-BILLABLE
;BPRELCOP - 1 (Yes) or 0 (No) release copay or not?
CLOSEIT(BPSTRA,REASON,BPSCLCM,BPDROP,BPRELCOP) ;
N BPSCLA,ERROR,DA,DR,BPLCK,DIE
S BPSCLA=$$GET1^DIQ(9002313.59,BPSTRA,3,"I")
W !,"Closing Claim ",$$GET1^DIQ(9002313.02,BPSCLA,.01),"..."
S BPLCK=0
L +^BPSC(BPSCLA):0
I $T S BPLCK=1
E W !," *** CLAIM ",$$GET1^DIQ(9002313.02,BPSCLA,.01)," IN USE ***" Q 0
D CLOSE^BPSBUTL(BPSCLA,BPSTRA,REASON,$S($G(BPDROP)="D":1,1:0),BPRELCOP,BPSCLCM,.ERROR,1)
I $D(ERROR) W "NOT OK" D DSPERR(ERROR) D Q 0
. I BPLCK=1 L -^BPSC(BPSCLA)
S DIE="^BPSC(",DA=BPSCLA,DR="901///1;902///"_$$NOW^XLFDT()_";903////"_DUZ_";904///"_REASON_";905////"_BPDROP D ^DIE
I BPLCK=1 L -^BPSC(BPSCLA)
H 1 W "OK"
Q 1
;
DSPERR(MSG) ; Display the ERROR message
W !,"Error: *** ",MSG," ***"
Q
;
;/**
;ECME has tried to submit the claim to insurance with the name BPINSNAM
;but the claim was rejected and now we need to determine if the patient
;has any other insurance with pharmacy coverage that can be billed for the RX
;Input:
; BP59 - pointer to file #9002313.59
; BPINSNAM - insurance that have already been used by ECME
;Output:
; 0 - not found
; 1 ^ Insurance Name ^ Group Number ^ Date of service
NEXTINS(BP59,BPINSNAM) ;get insurance info by the pointer of #9002313.59
N BPDOS,BPDFN,BPZZ,BP36,BPX,BPHONE,BPY,BPINSNM
N BPPHARM,BPCOORD,BPINS,BPFOUND
S BPY=0
S BPHONE=$P($G(^BPST(BP59,10,+$G(^BPST(BP59,9)),3)),U,2)
S BPDOS=+$P($G(^BPST(BP59,12)),U,2)\1
I BPDOS=0 S BPDOS=+$P($G(^BPST(BP59,0)),U,8)\1
S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
; call INSUR^IBBAPI to get information about:
;1 = Insurance Company Name
;7 = Coordination of Benefits (primary, secondary, tertiary)
;15 = Pharmacy Coverage?
;18 = Group Number
S BPX=$$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,7,15,18")
S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D
. ;get pharmacy coverage
. S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15))
I BPX<1 Q 0
D PROCINS(.BPZZ)
;check pharmacy coverage
S BPFOUND=0 ;if found will be set to insurance node in the INSUR^IBBAPI array
S BPPHARM=1 ;look only at those with pharmacy coverage
S BPCOORD=0
F S BPCOORD=+$O(BPZZ("RES",BPPHARM,BPCOORD)) Q:BPCOORD=0!(BPFOUND'=0) D
. S BPINS=+$O(BPZZ("RES",BPPHARM,BPCOORD,0))
. I BPINS>0 I $P($G(BPZZ("IBBAPI","INSUR",BPINS,1)),U,2)'=BPINSNAM S BPFOUND=BPINS
I BPFOUND=0 Q 0
Q 1_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,1)),U,2)_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,18)),U)_U_BPDOS
;
;process insurances
;input: local array returned by INSUR^IBBAPI
;output: BPZZ("RES",pharmacy coverage,coordination,insurance element # in BPZZ array)
PROCINS(BPZZ) ;
N BP1,BP2,BP0,BPPHONE,BPPHARM,BPCOORD
S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D
. ;get pharmacy coverage
. S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15))
. ;get coordination of benefits
. S BPCOORD=+$G(BPZZ("IBBAPI","INSUR",BP1,7))
. ;create ^TMP to sort results by pharmacy coverage and coordination of benefits
. S BPZZ("RES",BPPHARM,BPCOORD,BP1)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSSCRCL 11155 printed Dec 13, 2024@01:53:06 Page 2
BPSSCRCL ;BHAM ISC/SS - ECME SCREEN CLOSE CLAIMS ;05-APR-05
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,11,15,19,20,30,31**;JUN 2004;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to FIND^PSOREJUT supported by ICR #4706
+5 ;
+6 QUIT
+7 ;
CLO ;entry point to close claims
+1 NEW BPRET,BPSARR59
+2 IF '$DATA(@(VALMAR))
QUIT
+3 DO FULL^VALM1
+4 WRITE !,"Enter the line numbers for the claim(s) to be closed."
+5 SET BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,VALMAR)
+6 IF BPRET="^"
SET VALMBCK="R"
QUIT
+7 ;close claims
+8 ;update the content of the screen
+9 ;only if at least one claim was closed
+10 IF $$CLOSE(.BPSARR59)
DO REDRAW^BPSSCRUD("Updating screen for closed claims...")
+11 IF '$TEST
SET VALMBCK="R"
+12 QUIT
+13 ;
+14 ;close claims
+15 ;input:
+16 ; BP59ARR - array with ptrs to BPS TRANSACTION FILE
+17 ; BP59ARR(ien59)="ien in TMP ^ number on the user screen"
+18 ;returns:
+19 ; BPCLTOT - number of closed claims
CLOSE(BP59ARR) ;
+1 NEW BPNEWARR,BPRETV,BPREJFLG,X
+2 NEW BPDFN,BP59,BPIFANY,BPQ,BPCLST,BPS52,BPSRF,BPSZ,BPSECOND
+3 NEW BPREAS,BPCOMM,BP90ANSW,BPRCOPAY,BPRXINFO,BPCOP,BPCLTOT,BPINS,BPINSNM,BP59FRST
+4 SET BPRETV=$$MKNEWARR^BPSSCR05(.BP59ARR,.BPNEWARR,.BPINS)
+5 SET BPQ=""
SET BPIFANY=0
SET BPREJFLG=1
SET BPSECOND=0
+6 SET BPDFN=""
+7 FOR
SET BPDFN=$ORDER(BPNEWARR(BPDFN))
if BPDFN=""
QUIT
Begin DoDot:1
+8 WRITE !!,"You've chosen to close the following prescription(s) for",!,$EXTRACT($$PATNAME^BPSSCRU2(BPDFN),1,13)_" :"
+9 SET BP59=""
FOR
SET BP59=$ORDER(BPNEWARR(BPDFN,BP59))
if BP59=""
QUIT
Begin DoDot:2
+10 IF $Y>20
DO PAUSE^VALM1
WRITE @IOF
IF X="^"
SET BPQ="^"
QUIT
+11 SET BPIFANY=1
SET BPQ=""
+12 SET BPREJFLG=+$PIECE($GET(BPNEWARR(BPDFN,BP59)),U,3)
+13 WRITE !,@VALMAR@(+$GET(BPNEWARR(BPDFN,BP59)),0)
+14 DO DISPREJ^BPSSCRU6(BP59)
+15 ;
+16 ; don't allow the selection of non-billable entries here
+17 IF $$NB^BPSSCR03(BP59)
Begin DoDot:3
+18 WRITE !?6,$$EREJTXT^BPSSCR03(BP59)
+19 WRITE !,"Entry is NON BILLABLE. There is no claim to close."
+20 QUIT
End DoDot:3
SET BPQ="^"
QUIT
+21 ;
+22 ;can't close a closed claim. The user must reopen first.
+23 IF $$CLOSED02^BPSSCR03($PIECE($GET(^BPST(BP59,0)),U,4))
WRITE !,"This claim is already closed."
SET BPQ="^"
QUIT
+24 ; Check for unresolved rejects - BPS*1*19
+25 SET BPSZ=$$RXREF^BPSSCRU2(BP59)
+26 IF $$FIND^PSOREJUT($PIECE(BPSZ,U),$PIECE(BPSZ,U,2))
Begin DoDot:3
+27 WRITE !,"The Prescription is currently open in the pharmacist's Third Party Payer"
+28 WRITE !,"Reject Worklist. The claim cannot be closed until action is taken by the"
+29 WRITE !,"pharmacist."
+30 SET BPQ="^"
End DoDot:3
QUIT
+31 ;get claim status from transaction
+32 SET BPCLST=$$CLAIMST^BPSSCRU3(BP59)
+33 ;Is this a secondary claim?
+34 IF $PIECE($GET(^BPST(BP59,0)),U,14)=2
SET BPSECOND=1
+35 IF $PIECE($GET(^BPST(BP59,0)),U,14)<2
IF $$PAYABLE^BPSOSRX5($PIECE(BPCLST,U))
IF $$PAYBLSEC^BPSUTIL2(BP59)
Begin DoDot:3
+36 WRITE !,"The claim cannot be closed if the secondary claim is payable.",!,"Please reverse the secondary claim first."
End DoDot:3
SET BPQ="^"
QUIT
+37 IF BPSECOND
IF BPCLST'["E REJECTED"
IF BPCLST'["E REVERSAL ACCEPTED"
Begin DoDot:3
+38 WRITE !,"The CLOSE action can only be applied to an E REJECTED or E REVERSAL ACCEPTED",!,"secondary claim. This claim is ",$PIECE(BPCLST,U),".",!,"The secondary claim is also closed when the primary claim is clos
ed."
End DoDot:3
SET BPQ="^"
QUIT
+39 if BPREJFLG=0
WRITE !,"Claim Neither Rejected Nor Reversed and cannot be Closed."
End DoDot:2
if BPQ="^"
QUIT
End DoDot:1
if BPQ="^"
QUIT
+40 IF +BPRETV=0
QUIT $$QUITCL()
+41 IF BPQ="^"
QUIT $$QUITCL()
+42 ;
+43 ; check 2nd insurance, but only if closing a Primary claim.
+44 SET BPQ=""
+45 IF 'BPSECOND
Begin DoDot:1
+46 SET BPDFN=""
FOR
SET BPDFN=$ORDER(BPINS(BPDFN))
if BPDFN=""
QUIT
Begin DoDot:2
+47 SET BPINSNM=""
FOR
SET BPINSNM=$ORDER(BPINS(BPDFN,BPINSNM))
if BPINSNM=""
QUIT
Begin DoDot:3
+48 SET BP59FRST=0
+49 SET BP59=""
+50 KILL BPRXINFO
+51 FOR
SET BP59=$ORDER(BPINS(BPDFN,BPINSNM,BP59))
if BP59=""
QUIT
Begin DoDot:4
+52 if BP59FRST=0
SET BP59FRST=BP59
+53 SET BPRXINFO(BP59)=$EXTRACT($GET(@VALMAR@(+$GET(BP59ARR(BP59)),0)),7,99)
End DoDot:4
if BPQ="^"
QUIT
+54 ; Only check 2nd if the RX/Fill is released
+55 SET BPSZ=$$RXREF^BPSSCRU2(BP59FRST)
+56 SET BPS52=$PIECE(BPSZ,U)
SET BPSRF=$PIECE(BPSZ,U,2)
+57 if $$RELDATE^BPSBCKJ(BPS52,BPSRF)']""
QUIT
+58 ; call CH2NDINS^BPSSCRU5 only once for all claims for this patient and insurance
+59 ; you can use one BP59FRST for the group of claims here as a parameter since
+60 ; they all are all identical from the "patient-insurance pair" point of view
+61 if BP59FRST>0
DO CH2NDINS^BPSSCRU5(BP59FRST,$EXTRACT($$PATNAME^BPSSCRU2(BPDFN),1,13),BPINSNM,.BPRXINFO)
End DoDot:3
if BPQ="^"
QUIT
End DoDot:2
if BPQ="^"
QUIT
End DoDot:1
+62 ;
+63 IF BPQ="^"
QUIT $$QUITCL()
+64 ;
+65 WRITE !!,"ALL Selected Rxs will be CLOSED using the same information gathered in the",!,"following prompts.",!
+66 SET BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
+67 ;
IF BPQ'=1
QUIT $$QUITCL()
+68 ; ask questions for all of them
+69 WRITE !!
+70 IF $$ASKQUEST(+$PIECE(BPRETV,U,2),.BPREAS,.BPCOMM,.BP90ANSW,.BPRCOPAY)'=1
QUIT $$QUITCL()
+71 ;
+72 WRITE @IOF
+73 ;and finally close all
+74 SET BPCLTOT=0
+75 SET BPDFN=""
FOR
SET BPDFN=$ORDER(BPNEWARR(BPDFN))
if BPDFN=""
QUIT
Begin DoDot:1
+76 SET BP59=""
FOR
SET BP59=$ORDER(BPNEWARR(BPDFN,BP59))
if BP59=""
QUIT
Begin DoDot:2
+77 ;can't be closed
IF $PIECE($GET(BPNEWARR(BPDFN,BP59)),U,3)=0
QUIT
+78 SET BPCOP=0
+79 ;release copay
IF +BPRCOPAY=1
IF $PIECE($GET(BPNEWARR(BPDFN,BP59)),U,4)=1
SET BPCOP=1
+80 IF $$CLOSEIT(BP59,$PIECE(BPREAS,U,2),BPCOMM,BP90ANSW,BPCOP)>0
Begin DoDot:3
+81 SET BPCLTOT=BPCLTOT+1
End DoDot:3
End DoDot:2
End DoDot:1
+82 ;
+83 WRITE !,BPCLTOT," claim",$SELECT(BPCLTOT'=1:"s have",1:" has")," been closed.",!
+84 DO PAUSE^VALM1
+85 QUIT BPCLTOT
+86 ;
QUITCL() ;
+1 WRITE !!,"0 claims have been closed."
+2 DO PAUSE^VALM1
+3 QUIT 0
+4 ;/**
+5 ;Ask all necessary questions
+6 ;Input
+7 ; BPRELCOP - ask release copay question
+8 ; .BPREAZ - ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG
+9 ; .BPCOMZ - close comment (string)
+10 ; .BP90ANSZ - "", "D"(drop to paper) or "N" (non-billable)
+11 ; .BPRCOPAZ - 1(Yes) or 0(No) , answer to "release copay" question
+12 ;Output:
+13 ; 0 - cancel process
+14 ; ^ - emergency quit (cancel process)
+15 ; 1 - ok, can proceed
ASKQUEST(BPRELCOP,BPREAZ,BPCOMZ,BP90ANSZ,BPRCOPAZ) ;*/
+1 SET BPCOMZ=""
+2 SET BP90ANSZ=""
+3 SET BPRCOPAZ=0
+4 ;ask the user to choose the close reason from #356.8
+5 ;using set of close reasons in IB file 356.8
+6 SET BPREAZ=$$REASON()
+7 IF BPREAZ="^"
QUIT "^"
+8 ;if has ECME PAPER FLAG
IF ($PIECE(BPREAZ,U,4)=1)
Begin DoDot:1
+9 ;ask if the claim is still billable thru paper?
+10 SET BP90ANSZ=$$PROMPT^BPSSCRCV("S^N:NON-BILLABLE;D:DROP TO PAPER","Treat as (N)on-Billable Episode or (D)rop Bill to Paper?","")
End DoDot:1
+11 IF BP90ANSZ=-1
QUIT "^"
+12 SET BPCOMZ=$$COMMENT("Comment ",40)
+13 IF (BPCOMZ="^")
QUIT "^"
+14 IF $LENGTH(BPCOMZ)>0
IF BPCOMZ?1" "." "
SET BPCOMZ=""
+15 ;check copay
+16 ;ask "release copay?" in all NON-BILLABLE cases, i.e. except user answered "DROP TO PAPER"
+17 ;(even in cases when he was not asked about it)
+18 IF BP90ANSZ'="D"
IF BPRELCOP
Begin DoDot:1
+19 ; Ask user if s/he wants to release a copay
+20 SET BPRCOPAZ=$$YESNO^BPSSCRRS("Release Patient CoPay(Y/N)")
End DoDot:1
+21 IF BPRCOPAZ=-1
QUIT "^"
+22 ;
+23 SET BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)")
+24 ;quit by "^"
IF BPQ=-1
QUIT "^"
+25 ;doesn't want to proceed
IF BPQ'=1
QUIT 0
+26 ; answers can be used
QUIT 1
+27 ;
+28 ;/**
+29 ;ask for the close reason
+30 ;return:
+31 ; ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG ^ CODE ^ INACTIVE
+32 ;
+33 ; Allow the user to select an entry that has ECME FLAG set to 1 and INACTIVE flag not set to 1
REASON() ;
+1 NEW DIC,BPREASNM,BP3568,Y
+2 ; - Asks for REASON for Closing
+3 SET DIC="^IBE(356.8,"
SET DIC(0)="AEQMZ"
+4 SET DIC("S")="I ($P(^(0),U,2)=1),($P(^(0),U,5)'=1)"
+5 DO ^DIC
+6 IF Y=-1
QUIT "^"
+7 QUIT +Y_U_Y(0)
+8 ;/**
+9 ;enter the comment
+10 ;BPSTR -prompt string
+11 ;BPMLEN -maxlen
+1 NEW DIR,DTOUT,DUOUT,BPQ
+2 IF '$DATA(BPSTR)
SET BPSTR="Comment "
+3 IF '$DATA(BPMLEN)
SET BPMLEN=40
+4 SET DIR(0)="FO^0:250"
+5 SET DIR("A")=BPSTR
+6 SET DIR("?",1)="This response must have no more than "_BPMLEN_" characters"
+7 SET DIR("?")="and must not contain embedded up arrow."
+8 SET BPQ=0
+9 FOR
Begin DoDot:1
+10 DO ^DIR
+11 IF $DATA(DUOUT)!($DATA(DTOUT))
SET BPQ=-1
QUIT
+12 IF $LENGTH(Y)'>BPMLEN
SET BPQ=1
QUIT
+13 WRITE !!,"This response must have no more than "_BPMLEN_" characters"
+14 WRITE !,"and must not contain embedded uparrow.",!
+15 SET DIR("B")=$EXTRACT(Y,1,BPMLEN)
End DoDot:1
if +BPQ'=0
QUIT
+16 if BPQ<0
QUIT "^"
+17 QUIT Y
+18 ;/**
+19 ;close the claim
+20 ;the approach and code partially borrowed from IHS code CLOSE^BPSOS6N
+21 ;BPSTRA - ptr to #9002313.59
+22 ;REASON - text name of the close reason
+23 ;BPSCLCM - comment
+24 ;BPDROP:
+25 ; "D" - DROP BILL TO PAPER
+26 ; "N" - NON-BILLABLE
+27 ;BPRELCOP - 1 (Yes) or 0 (No) release copay or not?
CLOSEIT(BPSTRA,REASON,BPSCLCM,BPDROP,BPRELCOP) ;
+1 NEW BPSCLA,ERROR,DA,DR,BPLCK,DIE
+2 SET BPSCLA=$$GET1^DIQ(9002313.59,BPSTRA,3,"I")
+3 WRITE !,"Closing Claim ",$$GET1^DIQ(9002313.02,BPSCLA,.01),"..."
+4 SET BPLCK=0
+5 LOCK +^BPSC(BPSCLA):0
+6 IF $TEST
SET BPLCK=1
+7 IF '$TEST
WRITE !," *** CLAIM ",$$GET1^DIQ(9002313.02,BPSCLA,.01)," IN USE ***"
QUIT 0
+8 DO CLOSE^BPSBUTL(BPSCLA,BPSTRA,REASON,$SELECT($GET(BPDROP)="D":1,1:0),BPRELCOP,BPSCLCM,.ERROR,1)
+9 IF $DATA(ERROR)
WRITE "NOT OK"
DO DSPERR(ERROR)
Begin DoDot:1
+10 IF BPLCK=1
LOCK -^BPSC(BPSCLA)
End DoDot:1
QUIT 0
+11 SET DIE="^BPSC("
SET DA=BPSCLA
SET DR="901///1;902///"_$$NOW^XLFDT()_";903////"_DUZ_";904///"_REASON_";905////"_BPDROP
DO ^DIE
+12 IF BPLCK=1
LOCK -^BPSC(BPSCLA)
+13 HANG 1
WRITE "OK"
+14 QUIT 1
+15 ;
DSPERR(MSG) ; Display the ERROR message
+1 WRITE !,"Error: *** ",MSG," ***"
+2 QUIT
+3 ;
+4 ;/**
+5 ;ECME has tried to submit the claim to insurance with the name BPINSNAM
+6 ;but the claim was rejected and now we need to determine if the patient
+7 ;has any other insurance with pharmacy coverage that can be billed for the RX
+8 ;Input:
+9 ; BP59 - pointer to file #9002313.59
+10 ; BPINSNAM - insurance that have already been used by ECME
+11 ;Output:
+12 ; 0 - not found
+13 ; 1 ^ Insurance Name ^ Group Number ^ Date of service
NEXTINS(BP59,BPINSNAM) ;get insurance info by the pointer of #9002313.59
+1 NEW BPDOS,BPDFN,BPZZ,BP36,BPX,BPHONE,BPY,BPINSNM
+2 NEW BPPHARM,BPCOORD,BPINS,BPFOUND
+3 SET BPY=0
+4 SET BPHONE=$PIECE($GET(^BPST(BP59,10,+$GET(^BPST(BP59,9)),3)),U,2)
+5 SET BPDOS=+$PIECE($GET(^BPST(BP59,12)),U,2)\1
+6 IF BPDOS=0
SET BPDOS=+$PIECE($GET(^BPST(BP59,0)),U,8)\1
+7 SET BPDFN=+$PIECE($GET(^BPST(BP59,0)),U,6)
+8 ; call INSUR^IBBAPI to get information about:
+9 ;1 = Insurance Company Name
+10 ;7 = Coordination of Benefits (primary, secondary, tertiary)
+11 ;15 = Pharmacy Coverage?
+12 ;18 = Group Number
+13 SET BPX=$$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,7,15,18")
+14 SET BP1=""
FOR
SET BP1=$ORDER(BPZZ("IBBAPI","INSUR",BP1))
if +BP1=0
QUIT
Begin DoDot:1
+15 ;get pharmacy coverage
+16 SET BPPHARM=+$GET(BPZZ("IBBAPI","INSUR",BP1,15))
End DoDot:1
+17 IF BPX<1
QUIT 0
+18 DO PROCINS(.BPZZ)
+19 ;check pharmacy coverage
+20 ;if found will be set to insurance node in the INSUR^IBBAPI array
SET BPFOUND=0
+21 ;look only at those with pharmacy coverage
SET BPPHARM=1
+22 SET BPCOORD=0
+23 FOR
SET BPCOORD=+$ORDER(BPZZ("RES",BPPHARM,BPCOORD))
if BPCOORD=0!(BPFOUND'=0)
QUIT
Begin DoDot:1
+24 SET BPINS=+$ORDER(BPZZ("RES",BPPHARM,BPCOORD,0))
+25 IF BPINS>0
IF $PIECE($GET(BPZZ("IBBAPI","INSUR",BPINS,1)),U,2)'=BPINSNAM
SET BPFOUND=BPINS
End DoDot:1
+26 IF BPFOUND=0
QUIT 0
+27 QUIT 1_U_$PIECE($GET(BPZZ("IBBAPI","INSUR",BPFOUND,1)),U,2)_U_$PIECE($GET(BPZZ("IBBAPI","INSUR",BPFOUND,18)),U)_U_BPDOS
+28 ;
+29 ;process insurances
+30 ;input: local array returned by INSUR^IBBAPI
+31 ;output: BPZZ("RES",pharmacy coverage,coordination,insurance element # in BPZZ array)
PROCINS(BPZZ) ;
+1 NEW BP1,BP2,BP0,BPPHONE,BPPHARM,BPCOORD
+2 SET BP1=""
FOR
SET BP1=$ORDER(BPZZ("IBBAPI","INSUR",BP1))
if +BP1=0
QUIT
Begin DoDot:1
+3 ;get pharmacy coverage
+4 SET BPPHARM=+$GET(BPZZ("IBBAPI","INSUR",BP1,15))
+5 ;get coordination of benefits
+6 SET BPCOORD=+$GET(BPZZ("IBBAPI","INSUR",BP1,7))
+7 ;create ^TMP to sort results by pharmacy coverage and coordination of benefits
+8 SET BPZZ("RES",BPPHARM,BPCOORD,BP1)=""
End DoDot:1
+9 QUIT
