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
