- BPSSCRU5 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
- ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10**;JUN 2004;Build 27
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;USER SCREEN
- Q
- ;
- DATETIME(Y) ;EP - convert fileman date.time to printable
- X ^DD("DD")
- Q Y
- ;
- ;create a history of claims and responses in #9002313.57 file
- ;record for the specified transaction in #9002313.59 file
- ;input:
- ; BP59 - ptr to #9002313.59
- ; BPHIST - array to return results
- ;output:
- ; Array in BPHIST with the format:
- ; BPHIST(type,timedate,PointerToResponseClaimFile)=PointerTo#9002313.57^request type
- ; where:
- ; request type - "C" - billing request, "R" - reversal request
- ; type "C" - BPS CLAIM file, "R" - BPS RESPONSE file
- ; PointerToResponseClaimFile - pointer to 9002313.03 or 9002313.02
- MKHIST(BP59,BPHIST) ;
- N BP57,BPLSTCLM,BPLSTRSP,BPDAT57,BP1,BPSSTDT
- S BP57=0
- N BPSARR02
- N BPSARR03
- ; -- process BPS LOG OF TRANSACTIONS file
- F S BP57=$O(^BPSTL("B",BP59,BP57)) Q:+BP57=0 D
- . ;claim transmissions
- . S BPDAT57(0)=$G(^BPSTL(BP57,0))
- . S BPSSTDT=+$P(BPDAT57(0),U,11) ;start time
- . S BPLSTCLM=+$P(BPDAT57(0),U,4) ;claim
- . I BPLSTCLM>0 D
- . . S BP1=+$P($G(^BPSC(BPLSTCLM,0)),U,5) ;transmitted on
- . . I BP1=0 S BP1=+$P($G(^BPSC(BPLSTCLM,0)),U,6) ;rec created on
- . . ;old BPS CLAIMS recs don't have dates, so use START TIME from .57 file but
- . . ;only at the very first time (using $D for this)
- . . I BP1=0 I '$D(BPSARR02(BPLSTCLM)) S (BPSARR02(BPLSTCLM))=BPSSTDT,BP1=BPSSTDT
- . . I BP1 I '$D(BPHIST("C",BP1,BPLSTCLM)) S BPHIST("C",BP1,BPLSTCLM)=BP57_U_"C"
- . S BPLSTRSP=+$P(BPDAT57(0),U,5) ;response
- . I BPLSTRSP>0 D
- . . S BP1=+$P($G(^BPSR(BPLSTRSP,0)),U,2) ;received on
- . . I BP1=0 I '$D(BPSARR03(BPLSTRSP)) S (BPSARR02(BPLSTCLM))=BPSSTDT,BP1=BPSSTDT
- . . I BP1 I '$D(BPHIST("R",BP1,BPLSTRSP)) S BPHIST("R",BP1,BPLSTRSP)=BP57_U_"C"
- . ;reversal transmissions
- . S BPDAT57(4)=$G(^BPSTL(BP57,4))
- . S BPLSTCLM=+$P(BPDAT57(4),U,1) ;reversal
- . I BPLSTCLM>0 D
- . . S BP1=+$P($G(^BPSC(BPLSTCLM,0)),U,5) ;transmitted on
- . . I BP1=0 S BP1=+$P($G(^BPSC(BPLSTCLM,0)),U,6) ;rec created on
- . . I BP1=0 I '$D(BPSARR02(BPLSTCLM)) S (BPSARR02(BPLSTCLM))=BPSSTDT,BP1=BPSSTDT
- . . I BP1 I '$D(BPHIST("C",BP1,BPLSTCLM)) S BPHIST("C",BP1,BPLSTCLM)=BP57_U_"R"
- . S BPLSTRSP=+$P(BPDAT57(4),U,2) ;reversal response
- . I BPLSTRSP>0 D
- . . S BP1=+$P($G(^BPSR(BPLSTRSP,0)),U,2) ;received on
- . . I BP1=0 I '$D(BPSARR03(BPLSTRSP)) S (BPSARR02(BPLSTCLM))=BPSSTDT,BP1=BPSSTDT
- . . I BP1 I '$D(BPHIST("R",BP1,BPLSTRSP)) S BPHIST("R",BP1,BPLSTRSP)=BP57_U_"R"
- ;--------
- ;sorting: pairs (send/respond) in reversed chronological order
- N BPCLDT1,BPCLIEN,BPRSDT1,BPRSIEN,BPCLDT2
- S BPCLDT1=0
- F S BPCLDT1=$O(BPHIST("C",BPCLDT1)) Q:BPCLDT1="" D
- . S BPCLIEN=$O(BPHIST("C",BPCLDT1,0)) Q:BPCLIEN="" D
- . . S BPCLDT2=+$O(BPHIST("C",BPCLDT1))
- . . I BPCLDT2=0 S BPCLDT2=9999999
- . . S BPRSDT1=BPCLDT1
- . . F S BPRSDT1=$O(BPHIST("R",BPRSDT1)) Q:BPRSDT1=""!(BPRSDT1>BPCLDT2) D
- . . . S BPRSIEN=$O(BPHIST("R",BPRSDT1,0)) Q:BPRSIEN="" D
- . . . . S BPHIST("C",BPCLDT1,BPCLIEN,"R",BPRSIEN)=BPHIST("R",BPRSDT1,BPRSIEN)
- ;
- Q
- ;returns text for the transaction code in file #9002313.02 -- BPS CLAIMS FILE
- TRTYPE(BPTRCD) ;
- I BPTRCD="E1" Q "Eligibility Verification"
- I BPTRCD="B1" Q "REQUEST" ;"Billing"
- I BPTRCD="B2" Q "REVERSAL" ; "Reversal"
- I BPTRCD="B3" Q "Rebill"
- I BPTRCD="P1" Q "P.A. Request & Billing"
- I BPTRCD="P2" Q "P.A. Reversal"
- I BPTRCD="P3" Q "P.A. Inquiry"
- I BPTRCD="P4" Q "P.A. Request Only"
- I BPTRCD="N1" Q "Information Reporting"
- I BPTRCD="N2" Q "Information Reporting Reversal"
- I BPTRCD="N3" Q "Information Reporting Rebill"
- I BPTRCD="C1" Q "Controlled Substance Reporting"
- I BPTRCD="C2" Q "Controlled Substance Reporting Reversal"
- I BPTRCD="C3" Q "Controlled Substance Reporting Rebill"
- Q ""
- ;
- ;get NDC for LOG
- ;BPIEN02 - IEN in #9002313.02 file
- LNDC(BPIEN02) ;
- N BPDAT02,BPNDC
- S BPDAT02(400)=$G(^BPSC(BPIEN02,400,1,400))
- S BPNDC=$E($P(BPDAT02(400),U,7),3,99)
- S BPNDC=$E(BPNDC,1,5)_"-"_$E(BPNDC,6,9)_"-"_$E(BPNDC,10,11)
- Q BPNDC
- ;prepares array of reject codes
- ; BPIEN03 - IEN in #9002313.03 file
- ; BPRCODES - array to return results
- REJCODES(BPIEN03,BPRCODES) ;
- N BPA,BPR
- S BPA=0
- F S BPA=$O(^BPSR(BPIEN03,1000,1,511,BPA)) Q:'BPA D
- . S BPR=$P(^BPSR(BPIEN03,1000,1,511,BPA,0),U)
- . I BPR'="" S BPRCODES(BPR)=""
- Q
- ;status of the response
- RESPSTAT(BPIEN03) ;
- N BP1
- S BP1=$P($G(^BPSR(BPIEN03,1000,1,110)),U,2)
- Q:BP1="A" "Approved"
- Q:BP1="C" "Captured"
- Q:BP1="D" "Duplicate of Paid"
- Q:BP1="F" "PA Deferred"
- Q:BP1="P" "Paid"
- Q:BP1="Q" "Duplicate of Capture"
- Q:BP1="R" "Rejected"
- Q:BP1="S" "Duplicate of Approved"
- Q ""
- ;
- ;Electronic payer - ptr to #9002313.92
- ;BPIEN02 - ptr in #9002313.02
- B1PYRIEN(BP57) ;
- N BPX,BPX2
- S BPX2=+$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,2)
- S BPX=$P($G(^BPSF(9002313.92,BPX2,0)),U)
- Q BPX
- ;
- ;BPIEN02 - ptr in #9002313.02
- B2PYRIEN(BP57) ;
- N BPX,BPX2
- S BPX2=+$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,3)
- S BPX=$P($G(^BPSF(9002313.92,BPX2,0)),U)
- Q BPX
- ;
- ;B3 payer sheet
- B3PYRIEN(BP57) ;
- N BPX,BPX2
- S BPX2=+$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,4)
- S BPX=$P($G(^BPSF(9002313.92,BPX2,0)),U)
- Q BPX
- ;
- ;
- ;BPLN= line to use in SETLINE
- ;BPX - long string to display
- ;BPMLEN - max length
- ;BPPREFX - prefix string
- ;BPMARG - left margin
- WRAPLN(BPLN,BPX,BPMLEN,BPPREFX,BPMARG) ;
- N BPQ,BPLEN,BPXX
- S BPQ=0
- S BPLEN=BPMLEN-$L(BPPREFX)
- S BPXX=$E(BPX,1,BPLEN)
- D SETLINE^BPSSCRLG(.BPLN,BPPREFX_BPXX)
- S BPX=$E(BPX,BPLEN+1,9999)
- I $L(BPX)<1 Q
- S BPLEN=BPMLEN-BPMARG
- F D Q:BPQ=1
- . S BPXX=$E(BPX,1,BPLEN)
- . D SETLINE^BPSSCRLG(.BPLN,$$SPACES(BPMARG)_BPXX)
- . S BPX=$E(BPX,BPLEN+1,9999)
- . I $L(BPX)<1 S BPQ=1
- Q
- ;
- ;to prepare spaces
- SPACES(BPN) ;
- N BPX
- S $P(BPX," ",BPN+1)=""
- Q BPX
- ;
- ;BPN= line counter (index)
- ;BPARR - array for lines
- ;BPX - long string to display
- ;BPMLEN - mas length
- ;BPPREFX - prefix string
- ;BPMARG - left margin
- WRAPLN2(BPN,BPARR,BPX,BPMLEN,BPPREFX,BPMARG) ;
- N BPQ,BPLEN,BPXX
- S BPQ=0
- S BPLEN=BPMLEN-$L(BPPREFX)
- S BPXX=$E(BPX,1,BPLEN)
- D SETLN(.BPN,.BPARR,BPPREFX_BPXX)
- S BPX=$E(BPX,BPLEN+1,9999)
- I $L(BPX)<1 Q
- S BPLEN=BPMLEN-BPMARG
- F D Q:BPQ=1
- . S BPXX=$E(BPX,1,BPLEN)
- . D SETLN(.BPN,.BPARR,$$SPACES(BPMARG)_BPXX)
- . S BPX=$E(BPX,BPLEN+1,9999)
- . I $L(BPX)<1 S BPQ=1
- Q
- ;
- ;
- SETLN(BPN,BPARR,BPTXT) ;
- S BPN=BPN+1,BPARR(BPN)=BPTXT
- Q
- ;---
- ;check 2nd insurance
- ;if there then ask user and print message
- CH2NDINS(BP59,BPPATNAM,BPINSNAM,BPRXINFO) ;
- N BPRETV
- S BPRETV=$$NEXTINS^BPSSCRCL(BP59,BPINSNAM)
- Q:+BPRETV=0
- D PRN(BPPATNAM,BPRETV,.BPRXINFO,"S")
- W !!
- I $$YESNO^BPSSCRRS("Do you want to print the information (above) concerning additional insurance? (Y/N)")'=1 Q
- D PRN(BPPATNAM,BPRETV,.BPRXINFO,"P")
- Q
- ;
- ;BPPRNFL
- ; S- print to screen
- PRN(BPPATNAM,BPRETV,BPRXINFO,BPPRNFL) ;
- I BPPRNFL="S" W @IOF D MS2NDINS Q
- D PRINT("MS2NDINS^BPSSCRU5","BPS 2ND INSURANCE INFO","BP*")
- W !!
- Q
- ;
- MS2NDINS ;
- N Y,Z
- W !,"This patient has ADDITIONAL insurance with Rx Coverage that may be"
- W !,"used to bill this claim. The system will change the CT entry to a"
- W !,"NON-BILLABLE Episode. If appropriate, please go to the ECME Pharmacy"
- W !,"COB menu and use the PRO - Process Secondary/TRICARE Rx to ECME"
- W !,"option to create an ePharmacy secondary claim."
- W !!,"Patient: ",?18,BPPATNAM
- S Y=$P(BPRETV,U,4)\1 D DD^%DT
- W !,"Date of service: ",?18,Y
- W !,"Insurance: ",?18,$P(BPRETV,U,2)
- W !,"Group number: ",?18,$P(BPRETV,U,3)
- S Z=0 F S Z=$O(BPRXINFO(Z)) Q:+Z=0 W !,BPRXINFO(Z)
- Q
- ;
- ;Prints report
- ;propmpts user to choose device (including queuing)
- ;TXTSRC - name of the report's entry point
- ;DESCR - description for the Task Manager
- ;SAVEVARS - mask for vars that need to be available in the report
- ; (exmpl: "BP*")
- PRINT(TXTSRC,DESCR,SAVEVARS) ;
- N Y,QUITVAR,SCRFLAG
- S (QUITVAR,SCRFLAG)=0
- D DEVICE Q:QUITVAR
- D @TXTSRC
- D ^%ZISC
- I QUITVAR W !,"Cancelled"
- Q
- ;
- DEVICE ;
- N DIR,DIRUT,POP
- N ZTRTN,ZTIO,ZTSAVE,ZTDESC,%ZIS
- K IO("Q") S %ZIS="QM"
- W ! D ^%ZIS
- I POP S QUITVAR=1 Q
- S SCRFLAG=$S($E($G(IOST),1,2)="C-":1,1:0)
- I $D(IO("Q")) D S QUITVAR=1
- . S ZTRTN=TXTSRC
- . S ZTIO=ION
- . S ZTSAVE(SAVEVARS)=""
- . S ZTDESC=DESCR
- . D ^%ZTLOAD
- . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
- . D HOME^%ZIS
- U IO
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSSCRU5 8603 printed Feb 18, 2025@23:19:46 Page 2
- BPSSCRU5 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
- +1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10**;JUN 2004;Build 27
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;USER SCREEN
- +4 QUIT
- +5 ;
- DATETIME(Y) ;EP - convert fileman date.time to printable
- +1 XECUTE ^DD("DD")
- +2 QUIT Y
- +3 ;
- +4 ;create a history of claims and responses in #9002313.57 file
- +5 ;record for the specified transaction in #9002313.59 file
- +6 ;input:
- +7 ; BP59 - ptr to #9002313.59
- +8 ; BPHIST - array to return results
- +9 ;output:
- +10 ; Array in BPHIST with the format:
- +11 ; BPHIST(type,timedate,PointerToResponseClaimFile)=PointerTo#9002313.57^request type
- +12 ; where:
- +13 ; request type - "C" - billing request, "R" - reversal request
- +14 ; type "C" - BPS CLAIM file, "R" - BPS RESPONSE file
- +15 ; PointerToResponseClaimFile - pointer to 9002313.03 or 9002313.02
- MKHIST(BP59,BPHIST) ;
- +1 NEW BP57,BPLSTCLM,BPLSTRSP,BPDAT57,BP1,BPSSTDT
- +2 SET BP57=0
- +3 NEW BPSARR02
- +4 NEW BPSARR03
- +5 ; -- process BPS LOG OF TRANSACTIONS file
- +6 FOR
- SET BP57=$ORDER(^BPSTL("B",BP59,BP57))
- if +BP57=0
- QUIT
- Begin DoDot:1
- +7 ;claim transmissions
- +8 SET BPDAT57(0)=$GET(^BPSTL(BP57,0))
- +9 ;start time
- SET BPSSTDT=+$PIECE(BPDAT57(0),U,11)
- +10 ;claim
- SET BPLSTCLM=+$PIECE(BPDAT57(0),U,4)
- +11 IF BPLSTCLM>0
- Begin DoDot:2
- +12 ;transmitted on
- SET BP1=+$PIECE($GET(^BPSC(BPLSTCLM,0)),U,5)
- +13 ;rec created on
- IF BP1=0
- SET BP1=+$PIECE($GET(^BPSC(BPLSTCLM,0)),U,6)
- +14 ;old BPS CLAIMS recs don't have dates, so use START TIME from .57 file but
- +15 ;only at the very first time (using $D for this)
- +16 IF BP1=0
- IF '$DATA(BPSARR02(BPLSTCLM))
- SET (BPSARR02(BPLSTCLM))=BPSSTDT
- SET BP1=BPSSTDT
- +17 IF BP1
- IF '$DATA(BPHIST("C",BP1,BPLSTCLM))
- SET BPHIST("C",BP1,BPLSTCLM)=BP57_U_"C"
- End DoDot:2
- +18 ;response
- SET BPLSTRSP=+$PIECE(BPDAT57(0),U,5)
- +19 IF BPLSTRSP>0
- Begin DoDot:2
- +20 ;received on
- SET BP1=+$PIECE($GET(^BPSR(BPLSTRSP,0)),U,2)
- +21 IF BP1=0
- IF '$DATA(BPSARR03(BPLSTRSP))
- SET (BPSARR02(BPLSTCLM))=BPSSTDT
- SET BP1=BPSSTDT
- +22 IF BP1
- IF '$DATA(BPHIST("R",BP1,BPLSTRSP))
- SET BPHIST("R",BP1,BPLSTRSP)=BP57_U_"C"
- End DoDot:2
- +23 ;reversal transmissions
- +24 SET BPDAT57(4)=$GET(^BPSTL(BP57,4))
- +25 ;reversal
- SET BPLSTCLM=+$PIECE(BPDAT57(4),U,1)
- +26 IF BPLSTCLM>0
- Begin DoDot:2
- +27 ;transmitted on
- SET BP1=+$PIECE($GET(^BPSC(BPLSTCLM,0)),U,5)
- +28 ;rec created on
- IF BP1=0
- SET BP1=+$PIECE($GET(^BPSC(BPLSTCLM,0)),U,6)
- +29 IF BP1=0
- IF '$DATA(BPSARR02(BPLSTCLM))
- SET (BPSARR02(BPLSTCLM))=BPSSTDT
- SET BP1=BPSSTDT
- +30 IF BP1
- IF '$DATA(BPHIST("C",BP1,BPLSTCLM))
- SET BPHIST("C",BP1,BPLSTCLM)=BP57_U_"R"
- End DoDot:2
- +31 ;reversal response
- SET BPLSTRSP=+$PIECE(BPDAT57(4),U,2)
- +32 IF BPLSTRSP>0
- Begin DoDot:2
- +33 ;received on
- SET BP1=+$PIECE($GET(^BPSR(BPLSTRSP,0)),U,2)
- +34 IF BP1=0
- IF '$DATA(BPSARR03(BPLSTRSP))
- SET (BPSARR02(BPLSTCLM))=BPSSTDT
- SET BP1=BPSSTDT
- +35 IF BP1
- IF '$DATA(BPHIST("R",BP1,BPLSTRSP))
- SET BPHIST("R",BP1,BPLSTRSP)=BP57_U_"R"
- End DoDot:2
- End DoDot:1
- +36 ;--------
- +37 ;sorting: pairs (send/respond) in reversed chronological order
- +38 NEW BPCLDT1,BPCLIEN,BPRSDT1,BPRSIEN,BPCLDT2
- +39 SET BPCLDT1=0
- +40 FOR
- SET BPCLDT1=$ORDER(BPHIST("C",BPCLDT1))
- if BPCLDT1=""
- QUIT
- Begin DoDot:1
- +41 SET BPCLIEN=$ORDER(BPHIST("C",BPCLDT1,0))
- if BPCLIEN=""
- QUIT
- Begin DoDot:2
- +42 SET BPCLDT2=+$ORDER(BPHIST("C",BPCLDT1))
- +43 IF BPCLDT2=0
- SET BPCLDT2=9999999
- +44 SET BPRSDT1=BPCLDT1
- +45 FOR
- SET BPRSDT1=$ORDER(BPHIST("R",BPRSDT1))
- if BPRSDT1=""!(BPRSDT1>BPCLDT2)
- QUIT
- Begin DoDot:3
- +46 SET BPRSIEN=$ORDER(BPHIST("R",BPRSDT1,0))
- if BPRSIEN=""
- QUIT
- Begin DoDot:4
- +47 SET BPHIST("C",BPCLDT1,BPCLIEN,"R",BPRSIEN)=BPHIST("R",BPRSDT1,BPRSIEN)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +48 ;
- +49 QUIT
- +50 ;returns text for the transaction code in file #9002313.02 -- BPS CLAIMS FILE
- TRTYPE(BPTRCD) ;
- +1 IF BPTRCD="E1"
- QUIT "Eligibility Verification"
- +2 ;"Billing"
- IF BPTRCD="B1"
- QUIT "REQUEST"
- +3 ; "Reversal"
- IF BPTRCD="B2"
- QUIT "REVERSAL"
- +4 IF BPTRCD="B3"
- QUIT "Rebill"
- +5 IF BPTRCD="P1"
- QUIT "P.A. Request & Billing"
- +6 IF BPTRCD="P2"
- QUIT "P.A. Reversal"
- +7 IF BPTRCD="P3"
- QUIT "P.A. Inquiry"
- +8 IF BPTRCD="P4"
- QUIT "P.A. Request Only"
- +9 IF BPTRCD="N1"
- QUIT "Information Reporting"
- +10 IF BPTRCD="N2"
- QUIT "Information Reporting Reversal"
- +11 IF BPTRCD="N3"
- QUIT "Information Reporting Rebill"
- +12 IF BPTRCD="C1"
- QUIT "Controlled Substance Reporting"
- +13 IF BPTRCD="C2"
- QUIT "Controlled Substance Reporting Reversal"
- +14 IF BPTRCD="C3"
- QUIT "Controlled Substance Reporting Rebill"
- +15 QUIT ""
- +16 ;
- +17 ;get NDC for LOG
- +18 ;BPIEN02 - IEN in #9002313.02 file
- LNDC(BPIEN02) ;
- +1 NEW BPDAT02,BPNDC
- +2 SET BPDAT02(400)=$GET(^BPSC(BPIEN02,400,1,400))
- +3 SET BPNDC=$EXTRACT($PIECE(BPDAT02(400),U,7),3,99)
- +4 SET BPNDC=$EXTRACT(BPNDC,1,5)_"-"_$EXTRACT(BPNDC,6,9)_"-"_$EXTRACT(BPNDC,10,11)
- +5 QUIT BPNDC
- +6 ;prepares array of reject codes
- +7 ; BPIEN03 - IEN in #9002313.03 file
- +8 ; BPRCODES - array to return results
- REJCODES(BPIEN03,BPRCODES) ;
- +1 NEW BPA,BPR
- +2 SET BPA=0
- +3 FOR
- SET BPA=$ORDER(^BPSR(BPIEN03,1000,1,511,BPA))
- if 'BPA
- QUIT
- Begin DoDot:1
- +4 SET BPR=$PIECE(^BPSR(BPIEN03,1000,1,511,BPA,0),U)
- +5 IF BPR'=""
- SET BPRCODES(BPR)=""
- End DoDot:1
- +6 QUIT
- +7 ;status of the response
- RESPSTAT(BPIEN03) ;
- +1 NEW BP1
- +2 SET BP1=$PIECE($GET(^BPSR(BPIEN03,1000,1,110)),U,2)
- +3 if BP1="A"
- QUIT "Approved"
- +4 if BP1="C"
- QUIT "Captured"
- +5 if BP1="D"
- QUIT "Duplicate of Paid"
- +6 if BP1="F"
- QUIT "PA Deferred"
- +7 if BP1="P"
- QUIT "Paid"
- +8 if BP1="Q"
- QUIT "Duplicate of Capture"
- +9 if BP1="R"
- QUIT "Rejected"
- +10 if BP1="S"
- QUIT "Duplicate of Approved"
- +11 QUIT ""
- +12 ;
- +13 ;Electronic payer - ptr to #9002313.92
- +14 ;BPIEN02 - ptr in #9002313.02
- B1PYRIEN(BP57) ;
- +1 NEW BPX,BPX2
- +2 SET BPX2=+$PIECE($GET(^BPSTL(BP57,10,+$GET(^BPSTL(BP57,9)),0)),U,2)
- +3 SET BPX=$PIECE($GET(^BPSF(9002313.92,BPX2,0)),U)
- +4 QUIT BPX
- +5 ;
- +6 ;BPIEN02 - ptr in #9002313.02
- B2PYRIEN(BP57) ;
- +1 NEW BPX,BPX2
- +2 SET BPX2=+$PIECE($GET(^BPSTL(BP57,10,+$GET(^BPSTL(BP57,9)),0)),U,3)
- +3 SET BPX=$PIECE($GET(^BPSF(9002313.92,BPX2,0)),U)
- +4 QUIT BPX
- +5 ;
- +6 ;B3 payer sheet
- B3PYRIEN(BP57) ;
- +1 NEW BPX,BPX2
- +2 SET BPX2=+$PIECE($GET(^BPSTL(BP57,10,+$GET(^BPSTL(BP57,9)),0)),U,4)
- +3 SET BPX=$PIECE($GET(^BPSF(9002313.92,BPX2,0)),U)
- +4 QUIT BPX
- +5 ;
- +6 ;
- +7 ;BPLN= line to use in SETLINE
- +8 ;BPX - long string to display
- +9 ;BPMLEN - max length
- +10 ;BPPREFX - prefix string
- +11 ;BPMARG - left margin
- WRAPLN(BPLN,BPX,BPMLEN,BPPREFX,BPMARG) ;
- +1 NEW BPQ,BPLEN,BPXX
- +2 SET BPQ=0
- +3 SET BPLEN=BPMLEN-$LENGTH(BPPREFX)
- +4 SET BPXX=$EXTRACT(BPX,1,BPLEN)
- +5 DO SETLINE^BPSSCRLG(.BPLN,BPPREFX_BPXX)
- +6 SET BPX=$EXTRACT(BPX,BPLEN+1,9999)
- +7 IF $LENGTH(BPX)<1
- QUIT
- +8 SET BPLEN=BPMLEN-BPMARG
- +9 FOR
- Begin DoDot:1
- +10 SET BPXX=$EXTRACT(BPX,1,BPLEN)
- +11 DO SETLINE^BPSSCRLG(.BPLN,$$SPACES(BPMARG)_BPXX)
- +12 SET BPX=$EXTRACT(BPX,BPLEN+1,9999)
- +13 IF $LENGTH(BPX)<1
- SET BPQ=1
- End DoDot:1
- if BPQ=1
- QUIT
- +14 QUIT
- +15 ;
- +16 ;to prepare spaces
- SPACES(BPN) ;
- +1 NEW BPX
- +2 SET $PIECE(BPX," ",BPN+1)=""
- +3 QUIT BPX
- +4 ;
- +5 ;BPN= line counter (index)
- +6 ;BPARR - array for lines
- +7 ;BPX - long string to display
- +8 ;BPMLEN - mas length
- +9 ;BPPREFX - prefix string
- +10 ;BPMARG - left margin
- WRAPLN2(BPN,BPARR,BPX,BPMLEN,BPPREFX,BPMARG) ;
- +1 NEW BPQ,BPLEN,BPXX
- +2 SET BPQ=0
- +3 SET BPLEN=BPMLEN-$LENGTH(BPPREFX)
- +4 SET BPXX=$EXTRACT(BPX,1,BPLEN)
- +5 DO SETLN(.BPN,.BPARR,BPPREFX_BPXX)
- +6 SET BPX=$EXTRACT(BPX,BPLEN+1,9999)
- +7 IF $LENGTH(BPX)<1
- QUIT
- +8 SET BPLEN=BPMLEN-BPMARG
- +9 FOR
- Begin DoDot:1
- +10 SET BPXX=$EXTRACT(BPX,1,BPLEN)
- +11 DO SETLN(.BPN,.BPARR,$$SPACES(BPMARG)_BPXX)
- +12 SET BPX=$EXTRACT(BPX,BPLEN+1,9999)
- +13 IF $LENGTH(BPX)<1
- SET BPQ=1
- End DoDot:1
- if BPQ=1
- QUIT
- +14 QUIT
- +15 ;
- +16 ;
- SETLN(BPN,BPARR,BPTXT) ;
- +1 SET BPN=BPN+1
- SET BPARR(BPN)=BPTXT
- +2 QUIT
- +3 ;---
- +4 ;check 2nd insurance
- +5 ;if there then ask user and print message
- CH2NDINS(BP59,BPPATNAM,BPINSNAM,BPRXINFO) ;
- +1 NEW BPRETV
- +2 SET BPRETV=$$NEXTINS^BPSSCRCL(BP59,BPINSNAM)
- +3 if +BPRETV=0
- QUIT
- +4 DO PRN(BPPATNAM,BPRETV,.BPRXINFO,"S")
- +5 WRITE !!
- +6 IF $$YESNO^BPSSCRRS("Do you want to print the information (above) concerning additional insurance? (Y/N)")'=1
- QUIT
- +7 DO PRN(BPPATNAM,BPRETV,.BPRXINFO,"P")
- +8 QUIT
- +9 ;
- +10 ;BPPRNFL
- +11 ; S- print to screen
- PRN(BPPATNAM,BPRETV,BPRXINFO,BPPRNFL) ;
- +1 IF BPPRNFL="S"
- WRITE @IOF
- DO MS2NDINS
- QUIT
- +2 DO PRINT("MS2NDINS^BPSSCRU5","BPS 2ND INSURANCE INFO","BP*")
- +3 WRITE !!
- +4 QUIT
- +5 ;
- MS2NDINS ;
- +1 NEW Y,Z
- +2 WRITE !,"This patient has ADDITIONAL insurance with Rx Coverage that may be"
- +3 WRITE !,"used to bill this claim. The system will change the CT entry to a"
- +4 WRITE !,"NON-BILLABLE Episode. If appropriate, please go to the ECME Pharmacy"
- +5 WRITE !,"COB menu and use the PRO - Process Secondary/TRICARE Rx to ECME"
- +6 WRITE !,"option to create an ePharmacy secondary claim."
- +7 WRITE !!,"Patient: ",?18,BPPATNAM
- +8 SET Y=$PIECE(BPRETV,U,4)\1
- DO DD^%DT
- +9 WRITE !,"Date of service: ",?18,Y
- +10 WRITE !,"Insurance: ",?18,$PIECE(BPRETV,U,2)
- +11 WRITE !,"Group number: ",?18,$PIECE(BPRETV,U,3)
- +12 SET Z=0
- FOR
- SET Z=$ORDER(BPRXINFO(Z))
- if +Z=0
- QUIT
- WRITE !,BPRXINFO(Z)
- +13 QUIT
- +14 ;
- +15 ;Prints report
- +16 ;propmpts user to choose device (including queuing)
- +17 ;TXTSRC - name of the report's entry point
- +18 ;DESCR - description for the Task Manager
- +19 ;SAVEVARS - mask for vars that need to be available in the report
- +20 ; (exmpl: "BP*")
- PRINT(TXTSRC,DESCR,SAVEVARS) ;
- +1 NEW Y,QUITVAR,SCRFLAG
- +2 SET (QUITVAR,SCRFLAG)=0
- +3 DO DEVICE
- if QUITVAR
- QUIT
- +4 DO @TXTSRC
- +5 DO ^%ZISC
- +6 IF QUITVAR
- WRITE !,"Cancelled"
- +7 QUIT
- +8 ;
- DEVICE ;
- +1 NEW DIR,DIRUT,POP
- +2 NEW ZTRTN,ZTIO,ZTSAVE,ZTDESC,%ZIS
- +3 KILL IO("Q")
- SET %ZIS="QM"
- +4 WRITE !
- DO ^%ZIS
- +5 IF POP
- SET QUITVAR=1
- QUIT
- +6 SET SCRFLAG=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
- +7 IF $DATA(IO("Q"))
- Begin DoDot:1
- +8 SET ZTRTN=TXTSRC
- +9 SET ZTIO=ION
- +10 SET ZTSAVE(SAVEVARS)=""
- +11 SET ZTDESC=DESCR
- +12 DO ^%ZTLOAD
- +13 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
- +14 DO HOME^%ZIS
- End DoDot:1
- SET QUITVAR=1
- +15 USE IO
- +16 QUIT
- +17 ;