- BMCFPRN1 ;IHS/OIT/FCJ - PRINT REFERRAL FORM PART 2 ; 04 May 2018 4:45 PM
- ;;4.0;REFERRED CARE INFO SYSTEM;**1,3,13**;JAN 09, 2006;Build 101
- ;;IHS/ITSC/FCJ SPLIT RTN FROM BMCFPRN, MULT CHGS TO CALL BMCFPRN
- ;4.0*1 5.17.06 IHS/OIT/FCJ ADDED PRINTING OF ELIG DATES
- ; FOR MEDICARE AND MEDICAID
- ;4.0*3 11.29.06 IHS/OIT/FCJ NOT EXITING LOOP W/MUL INS W/SAME #
- ;4.0*13 3.30.18 IHS.OIT.FCJ ADDED NEW MBI FOR MEDICARE AND RRR
- ;
- OTHPAY ;ENTRY POINT
- ;Third Party Coverage as of Best Avail Beg Dt or Today
- S Y=$$ANYINS^BMCRLU($P(BMCR0,U,3),$S($$AVDOS^BMCRLU(BMCREF)]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT))
- ;
- BEGDT ;Write Msg based on existence of Best Avail Beg & No Third Party
- I 'Y D Q
- .S BMCDT=$$AVDOS^BMCRLU(BMCREF)
- .I BMCDT'="" S X="Records indicate patient has no third party coverage for this Service Date.",N=1,T=0,C=0 D W^BMCFPRN Q
- .E S X="Our records indicate that the patient has no third party coverage as of today.",N=1,T=0,C=0 D W^BMCFPRN Q:BMCQUIT
- S X="Our records, as of "_$$FMTE^XLFDT(DT,"5D")_" indicate that this patient has the following",C=0,T=0,N=1 D W^BMCFPRN Q:BMCQUIT
- S X="third party coverage:",C=0,T=0,N=1 D W^BMCFPRN Q:BMCQUIT
- ;
- THIRD ;display third party coverage
- ;4.0*13 3.30.18 IHS.OIT.FCJ CHG NEXT SECTION TO PRT NEW MBI
- MCR ;MEDICARE
- S BMCI=1
- G:'$D(^AUPNMCR(BMCDFN)) MCD
- S BMCNUM="",BMCMBI="",BMCN=0
- S BMCMBI=$$GETMBI^AUPNMBI(BMCDFN,DT,0)
- I BMCMBI<1 S BMCMBI=$P($G(^AUPNMCR(BMCDFN,0)),U,3) I $P(^AUPNMCR(BMCDFN,0),U,4)'="" S BMCMBI=BMCMBI_$G(^AUTTMCS($P(^AUPNMCR(BMCDFN,0),U,4),0))
- ;test for elig dates
- G:'$D(^AUPNMCR(BMCDFN,11)) MCD
- S BMCE=0,J=0 F S J=$O(^AUPNMCR(BMCDFN,11,J)) Q:J'=+J D
- .Q:J>DT
- .I $P(^AUPNMCR(BMCDFN,11,J,0),U,2)]"",$P(^(0),U,2)<DT Q
- .S BMCE=1,BMCE(J)=^AUPNMCR(BMCDFN,11,J,0)
- G:'BMCE MCD
- ;TEST FOR COV TYPE "D" BEFORE WRITING MEDICARE NO.
- I $G(BMCE) S J=0 F S J=$O(BMCE(J)) Q:J'?1N.N D
- .S BMCEBDT=$P(BMCE(J),U),BMCEEDT=$P(BMCE(J),U,2),BMCECOV=$P(BMCE(J),U,3)
- .S BMCNUM=$S(BMCECOV="D":$P(BMCE(J),U,6),1:BMCMBI)
- .;PRINT ELIG NUMBER
- .I BMCNUM="" S BMCNUM="NO POLICY #"
- .S C=0,N=1,T=10,BMCI=BMCI+1,X="PATIENT HAS MEDICARE: - "_BMCNUM,N=1,C=0,T=10 D W^BMCFPRN Q:BMCQUIT
- .S:BMCEEDT="" BMCEEDT="OPEN"
- .S C=0,N=1,T=10,X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- .S X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV D W^BMCFPRN Q:BMCQUIT
- K BMCE,BMCEB,BMCEEDT,BMCEBDT,BMCECOV
- MCD I $$MCD^AUPNPAT(BMCDFN,DT) D
- .S BMCN=0 F S BMCN=$O(^AUPNMCD("B",BMCDFN,BMCN)) Q:BMCN'?1N.N D
- ..Q:'$D(^AUPNMCD(BMCN,11))
- ..;4.0*3 11.29.06 IHS/OIT/FCJ NOT EXITING PROP W/MUL INS W/SAME #
- ..;S BMCE=0,J=0 F S J=$O(^AUPNMCD(BMCN,11,J)) Q:J'=+J D
- ..S BMCE=0,J=0 F S J=$O(^AUPNMCD(BMCN,11,J)) Q:J'?1N.N D
- ...Q:J>DT
- ...I $P(^AUPNMCD(BMCN,11,J,0),U,2)]"",$P(^(0),U,2)<DT Q
- ...S BMCE=1,BMCE(J)=^AUPNMCD(BMCN,11,J,0)
- ..Q:'BMCE
- ..;S BMCNI=$P(^AUPNMCD(BMCN,0),U,10) ;4.0*1 2.9.06 IHS.OIT.FCJ
- ..S BMCNI=$P(^AUPNMCD(BMCN,0),U,10),BMCX="" ;4.0*1 2.9.06 IHS.OIT.FCJ
- ..I BMCNI]"" S BMCX=$P($G(^AUTNINS(BMCNI,0)),U)
- ..S:BMCX="" BMCX="UNKNOWN"
- ..S BMCNUM="",BMCNUM=$P($G(^AUPNMCD(BMCN,0)),U,3)
- ..I BMCNUM="" S BMCNUM="NO POLICY #"
- ..S BMCX=BMCX_" - "_BMCNUM
- ..S C=0,N=1,T=10,BMCI=BMCI+1,X="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX D W^BMCFPRN Q:BMCQUIT
- ..I $G(BMCE) S BMCEBDT="" F S BMCEBDT=$O(BMCE(BMCEBDT)) Q:BMCEBDT'?1N.N D
- ...S BMCEEDT=$P(^AUPNMCD(BMCN,11,BMCEBDT,0),U,2),BMCECOV=$P(^(0),U,3)
- ...S:BMCEEDT="" BMCEEDT="OPEN"
- ...S C=0,N=1,T=10,X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- ...S X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV D W^BMCFPRN
- ...K BMCE(BMCEBDT)
- ..;4.0*1 5.17.06 IHS.OIT.FCJ END OF CHANGES
- K BMCE,BMCEEDT,BMCEBDT,BMCECOV
- ;
- PVTINS ;Private Insurance Companies
- S (P,DFN)=BMCDFN,D=DT,BMCFLAG=1,BMCPCNT=0 K BMCPRNM D PI^BMCRLU1
- K P,D,BMCFLAG,BMCPCNT
- I '$D(BMCPRNM) W !,?10,"NO PRIVATE INSURANCE COVERAGE"
- I $D(BMCPRNM) D
- .W !,?10,"PRIVATE INSURER(S): "
- .S BMCX=0
- .F S BMCX=$O(BMCPRNM(BMCX)) Q:BMCX'=+BMCX W ?32,BMCPRNM(BMCX),!
- ;
- RR ;RAILROAD INS.
- ;4.0*13 3.30.18 IHS.OIT.FCJ CHG NEXT SECTION TO PRT NEW MBI
- S BMCI=1,BMCMBI=""
- Q:'$D(^AUPNRRE(BMCDFN))
- ;test for elig dates
- Q:'$D(^AUPNRRE(BMCDFN,11))
- S BMCE=0,J=0 F S J=$O(^AUPNRRE(BMCDFN,11,J)) Q:J'=+J D
- .Q:J>DT
- .I $P(^AUPNRRE(BMCDFN,11,J,0),U,2)]"",$P(^(0),U,2)<DT Q
- .S BMCE=1,BMCE(J)=^AUPNRRE(BMCDFN,11,J,0)
- Q:'BMCE
- S BMCMBI=$$GETMBI^AUPNMBI(BMCDFN,DT,0)
- I +BMCMBI<1 D
- .S BMCMBI="" I $P($G(^AUPNRRE(BMCDFN,0)),U,3)'="" S BMCMBI=$P($G(^AUTTRRP($P(^AUPNRRE(BMCDFN,0),U,3),0)),U)
- .S BMCMBI=BMCMBI_$P($G(^AUPNRRE(BMCDFN,0)),U,4)
- S BMCI=BMCI+1,X="RAILROAD: - "_BMCMBI
- S N=1,C=0,T=10 D W^BMCFPRN Q:BMCQUIT
- I $G(BMCE) S J=0 F S J=$O(BMCE(J)) Q:J'?1N.N D
- .S BMCEBDT=$P(BMCE(J),U),BMCEEDT=$P(BMCE(J),U,2),BMCECOV=$P(BMCE(J),U,3)
- .S C=0,N=1,T=10,X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- .S X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV D W^BMCFPRN
- ;I $$RAIL^BMCRLU(BMCDFN,DT) S BMCI=BMCI+1,X="RAILROAD: - "_$P($G(^AUTTRRP($P($G(^AUPNRRE(BMCDFN,0)),U,3),0)),U,1)_$P($G(^AUPNRRE(BMCDFN,0)),U,4),N=1,C=0,T=10 D W^BMCFPRN Q:BMCQUIT
- K BMCMBI
- Q
- BMCFPRN1 ;IHS/OIT/FCJ - PRINT REFERRAL FORM PART 2 ; 04 May 2018 4:45 PM
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,3,13**;JAN 09, 2006;Build 101
- +2 ;;IHS/ITSC/FCJ SPLIT RTN FROM BMCFPRN, MULT CHGS TO CALL BMCFPRN
- +3 ;4.0*1 5.17.06 IHS/OIT/FCJ ADDED PRINTING OF ELIG DATES
- +4 ; FOR MEDICARE AND MEDICAID
- +5 ;4.0*3 11.29.06 IHS/OIT/FCJ NOT EXITING LOOP W/MUL INS W/SAME #
- +6 ;4.0*13 3.30.18 IHS.OIT.FCJ ADDED NEW MBI FOR MEDICARE AND RRR
- +7 ;
- OTHPAY ;ENTRY POINT
- +1 ;Third Party Coverage as of Best Avail Beg Dt or Today
- +2 SET Y=$$ANYINS^BMCRLU($PIECE(BMCR0,U,3),$SELECT($$AVDOS^BMCRLU(BMCREF)]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:DT))
- +3 ;
- BEGDT ;Write Msg based on existence of Best Avail Beg & No Third Party
- +1 IF 'Y
- Begin DoDot:1
- +2 SET BMCDT=$$AVDOS^BMCRLU(BMCREF)
- +3 IF BMCDT'=""
- SET X="Records indicate patient has no third party coverage for this Service Date."
- SET N=1
- SET T=0
- SET C=0
- DO W^BMCFPRN
- QUIT
- +4 IF '$TEST
- SET X="Our records indicate that the patient has no third party coverage as of today."
- SET N=1
- SET T=0
- SET C=0
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- End DoDot:1
- QUIT
- +5 SET X="Our records, as of "_$$FMTE^XLFDT(DT,"5D")_" indicate that this patient has the following"
- SET C=0
- SET T=0
- SET N=1
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- +6 SET X="third party coverage:"
- SET C=0
- SET T=0
- SET N=1
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- +7 ;
- THIRD ;display third party coverage
- +1 ;4.0*13 3.30.18 IHS.OIT.FCJ CHG NEXT SECTION TO PRT NEW MBI
- MCR ;MEDICARE
- +1 SET BMCI=1
- +2 IF '$DATA(^AUPNMCR(BMCDFN))
- GOTO MCD
- +3 SET BMCNUM=""
- SET BMCMBI=""
- SET BMCN=0
- +4 SET BMCMBI=$$GETMBI^AUPNMBI(BMCDFN,DT,0)
- +5 IF BMCMBI<1
- SET BMCMBI=$PIECE($GET(^AUPNMCR(BMCDFN,0)),U,3)
- IF $PIECE(^AUPNMCR(BMCDFN,0),U,4)'=""
- SET BMCMBI=BMCMBI_$GET(^AUTTMCS($PIECE(^AUPNMCR(BMCDFN,0),U,4),0))
- +6 ;test for elig dates
- +7 IF '$DATA(^AUPNMCR(BMCDFN,11))
- GOTO MCD
- +8 SET BMCE=0
- SET J=0
- FOR
- SET J=$ORDER(^AUPNMCR(BMCDFN,11,J))
- IF J'=+J
- QUIT
- Begin DoDot:1
- +9 IF J>DT
- QUIT
- +10 IF $PIECE(^AUPNMCR(BMCDFN,11,J,0),U,2)]""
- IF $PIECE(^(0),U,2)<DT
- QUIT
- +11 SET BMCE=1
- SET BMCE(J)=^AUPNMCR(BMCDFN,11,J,0)
- End DoDot:1
- +12 IF 'BMCE
- GOTO MCD
- +13 ;TEST FOR COV TYPE "D" BEFORE WRITING MEDICARE NO.
- +14 IF $GET(BMCE)
- SET J=0
- FOR
- SET J=$ORDER(BMCE(J))
- IF J'?1N.N
- QUIT
- Begin DoDot:1
- +15 SET BMCEBDT=$PIECE(BMCE(J),U)
- SET BMCEEDT=$PIECE(BMCE(J),U,2)
- SET BMCECOV=$PIECE(BMCE(J),U,3)
- +16 SET BMCNUM=$SELECT(BMCECOV="D":$PIECE(BMCE(J),U,6),1:BMCMBI)
- +17 ;PRINT ELIG NUMBER
- +18 IF BMCNUM=""
- SET BMCNUM="NO POLICY #"
- +19 SET C=0
- SET N=1
- SET T=10
- SET BMCI=BMCI+1
- SET X="PATIENT HAS MEDICARE: - "_BMCNUM
- SET N=1
- SET C=0
- SET T=10
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- +20 IF BMCEEDT=""
- SET BMCEEDT="OPEN"
- +21 SET C=0
- SET N=1
- SET T=10
- SET X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- +22 SET X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- End DoDot:1
- +23 KILL BMCE,BMCEB,BMCEEDT,BMCEBDT,BMCECOV
- MCD IF $$MCD^AUPNPAT(BMCDFN,DT)
- Begin DoDot:1
- +1 SET BMCN=0
- FOR
- SET BMCN=$ORDER(^AUPNMCD("B",BMCDFN,BMCN))
- IF BMCN'?1N.N
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNMCD(BMCN,11))
- QUIT
- +3 ;4.0*3 11.29.06 IHS/OIT/FCJ NOT EXITING PROP W/MUL INS W/SAME #
- +4 ;S BMCE=0,J=0 F S J=$O(^AUPNMCD(BMCN,11,J)) Q:J'=+J D
- +5 SET BMCE=0
- SET J=0
- FOR
- SET J=$ORDER(^AUPNMCD(BMCN,11,J))
- IF J'?1N.N
- QUIT
- Begin DoDot:3
- +6 IF J>DT
- QUIT
- +7 IF $PIECE(^AUPNMCD(BMCN,11,J,0),U,2)]""
- IF $PIECE(^(0),U,2)<DT
- QUIT
- +8 SET BMCE=1
- SET BMCE(J)=^AUPNMCD(BMCN,11,J,0)
- End DoDot:3
- +9 IF 'BMCE
- QUIT
- +10 ;S BMCNI=$P(^AUPNMCD(BMCN,0),U,10) ;4.0*1 2.9.06 IHS.OIT.FCJ
- +11 ;4.0*1 2.9.06 IHS.OIT.FCJ
- SET BMCNI=$PIECE(^AUPNMCD(BMCN,0),U,10)
- SET BMCX=""
- +12 IF BMCNI]""
- SET BMCX=$PIECE($GET(^AUTNINS(BMCNI,0)),U)
- +13 IF BMCX=""
- SET BMCX="UNKNOWN"
- +14 SET BMCNUM=""
- SET BMCNUM=$PIECE($GET(^AUPNMCD(BMCN,0)),U,3)
- +15 IF BMCNUM=""
- SET BMCNUM="NO POLICY #"
- +16 SET BMCX=BMCX_" - "_BMCNUM
- +17 SET C=0
- SET N=1
- SET T=10
- SET BMCI=BMCI+1
- SET X="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- +18 IF $GET(BMCE)
- SET BMCEBDT=""
- FOR
- SET BMCEBDT=$ORDER(BMCE(BMCEBDT))
- IF BMCEBDT'?1N.N
- QUIT
- Begin DoDot:3
- +19 SET BMCEEDT=$PIECE(^AUPNMCD(BMCN,11,BMCEBDT,0),U,2)
- SET BMCECOV=$PIECE(^(0),U,3)
- +20 IF BMCEEDT=""
- SET BMCEEDT="OPEN"
- +21 SET C=0
- SET N=1
- SET T=10
- SET X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- +22 SET X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV
- DO W^BMCFPRN
- +23 KILL BMCE(BMCEBDT)
- End DoDot:3
- +24 ;4.0*1 5.17.06 IHS.OIT.FCJ END OF CHANGES
- End DoDot:2
- End DoDot:1
- +25 KILL BMCE,BMCEEDT,BMCEBDT,BMCECOV
- +26 ;
- PVTINS ;Private Insurance Companies
- +1 SET (P,DFN)=BMCDFN
- SET D=DT
- SET BMCFLAG=1
- SET BMCPCNT=0
- KILL BMCPRNM
- DO PI^BMCRLU1
- +2 KILL P,D,BMCFLAG,BMCPCNT
- +3 IF '$DATA(BMCPRNM)
- WRITE !,?10,"NO PRIVATE INSURANCE COVERAGE"
- +4 IF $DATA(BMCPRNM)
- Begin DoDot:1
- +5 WRITE !,?10,"PRIVATE INSURER(S): "
- +6 SET BMCX=0
- +7 FOR
- SET BMCX=$ORDER(BMCPRNM(BMCX))
- IF BMCX'=+BMCX
- QUIT
- WRITE ?32,BMCPRNM(BMCX),!
- End DoDot:1
- +8 ;
- RR ;RAILROAD INS.
- +1 ;4.0*13 3.30.18 IHS.OIT.FCJ CHG NEXT SECTION TO PRT NEW MBI
- +2 SET BMCI=1
- SET BMCMBI=""
- +3 IF '$DATA(^AUPNRRE(BMCDFN))
- QUIT
- +4 ;test for elig dates
- +5 IF '$DATA(^AUPNRRE(BMCDFN,11))
- QUIT
- +6 SET BMCE=0
- SET J=0
- FOR
- SET J=$ORDER(^AUPNRRE(BMCDFN,11,J))
- IF J'=+J
- QUIT
- Begin DoDot:1
- +7 IF J>DT
- QUIT
- +8 IF $PIECE(^AUPNRRE(BMCDFN,11,J,0),U,2)]""
- IF $PIECE(^(0),U,2)<DT
- QUIT
- +9 SET BMCE=1
- SET BMCE(J)=^AUPNRRE(BMCDFN,11,J,0)
- End DoDot:1
- +10 IF 'BMCE
- QUIT
- +11 SET BMCMBI=$$GETMBI^AUPNMBI(BMCDFN,DT,0)
- +12 IF +BMCMBI<1
- Begin DoDot:1
- +13 SET BMCMBI=""
- IF $PIECE($GET(^AUPNRRE(BMCDFN,0)),U,3)'=""
- SET BMCMBI=$PIECE($GET(^AUTTRRP($PIECE(^AUPNRRE(BMCDFN,0),U,3),0)),U)
- +14 SET BMCMBI=BMCMBI_$PIECE($GET(^AUPNRRE(BMCDFN,0)),U,4)
- End DoDot:1
- +15 SET BMCI=BMCI+1
- SET X="RAILROAD: - "_BMCMBI
- +16 SET N=1
- SET C=0
- SET T=10
- DO W^BMCFPRN
- IF BMCQUIT
- QUIT
- +17 IF $GET(BMCE)
- SET J=0
- FOR
- SET J=$ORDER(BMCE(J))
- IF J'?1N.N
- QUIT
- Begin DoDot:1
- +18 SET BMCEBDT=$PIECE(BMCE(J),U)
- SET BMCEEDT=$PIECE(BMCE(J),U,2)
- SET BMCECOV=$PIECE(BMCE(J),U,3)
- +19 SET C=0
- SET N=1
- SET T=10
- SET X="ELIG DATES: "_$$FMTE^XLFDT(BMCEBDT,"5D")_" TO "
- +20 SET X=X_$$FMTE^XLFDT(BMCEEDT,"5D")_" COVERAGE: "_BMCECOV
- DO W^BMCFPRN
- End DoDot:1
- +21 ;I $$RAIL^BMCRLU(BMCDFN,DT) S BMCI=BMCI+1,X="RAILROAD: - "_$P($G(^AUTTRRP($P($G(^AUPNRRE(BMCDFN,0)),U,3),0)),U,1)_$P($G(^AUPNRRE(BMCDFN,0)),U,4),N=1,C=0,T=10 D W^BMCFPRN Q:BMCQUIT
- +22 KILL BMCMBI
- +23 QUIT