BPSSCRU3 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,9,10,20,21**;JUN 2004;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;USER SCREEN
Q
;get comment from BPS TRANSACTION file
;BP59 - ien in that file
N BPCMNT,BPX,BPTXT
S BPCMNT=$O(^BPST(BP59,11,999999),-1)
I BPCMNT="" Q ""
S BPX=$G(^BPST(BP59,11,BPCMNT,0))
; If the date/time of the comment is earlier than the date/time of
; the Submit Date, then do not display the comment (BPS*1*21)
I $P(BPX,U,1)<$P($G(^BPST(BP59,0)),U,7) Q "Prior comments suppressed-use CMT action for all comments"
S BPTXT=$P(BPX,U,3) I $L(BPTXT)>60 S BPTXT=$S(+$P(BPX,U,4):$E(BPTXT,1,50)_"...",1:$E(BPTXT,1,58)_"...")
Q $$DATTIM($P(BPX,U,1)\1)_$S(+$P(BPX,U,4):" (Pharm)",1:"")_" - "_BPTXT_U_$$USERNAM^BPSCMT01($P(BPX,U,2))
;
DATTIM(X) ;Convert FM date to displayable (mm/dd/yy HH:MM) format.
I +X=0 W ""
N DATE,YR,BPT,BPM,BPH,BPAP
I $G(X) S YR=$E(X,2,3)
I $G(X) S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_YR,1:"")
S BPT=$P(X,".",2) S:$L(BPT)<4 BPT=BPT_$E("0000",1,4-$L(BPT))
S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4)
S BPAP="a" I BPH>12 S BPH=BPH-12,BPAP="p" S:$L(BPH)<2 BPH="0"_BPH
I BPT S:'BPH BPH=12 S DATE=DATE_" "_BPH_":"_BPM_BPAP
Q $G(DATE)
;/**
;a wrapper for $$STATUS^BPSOSRX to get the status by BPS TRANSACTION pointer
;input BP59 - ptr to 9002313.59
;output - pieces 1,2 and 3 of the $$STATUS^BPSOSRX output
; example: "E REVERSAL ACCEPTED^3071206.152829^Reversal Accepted"
CLAIMST(BP59) ;*/
N BPX,BPSTATUS,BPREF,BPSCHED
N BPCOB S BPCOB=$$COB59^BPSUTIL2(BP59)
S BPSCHED=0
S BPX=$$RXREF^BPSSCRU2(BP59)
S BPREF=$P(BPX,U,2)
S BPSTATUS=$$STATUS^BPSOSRX(+BPX,BPREF,,,BPCOB)
;if the request completed (99%) and there is another active (scheduled, activated,
;in process,completed but not inactivated yet) request then return IN PROGRESS
I $P(BPSTATUS,U,4)=99,$$ACTREQS^BPSOSRX6(+BPX,BPREF,BPCOB) S BPSCHED=1
I BPSCHED I ($P(BPSTATUS,U)="E PAYABLE")!($P(BPSTATUS,U)="E REVERSAL ACCEPTED") Q "IN PROGRESS"_U_$P(BPSTATUS,U,2)
Q $P(BPSTATUS,U,1,3)
;
;/**
;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
;B59 - ptr to #9002313.59
;BPRESP - ptr to #9002313.03
;BPPOS - position inside #9002313.03 (i.e. the number
;of the claim in the transmission - currently we always have only 1
GRESPPOS(BP59,BPRESP,BPPOS) ;*/
I $G(^BPST(BP59,4)) D ; reversal kind of message
. S BPRESP=+$P(^BPST(BP59,4),U,2)
. S BPPOS=1
E D
. S BPRESP=+$P($G(^BPST(BP59,0)),U,5)
. S BPPOS=+$P($G(^BPST(BP59,0)),U,9)
Q:+BPRESP=0 0
Q:+BPPOS=0 0
Q 1
;
;/**
;Messages from the BPS RESPONSE file
;BP59 - ptr to 9002313.59
;FIELD - what field to get
;
GETMESS(FIELD,BP59) ;
I '$G(FIELD) Q ""
I '$G(BP59) Q ""
N BPRESP,BPPOS
; Get response and position in the BPS RESPONSE file
I $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0 Q ""
; 504-F4 (Message)
I FIELD=504 Q $P($G(^BPSR(BPRESP,504)),U)
; 526-FQ (Additional Message Information) - Get first entry of the multiple)
I FIELD=526 N MESSAGE,N D Q MESSAGE
. N ADDMESS
. D ADDMESS^BPSSCRLG(BPRESP,BPPOS,.ADDMESS)
. S MESSAGE=""
. S N=$O(ADDMESS(""))
. I N S MESSAGE=$E(ADDMESS(N),1,200)
Q ""
;
;reject message from RESPONSE file
;BP59 - ptr to 9002313.59
;BPARR1 - array to return messages (by ref)
;BPN1 - index for the array (by ref - will
; be incremented if more than one node added)
;BPMLEN - max length for each string
;PBPREF - for prefix string
;compare GETRJCOD from BPSSCRU2
GETRJCOD(BP59,BPARR1,BPN1,BPMLEN,PBPREF) ;
N BP59DAT S BP59DAT=$G(^BPST(BP59,0))
N BPRESP,BPPOS
N BPRJCOD
N BPRJTXT
N BPSTR
N BPRJ
;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
;get response and position
I $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0 Q
S BPRJ=0
S BPSTR=""
F S BPRJ=$O(^BPSR(BPRESP,1000,BPPOS,511,BPRJ)) Q:+BPRJ=0 D
. S BPRJCOD=$P($G(^BPSR(BPRESP,1000,BPPOS,511,BPRJ,0)),U)
. Q:$L(BPRJCOD)=0
. S BPRJTXT=$$GETRJNAM(BPRJCOD)
. S BPN1=BPN1+1,BPARR1(BPN1)=PBPREF_BPRJTXT
Q BPN1
;/**
;Input:
; BP59 - pointer to file #9002313.59
; BPSNBR - flag to determine if eT/eC pseudo-reject codes should also be returned for non-billable entries
; default is to NOT include them (leave parameter blank)
;Output:
; BPRCODES - array for reject codes by reference
REJCODES(BP59,BPRCODES,BPSNBR) ;get reject codes
N BPRESP,BPPOS,BPA,BPR
;
; get TRI/CVA non-billable pseudo-reject codes if the flag is set and the entry is non-billable (BPS*1*20)
I $G(BPSNBR),$$NB^BPSSCR03(BP59) D
. S BPR=$E($$EREJTXT^BPSSCR03(BP59),1,2) ; get the eT or eC pseudo-reject code
. I BPR'="" S BPRCODES(BPR)=""
. Q
;
;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
;get response and position
I $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0 Q
;
S BPA=0
F S BPA=$O(^BPSR(BPRESP,1000,BPPOS,511,BPA)) Q:'BPA D
. S BPR=$P(^BPSR(BPRESP,1000,BPPOS,511,BPA,0),U)
. I BPR'="" S BPRCODES(BPR)=""
Q
;/**
;BPRJCODE - code
GETRJNAM(BPRJCODE) ;*/
N BPRJIEN
S BPRJIEN=$O(^BPSF(9002313.93,"B",BPRJCODE,0))
Q:+BPRJIEN=0 ""
Q BPRJCODE_":"_$P($G(^BPSF(9002313.93,BPRJIEN,0)),U,2)
;/**
;BP59 - ptr to 9002313.59
;was the claim ever autoreversed ?
AUTOREV(BP59) ;*/
N BP02
S BP02=+$P($G(^BPST(BP59,0)),U,4)
Q +$P($G(^BPSC(BP02,0)),U,7)
;
;/**
;BP59 - ptr to 9002313.59
;returns :
;0 Waiting to start
;10 Gathering claim info
;19 Special Grouping
;30 Waiting for packet build
;31 Wait for retry (insurer asleep)
;40 Packet being built
;50 Waiting for transmit
;51 Wait for retry (comms error)
;60 Transmitting
;70 Receiving Response
;80 Waiting to process response
;90 Processing response
;99 Done
;
PRCNTG(BP59) ;*/
Q +$P($G(^BPST(BP59,0)),U,2)
;
;
LINE(BPN,BPCH) ;
N BP1
S $P(BP1,BPCH,BPN+1)=""
Q BP1
;
DTTIME(X) ;Convert FM date to displayable (mm/dd/yy HH:MM) format.
I +X=0 W ""
N DATE,YR,BPT,BPM,BPH,BPAP,BPS
I $G(X) S YR=$E(X,1,3)+1700
I $G(X) S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_YR,1:"")
S BPT=$P(X,".",2)
I BPT S:$L(BPT)<6 BPT=BPT_$E("000000",1,6-$L(BPT))
S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4),BPS=$E(BPT,5,6)
I BPT S DATE=DATE_"@"_BPH_":"_BPM_":"_BPS
Q $G(DATE)
;
;call IB API to get insurance data, then select proper insurance by its name
;get its phone number
;input:
; DFN - patient IEN in #2
; BPDOS - date of service
; BPINSNM - insurance name
;output: insurance ien^insurance name^phone
GETPHONE(BPDFN,BPDOS,BPINSNM) ;
N BPX,BPZZ,BP1,BPPHONE
S BPPHONE=""
I $$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,6")'=1 Q ""
S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D
. I BPINSNM=$P($G(BPZZ("IBBAPI","INSUR",BP1,1)),U,2) S BPPHONE=$G(BPZZ("IBBAPI","INSUR",BP1,6)) Q
Q BPPHONE
;
;try to get insurance name and phone from #9002313.59, #9002313.57 and from INSUR^IBBAPI
;input: BP59 - ien in #9002313.59
;return insurance_name^phone#
NAMEPHON(BP59) ;
N BPHONE,BPINSNM,BPINSID,BP57,BPINSN
S BPHONE=$P($G(^BPST(BP59,10,+$G(^BPST(BP59,9)),3)),U,2)
S BPINSNM=$P($G(^BPST(BP59,10,+$G(^BPST(BP59,9)),0)),U,7)
S BP57=0
F Q:(BPHONE'="")&(BPINSNM'="") S BP57=$O(^BPSTL("B",BP59,BP57)) Q:+BP57=0 D
. S BPINSN=+$G(^BPSTL(BP57,9))
. S:BPHONE="" BPHONE=$P($G(^BPSTL(BP57,10,BPINSN,3)),U,2)
. S:BPINSNM="" BPINSNM=$P($G(^BPSTL(BP57,10,BPINSN,0)),U,7)
;
I (BPINSNM'="")&(BPHONE="") D
. 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)
. S BPHONE=$$GETPHONE(BPDFN,BPDOS,BPINSNM)
Q BPINSNM_U_BPHONE
;
COM(BPSRXI,BPSRXR,BPSCOB,BPSARRAY) ; Get Comments
; This API retrieves comments for pharmacist from BPS Transaction.
;
; Input: BPSRXI - Prescription IEN (Pointer to the PRESCRIPTION
; file (#52). This parameter is required.
; BPSRXR - Fill Number (0 for original, 1 for 1st refill,
; 2 for the 2nd refill, etc.). If this parameter
; is missing, it will default to zero.
; BPSCOB - Coordination of Benefit value (1-Primary,
; 2-Secondary, 3-Tertiary). If not passed in,
; primary is assumed.
;
; Output: BPSARRAY - Return array of data in the format of:
; Array Name(Transaction Date,Count Index)=Pharmacy Flag ^
; Comment ^ User entering comment
;
N BP59,BPSI,BPSCNT,BPSPFLG,BPSDATE,BPSUSER,BPSCOM,BPSX
;
I '$G(BPSRXI) Q
;
; Note that $$IEN59^BPSOSRX will treat BPSRXR="" as the original
; fill (0) and BPSCOB="" as primary (1)
S BP59=$$IEN59^BPSOSRX(BPSRXI,$G(BPSRXR),$G(BPSCOB))
I '$D(^BPST(BP59,0)) Q
;
S (BPSI,BPSCNT)=0
F S BPSI=$O(^BPST(BP59,11,BPSI)) Q:'BPSI D
.S BPSPFLG=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.04,"I")
.S BPSDATE=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.01,"I")
.S BPSUSER=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.02,"I")
.S BPSCOM=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.03)
.;
.S BPSX=BPSPFLG_"^"_BPSCOM_"^"_BPSUSER
.S BPSCNT=BPSCNT+1
.S BPSARRAY(BPSDATE,BPSCNT)=BPSX
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSSCRU3 9259 printed Dec 13, 2024@01:53:21 Page 2
BPSSCRU3 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,9,10,20,21**;JUN 2004;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;USER SCREEN
+4 QUIT
+5 ;get comment from BPS TRANSACTION file
+6 ;BP59 - ien in that file
+1 NEW BPCMNT,BPX,BPTXT
+2 SET BPCMNT=$ORDER(^BPST(BP59,11,999999),-1)
+3 IF BPCMNT=""
QUIT ""
+4 SET BPX=$GET(^BPST(BP59,11,BPCMNT,0))
+5 ; If the date/time of the comment is earlier than the date/time of
+6 ; the Submit Date, then do not display the comment (BPS*1*21)
+7 IF $PIECE(BPX,U,1)<$PIECE($GET(^BPST(BP59,0)),U,7)
QUIT "Prior comments suppressed-use CMT action for all comments"
+8 SET BPTXT=$PIECE(BPX,U,3)
IF $LENGTH(BPTXT)>60
SET BPTXT=$SELECT(+$PIECE(BPX,U,4):$EXTRACT(BPTXT,1,50)_"...",1:$EXTRACT(BPTXT,1,58)_"...")
+9 QUIT $$DATTIM($PIECE(BPX,U,1)\1)_$SELECT(+$PIECE(BPX,U,4):" (Pharm)",1:"")_" - "_BPTXT_U_$$USERNAM^BPSCMT01($PIECE(BPX,U,2))
+10 ;
DATTIM(X) ;Convert FM date to displayable (mm/dd/yy HH:MM) format.
+1 IF +X=0
WRITE ""
+2 NEW DATE,YR,BPT,BPM,BPH,BPAP
+3 IF $GET(X)
SET YR=$EXTRACT(X,2,3)
+4 IF $GET(X)
SET DATE=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_YR,1:"")
+5 SET BPT=$PIECE(X,".",2)
if $LENGTH(BPT)<4
SET BPT=BPT_$EXTRACT("0000",1,4-$LENGTH(BPT))
+6 SET BPH=$EXTRACT(BPT,1,2)
SET BPM=$EXTRACT(BPT,3,4)
+7 SET BPAP="a"
IF BPH>12
SET BPH=BPH-12
SET BPAP="p"
if $LENGTH(BPH)<2
SET BPH="0"_BPH
+8 IF BPT
if 'BPH
SET BPH=12
SET DATE=DATE_" "_BPH_":"_BPM_BPAP
+9 QUIT $GET(DATE)
+10 ;/**
+11 ;a wrapper for $$STATUS^BPSOSRX to get the status by BPS TRANSACTION pointer
+12 ;input BP59 - ptr to 9002313.59
+13 ;output - pieces 1,2 and 3 of the $$STATUS^BPSOSRX output
+14 ; example: "E REVERSAL ACCEPTED^3071206.152829^Reversal Accepted"
CLAIMST(BP59) ;*/
+1 NEW BPX,BPSTATUS,BPREF,BPSCHED
+2 NEW BPCOB
SET BPCOB=$$COB59^BPSUTIL2(BP59)
+3 SET BPSCHED=0
+4 SET BPX=$$RXREF^BPSSCRU2(BP59)
+5 SET BPREF=$PIECE(BPX,U,2)
+6 SET BPSTATUS=$$STATUS^BPSOSRX(+BPX,BPREF,,,BPCOB)
+7 ;if the request completed (99%) and there is another active (scheduled, activated,
+8 ;in process,completed but not inactivated yet) request then return IN PROGRESS
+9 IF $PIECE(BPSTATUS,U,4)=99
IF $$ACTREQS^BPSOSRX6(+BPX,BPREF,BPCOB)
SET BPSCHED=1
+10 IF BPSCHED
IF ($PIECE(BPSTATUS,U)="E PAYABLE")!($PIECE(BPSTATUS,U)="E REVERSAL ACCEPTED")
QUIT "IN PROGRESS"_U_$PIECE(BPSTATUS,U,2)
+11 QUIT $PIECE(BPSTATUS,U,1,3)
+12 ;
+13 ;/**
+14 ;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
+15 ;B59 - ptr to #9002313.59
+16 ;BPRESP - ptr to #9002313.03
+17 ;BPPOS - position inside #9002313.03 (i.e. the number
+18 ;of the claim in the transmission - currently we always have only 1
GRESPPOS(BP59,BPRESP,BPPOS) ;*/
+1 ; reversal kind of message
IF $GET(^BPST(BP59,4))
Begin DoDot:1
+2 SET BPRESP=+$PIECE(^BPST(BP59,4),U,2)
+3 SET BPPOS=1
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET BPRESP=+$PIECE($GET(^BPST(BP59,0)),U,5)
+6 SET BPPOS=+$PIECE($GET(^BPST(BP59,0)),U,9)
End DoDot:1
+7 if +BPRESP=0
QUIT 0
+8 if +BPPOS=0
QUIT 0
+9 QUIT 1
+10 ;
+11 ;/**
+12 ;Messages from the BPS RESPONSE file
+13 ;BP59 - ptr to 9002313.59
+14 ;FIELD - what field to get
+15 ;
GETMESS(FIELD,BP59) ;
+1 IF '$GET(FIELD)
QUIT ""
+2 IF '$GET(BP59)
QUIT ""
+3 NEW BPRESP,BPPOS
+4 ; Get response and position in the BPS RESPONSE file
+5 IF $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0
QUIT ""
+6 ; 504-F4 (Message)
+7 IF FIELD=504
QUIT $PIECE($GET(^BPSR(BPRESP,504)),U)
+8 ; 526-FQ (Additional Message Information) - Get first entry of the multiple)
+9 IF FIELD=526
NEW MESSAGE,N
Begin DoDot:1
+10 NEW ADDMESS
+11 DO ADDMESS^BPSSCRLG(BPRESP,BPPOS,.ADDMESS)
+12 SET MESSAGE=""
+13 SET N=$ORDER(ADDMESS(""))
+14 IF N
SET MESSAGE=$EXTRACT(ADDMESS(N),1,200)
End DoDot:1
QUIT MESSAGE
+15 QUIT ""
+16 ;
+17 ;reject message from RESPONSE file
+18 ;BP59 - ptr to 9002313.59
+19 ;BPARR1 - array to return messages (by ref)
+20 ;BPN1 - index for the array (by ref - will
+21 ; be incremented if more than one node added)
+22 ;BPMLEN - max length for each string
+23 ;PBPREF - for prefix string
+24 ;compare GETRJCOD from BPSSCRU2
GETRJCOD(BP59,BPARR1,BPN1,BPMLEN,PBPREF) ;
+1 NEW BP59DAT
SET BP59DAT=$GET(^BPST(BP59,0))
+2 NEW BPRESP,BPPOS
+3 NEW BPRJCOD
+4 NEW BPRJTXT
+5 NEW BPSTR
+6 NEW BPRJ
+7 ;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
+8 ;get response and position
+9 IF $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0
QUIT
+10 SET BPRJ=0
+11 SET BPSTR=""
+12 FOR
SET BPRJ=$ORDER(^BPSR(BPRESP,1000,BPPOS,511,BPRJ))
if +BPRJ=0
QUIT
Begin DoDot:1
+13 SET BPRJCOD=$PIECE($GET(^BPSR(BPRESP,1000,BPPOS,511,BPRJ,0)),U)
+14 if $LENGTH(BPRJCOD)=0
QUIT
+15 SET BPRJTXT=$$GETRJNAM(BPRJCOD)
+16 SET BPN1=BPN1+1
SET BPARR1(BPN1)=PBPREF_BPRJTXT
End DoDot:1
+17 QUIT BPN1
+18 ;/**
+19 ;Input:
+20 ; BP59 - pointer to file #9002313.59
+21 ; BPSNBR - flag to determine if eT/eC pseudo-reject codes should also be returned for non-billable entries
+22 ; default is to NOT include them (leave parameter blank)
+23 ;Output:
+24 ; BPRCODES - array for reject codes by reference
REJCODES(BP59,BPRCODES,BPSNBR) ;get reject codes
+1 NEW BPRESP,BPPOS,BPA,BPR
+2 ;
+3 ; get TRI/CVA non-billable pseudo-reject codes if the flag is set and the entry is non-billable (BPS*1*20)
+4 IF $GET(BPSNBR)
IF $$NB^BPSSCR03(BP59)
Begin DoDot:1
+5 ; get the eT or eC pseudo-reject code
SET BPR=$EXTRACT($$EREJTXT^BPSSCR03(BP59),1,2)
+6 IF BPR'=""
SET BPRCODES(BPR)=""
+7 QUIT
End DoDot:1
+8 ;
+9 ;pointers for RESPONSE file (#9002313.03) by pointer in TRANSACTION file #9002313.59
+10 ;get response and position
+11 IF $$GRESPPOS(BP59,.BPRESP,.BPPOS)=0
QUIT
+12 ;
+13 SET BPA=0
+14 FOR
SET BPA=$ORDER(^BPSR(BPRESP,1000,BPPOS,511,BPA))
if 'BPA
QUIT
Begin DoDot:1
+15 SET BPR=$PIECE(^BPSR(BPRESP,1000,BPPOS,511,BPA,0),U)
+16 IF BPR'=""
SET BPRCODES(BPR)=""
End DoDot:1
+17 QUIT
+18 ;/**
+19 ;BPRJCODE - code
GETRJNAM(BPRJCODE) ;*/
+1 NEW BPRJIEN
+2 SET BPRJIEN=$ORDER(^BPSF(9002313.93,"B",BPRJCODE,0))
+3 if +BPRJIEN=0
QUIT ""
+4 QUIT BPRJCODE_":"_$PIECE($GET(^BPSF(9002313.93,BPRJIEN,0)),U,2)
+5 ;/**
+6 ;BP59 - ptr to 9002313.59
+7 ;was the claim ever autoreversed ?
AUTOREV(BP59) ;*/
+1 NEW BP02
+2 SET BP02=+$PIECE($GET(^BPST(BP59,0)),U,4)
+3 QUIT +$PIECE($GET(^BPSC(BP02,0)),U,7)
+4 ;
+5 ;/**
+6 ;BP59 - ptr to 9002313.59
+7 ;returns :
+8 ;0 Waiting to start
+9 ;10 Gathering claim info
+10 ;19 Special Grouping
+11 ;30 Waiting for packet build
+12 ;31 Wait for retry (insurer asleep)
+13 ;40 Packet being built
+14 ;50 Waiting for transmit
+15 ;51 Wait for retry (comms error)
+16 ;60 Transmitting
+17 ;70 Receiving Response
+18 ;80 Waiting to process response
+19 ;90 Processing response
+20 ;99 Done
+21 ;
PRCNTG(BP59) ;*/
+1 QUIT +$PIECE($GET(^BPST(BP59,0)),U,2)
+2 ;
+3 ;
LINE(BPN,BPCH) ;
+1 NEW BP1
+2 SET $PIECE(BP1,BPCH,BPN+1)=""
+3 QUIT BP1
+4 ;
DTTIME(X) ;Convert FM date to displayable (mm/dd/yy HH:MM) format.
+1 IF +X=0
WRITE ""
+2 NEW DATE,YR,BPT,BPM,BPH,BPAP,BPS
+3 IF $GET(X)
SET YR=$EXTRACT(X,1,3)+1700
+4 IF $GET(X)
SET DATE=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_YR,1:"")
+5 SET BPT=$PIECE(X,".",2)
+6 IF BPT
if $LENGTH(BPT)<6
SET BPT=BPT_$EXTRACT("000000",1,6-$LENGTH(BPT))
+7 SET BPH=$EXTRACT(BPT,1,2)
SET BPM=$EXTRACT(BPT,3,4)
SET BPS=$EXTRACT(BPT,5,6)
+8 IF BPT
SET DATE=DATE_"@"_BPH_":"_BPM_":"_BPS
+9 QUIT $GET(DATE)
+10 ;
+11 ;call IB API to get insurance data, then select proper insurance by its name
+12 ;get its phone number
+13 ;input:
+14 ; DFN - patient IEN in #2
+15 ; BPDOS - date of service
+16 ; BPINSNM - insurance name
+17 ;output: insurance ien^insurance name^phone
GETPHONE(BPDFN,BPDOS,BPINSNM) ;
+1 NEW BPX,BPZZ,BP1,BPPHONE
+2 SET BPPHONE=""
+3 IF $$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,6")'=1
QUIT ""
+4 SET BP1=""
FOR
SET BP1=$ORDER(BPZZ("IBBAPI","INSUR",BP1))
if +BP1=0
QUIT
Begin DoDot:1
+5 IF BPINSNM=$PIECE($GET(BPZZ("IBBAPI","INSUR",BP1,1)),U,2)
SET BPPHONE=$GET(BPZZ("IBBAPI","INSUR",BP1,6))
QUIT
End DoDot:1
+6 QUIT BPPHONE
+7 ;
+8 ;try to get insurance name and phone from #9002313.59, #9002313.57 and from INSUR^IBBAPI
+9 ;input: BP59 - ien in #9002313.59
+10 ;return insurance_name^phone#
NAMEPHON(BP59) ;
+1 NEW BPHONE,BPINSNM,BPINSID,BP57,BPINSN
+2 SET BPHONE=$PIECE($GET(^BPST(BP59,10,+$GET(^BPST(BP59,9)),3)),U,2)
+3 SET BPINSNM=$PIECE($GET(^BPST(BP59,10,+$GET(^BPST(BP59,9)),0)),U,7)
+4 SET BP57=0
+5 FOR
if (BPHONE'="")&(BPINSNM'="")
QUIT
SET BP57=$ORDER(^BPSTL("B",BP59,BP57))
if +BP57=0
QUIT
Begin DoDot:1
+6 SET BPINSN=+$GET(^BPSTL(BP57,9))
+7 if BPHONE=""
SET BPHONE=$PIECE($GET(^BPSTL(BP57,10,BPINSN,3)),U,2)
+8 if BPINSNM=""
SET BPINSNM=$PIECE($GET(^BPSTL(BP57,10,BPINSN,0)),U,7)
End DoDot:1
+9 ;
+10 IF (BPINSNM'="")&(BPHONE="")
Begin DoDot:1
+11 SET BPDOS=+$PIECE($GET(^BPST(BP59,12)),U,2)\1
+12 IF BPDOS=0
SET BPDOS=+$PIECE($GET(^BPST(BP59,0)),U,8)\1
+13 SET BPDFN=+$PIECE($GET(^BPST(BP59,0)),U,6)
+14 SET BPHONE=$$GETPHONE(BPDFN,BPDOS,BPINSNM)
End DoDot:1
+15 QUIT BPINSNM_U_BPHONE
+16 ;
COM(BPSRXI,BPSRXR,BPSCOB,BPSARRAY) ; Get Comments
+1 ; This API retrieves comments for pharmacist from BPS Transaction.
+2 ;
+3 ; Input: BPSRXI - Prescription IEN (Pointer to the PRESCRIPTION
+4 ; file (#52). This parameter is required.
+5 ; BPSRXR - Fill Number (0 for original, 1 for 1st refill,
+6 ; 2 for the 2nd refill, etc.). If this parameter
+7 ; is missing, it will default to zero.
+8 ; BPSCOB - Coordination of Benefit value (1-Primary,
+9 ; 2-Secondary, 3-Tertiary). If not passed in,
+10 ; primary is assumed.
+11 ;
+12 ; Output: BPSARRAY - Return array of data in the format of:
+13 ; Array Name(Transaction Date,Count Index)=Pharmacy Flag ^
+14 ; Comment ^ User entering comment
+15 ;
+16 NEW BP59,BPSI,BPSCNT,BPSPFLG,BPSDATE,BPSUSER,BPSCOM,BPSX
+17 ;
+18 IF '$GET(BPSRXI)
QUIT
+19 ;
+20 ; Note that $$IEN59^BPSOSRX will treat BPSRXR="" as the original
+21 ; fill (0) and BPSCOB="" as primary (1)
+22 SET BP59=$$IEN59^BPSOSRX(BPSRXI,$GET(BPSRXR),$GET(BPSCOB))
+23 IF '$DATA(^BPST(BP59,0))
QUIT
+24 ;
+25 SET (BPSI,BPSCNT)=0
+26 FOR
SET BPSI=$ORDER(^BPST(BP59,11,BPSI))
if 'BPSI
QUIT
Begin DoDot:1
+27 SET BPSPFLG=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.04,"I")
+28 SET BPSDATE=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.01,"I")
+29 SET BPSUSER=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.02,"I")
+30 SET BPSCOM=$$GET1^DIQ(9002313.59111,BPSI_","_BP59,.03)
+31 ;
+32 SET BPSX=BPSPFLG_"^"_BPSCOM_"^"_BPSUSER
+33 SET BPSCNT=BPSCNT+1
+34 SET BPSARRAY(BPSDATE,BPSCNT)=BPSX
End DoDot:1
+35 QUIT
+36 ;
