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 Dec 13, 2024@01:53:23 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 ;
