BPSPRRX1 ;ALB/SS - ePharmacy secondary billing ;16-DEC-08
;;1.0;E CLAIMS MGMT ENGINE;**8,9**;JUN 2004;Build 18
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
;display available plans and prompt the user to select the plan
;input:
; BPSDFN - patient's DFN
; BPSDOS - date of service
; BPRETAR - array to return details for the selected plan (by reference)
; BPSPRMT - prompt
; BPDEFPLN (optional) - default plan
;return: 0 if not selected
; "-110^No valid group insurance plans" if no plans
;return: the GROUP INSURANCE PLAN ien (#355.3)
; and selected plan's details in BPRETAR
SELECTPL(BPSDFN,BPSDOS,BPRETAR,BPSPRMT,BPDEFPLN) ;
N BPSRET,BPSARR
S BPSRET=$$SELPLAN(BPSDFN,BPSDOS,"E",.BPSARR,"1,7,8,10,11,14,12,18",1,$S($L($G(BPSPRMT)):BPSPRMT,1:"SECONDARY INSURANCE POLICY"),"",$G(BPDEFPLN))
Q:+BPSRET=-1 0
Q:+BPSRET=-110 BPSRET
Q:+BPSRET=0 0
M BPRETAR=BPSARR("IBBAPI","INSUR",+$P(BPSRET,U,3))
Q +$P(BPRETAR(8),U,1)
;
;select insurance from the list of the insurances which was built for the current user setting
;for the User Screen.
;input :
; BPSDFN - patient's DFN
; BPSDOS - date of service
; BPSTAT - IBSTAT flag in INSUR^IBBAPI
; BPSARR - array to return results (by reference)
; BPSFLDS - IBFLDS in INSUR^IBBAPI (list of fields to return, "*" for all)
; BPSDISPL - display insurances before prompting for selection
; BPSMESS - message to display before prompt
; BPDEFPLN (optional) - default plan
;output : 1^name of the insurance or null
;0^ - if "^" or was not selected
SELPLAN(BPSDFN,BPSDOS,BPSTAT,BPSARR,BPSFLDS,BPSDISPL,BPSPRMPT,BPSMESS,BPDEFPLN) ;
N BPSRET,BPSDFLT,BPSVAL
N DIR,Y,X
N BPX,BPCNT,BPTEL,BPCNT2
S BPSDFLT=""
S BPSRET=$$INSUR^IBBAPI(BPSDFN,BPSDOS,BPSTAT,.BPSARR,BPSFLDS)
Q:'BPSRET "-110^No valid group insurance plans"
W !,?4,"Insurance",?18,"COB",?23,"Subscriber ID",?37,"Group",?48,"Holder",?57,"Effective",?68,"Expires"
W !,?4,"=============",?18,"====",?23,"=============",?37,"==========",?48,"========",?57,"==========",?68,"=========="
S BPX=0
I $G(BPSDISPL) F S BPX=$O(BPSARR("IBBAPI","INSUR",BPX)) Q:BPX="" D
. W !,?1,BPX
. W ?4,$E($P($G(BPSARR("IBBAPI","INSUR",BPX,1)),U,2),1,13)
. W ?18,$E($P($G(BPSARR("IBBAPI","INSUR",BPX,7)),U,2),1,3)
. W ?23,$E($P($G(BPSARR("IBBAPI","INSUR",BPX,14)),U,1),1,13)
. W ?37,$E($P($G(BPSARR("IBBAPI","INSUR",BPX,8)),U,2),1,10)
. W ?48,$E($P($G(BPSARR("IBBAPI","INSUR",BPX,12)),U,2),1,9)
. W:+$G(BPSARR("IBBAPI","INSUR",BPX,10)) ?57,$$FMTE^XLFDT(+$G(BPSARR("IBBAPI","INSUR",BPX,10)),"5Z")
. W:+$G(BPSARR("IBBAPI","INSUR",BPX,11)) ?68,$$FMTE^XLFDT(+$G(BPSARR("IBBAPI","INSUR",BPX,11)),"5Z")
W !!
S BPX=0,BPCNT=0
S DIR("A")=BPSPRMPT
I $L($G(BPSMESS))>0 D
. S DIR("A","?")=BPSMESS
. S DIR("A",1)=""
. S DIR("A",2)=BPSMESS
. S DIR("A",3)=""
K ^TMP($J,"BPSPRRX1","LOOKUP")
F S BPX=$O(BPSARR("IBBAPI","INSUR",BPX)) Q:BPX="" D
. S BPCNT=BPCNT+1
. S BPSVAL=$E($P($G(BPSARR("IBBAPI","INSUR",BPX,1)),U,2)_" ("_$P($G(BPSARR("IBBAPI","INSUR",BPX,7)),U,2)_") - "_$P($G(BPSARR("IBBAPI","INSUR",BPX,8)),U,2),1,60)
. S ^TMP($J,"BPSPRRX1","LOOKUP",BPCNT,0)=BPSVAL_U_BPX
. S ^TMP($J,"BPSPRRX1","LOOKUP","B",BPX,BPCNT)=""
. I $G(BPDEFPLN)>0 I +BPSARR("IBBAPI","INSUR",BPX,8)=BPDEFPLN S BPSDFLT=BPX
I BPCNT=0 Q "0^"
S ^TMP($J,"BPSPRRX1","LOOKUP",0)=U_U_BPCNT_U_BPCNT
;set DIR variables
S DIR(0)="P^TMP($J,""BPSPRRX1"",""LOOKUP"",:AEQMZ"
I BPSDFLT'="" S DIR("B")=BPSDFLT ;$E(BPSDFLT,1,14)
D ^DIR
S BPX=$P($G(^TMP($J,"BPSPRRX1","LOOKUP",+Y,0)),U,2)
K ^TMP($J,"BPSPRRX1","LOOKUP")
I X="^" Q "-1^"
I $TR($P(Y,U,2)," ")="" Q "0^"
Q Y_U_BPX
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSPRRX1 3678 printed Sep 23, 2025@19:28:34 Page 2
BPSPRRX1 ;ALB/SS - ePharmacy secondary billing ;16-DEC-08
+1 ;;1.0;E CLAIMS MGMT ENGINE;**8,9**;JUN 2004;Build 18
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 ;display available plans and prompt the user to select the plan
+6 ;input:
+7 ; BPSDFN - patient's DFN
+8 ; BPSDOS - date of service
+9 ; BPRETAR - array to return details for the selected plan (by reference)
+10 ; BPSPRMT - prompt
+11 ; BPDEFPLN (optional) - default plan
+12 ;return: 0 if not selected
+13 ; "-110^No valid group insurance plans" if no plans
+14 ;return: the GROUP INSURANCE PLAN ien (#355.3)
+15 ; and selected plan's details in BPRETAR
SELECTPL(BPSDFN,BPSDOS,BPRETAR,BPSPRMT,BPDEFPLN) ;
+1 NEW BPSRET,BPSARR
+2 SET BPSRET=$$SELPLAN(BPSDFN,BPSDOS,"E",.BPSARR,"1,7,8,10,11,14,12,18",1,$SELECT($LENGTH($GET(BPSPRMT)):BPSPRMT,1:"SECONDARY INSURANCE POLICY"),"",$GET(BPDEFPLN))
+3 if +BPSRET=-1
QUIT 0
+4 if +BPSRET=-110
QUIT BPSRET
+5 if +BPSRET=0
QUIT 0
+6 MERGE BPRETAR=BPSARR("IBBAPI","INSUR",+$PIECE(BPSRET,U,3))
+7 QUIT +$PIECE(BPRETAR(8),U,1)
+8 ;
+9 ;select insurance from the list of the insurances which was built for the current user setting
+10 ;for the User Screen.
+11 ;input :
+12 ; BPSDFN - patient's DFN
+13 ; BPSDOS - date of service
+14 ; BPSTAT - IBSTAT flag in INSUR^IBBAPI
+15 ; BPSARR - array to return results (by reference)
+16 ; BPSFLDS - IBFLDS in INSUR^IBBAPI (list of fields to return, "*" for all)
+17 ; BPSDISPL - display insurances before prompting for selection
+18 ; BPSMESS - message to display before prompt
+19 ; BPDEFPLN (optional) - default plan
+20 ;output : 1^name of the insurance or null
+21 ;0^ - if "^" or was not selected
SELPLAN(BPSDFN,BPSDOS,BPSTAT,BPSARR,BPSFLDS,BPSDISPL,BPSPRMPT,BPSMESS,BPDEFPLN) ;
+1 NEW BPSRET,BPSDFLT,BPSVAL
+2 NEW DIR,Y,X
+3 NEW BPX,BPCNT,BPTEL,BPCNT2
+4 SET BPSDFLT=""
+5 SET BPSRET=$$INSUR^IBBAPI(BPSDFN,BPSDOS,BPSTAT,.BPSARR,BPSFLDS)
+6 if 'BPSRET
QUIT "-110^No valid group insurance plans"
+7 WRITE !,?4,"Insurance",?18,"COB",?23,"Subscriber ID",?37,"Group",?48,"Holder",?57,"Effective",?68,"Expires"
+8 WRITE !,?4,"=============",?18,"====",?23,"=============",?37,"==========",?48,"========",?57,"==========",?68,"=========="
+9 SET BPX=0
+10 IF $GET(BPSDISPL)
FOR
SET BPX=$ORDER(BPSARR("IBBAPI","INSUR",BPX))
if BPX=""
QUIT
Begin DoDot:1
+11 WRITE !,?1,BPX
+12 WRITE ?4,$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,1)),U,2),1,13)
+13 WRITE ?18,$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,7)),U,2),1,3)
+14 WRITE ?23,$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,14)),U,1),1,13)
+15 WRITE ?37,$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,8)),U,2),1,10)
+16 WRITE ?48,$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,12)),U,2),1,9)
+17 if +$GET(BPSARR("IBBAPI","INSUR",BPX,10))
WRITE ?57,$$FMTE^XLFDT(+$GET(BPSARR("IBBAPI","INSUR",BPX,10)),"5Z")
+18 if +$GET(BPSARR("IBBAPI","INSUR",BPX,11))
WRITE ?68,$$FMTE^XLFDT(+$GET(BPSARR("IBBAPI","INSUR",BPX,11)),"5Z")
End DoDot:1
+19 WRITE !!
+20 SET BPX=0
SET BPCNT=0
+21 SET DIR("A")=BPSPRMPT
+22 IF $LENGTH($GET(BPSMESS))>0
Begin DoDot:1
+23 SET DIR("A","?")=BPSMESS
+24 SET DIR("A",1)=""
+25 SET DIR("A",2)=BPSMESS
+26 SET DIR("A",3)=""
End DoDot:1
+27 KILL ^TMP($JOB,"BPSPRRX1","LOOKUP")
+28 FOR
SET BPX=$ORDER(BPSARR("IBBAPI","INSUR",BPX))
if BPX=""
QUIT
Begin DoDot:1
+29 SET BPCNT=BPCNT+1
+30 SET BPSVAL=$EXTRACT($PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,1)),U,2)_" ("_$PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,7)),U,2)_") - "_$PIECE($GET(BPSARR("IBBAPI","INSUR",BPX,8)),U,2),1,60)
+31 SET ^TMP($JOB,"BPSPRRX1","LOOKUP",BPCNT,0)=BPSVAL_U_BPX
+32 SET ^TMP($JOB,"BPSPRRX1","LOOKUP","B",BPX,BPCNT)=""
+33 IF $GET(BPDEFPLN)>0
IF +BPSARR("IBBAPI","INSUR",BPX,8)=BPDEFPLN
SET BPSDFLT=BPX
End DoDot:1
+34 IF BPCNT=0
QUIT "0^"
+35 SET ^TMP($JOB,"BPSPRRX1","LOOKUP",0)=U_U_BPCNT_U_BPCNT
+36 ;set DIR variables
+37 SET DIR(0)="P^TMP($J,""BPSPRRX1"",""LOOKUP"",:AEQMZ"
+38 ;$E(BPSDFLT,1,14)
IF BPSDFLT'=""
SET DIR("B")=BPSDFLT
+39 DO ^DIR
+40 SET BPX=$PIECE($GET(^TMP($JOB,"BPSPRRX1","LOOKUP",+Y,0)),U,2)
+41 KILL ^TMP($JOB,"BPSPRRX1","LOOKUP")
+42 IF X="^"
QUIT "-1^"
+43 IF $TRANSLATE($PIECE(Y,U,2)," ")=""
QUIT "0^"
+44 QUIT Y_U_BPX
+45 ;
