- 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 Jan 18, 2025@02:53: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 ;