BMCRLU.m

BMCRLU ; IHS/PHXAO/TMJ - GEN RETR UTILITIES ;     

 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ REMOVED THE () FOR PRINTING ACT OR EST; FX DT FORMAT

 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 ;4.0*9 11.2.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE

 ;

RZERO(V,L) ;ep right zero fill 

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"

 Q V

LZERO(V,L) ;left zero fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V

 Q V

LBLK(V,L) ;left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V

 Q V

 ;

ANYINS(P,D) ;EP - return 1 or 0 if patient has any insurance

 NEW BMCA

 S BMCA=0

 S BMCA=$$MCR^AUPNPAT(P,D) I BMCA Q BMCA

 S BMCA=$$MCD^AUPNPAT(P,D) I BMCA Q BMCA

 S BMCA=$$PI^AUPNPAT(P,D) I BMCA Q BMCA

 S BMCA=$$RAIL(P,D)

 Q BMCA

AVDX(R,A,T) ;EP - return array of available dx's

 NEW BMCFLG,BMCX

 I $G(T)="" S T="N"

 S BMCFLG=0

 I $G(A)="" S A="BMCAVDX"

 K @A

 I 'R S BMCFLG=1 Q BMCFLG

 I '$D(^BMCREF(R)) S BMCFLG=2 Q BMCFLG

 S (BMCX,C)=0 F  S BMCX=$O(^BMCDX("AD",R,BMCX)) Q:BMCX'=+BMCX  I $P(^BMCDX(BMCX,0),U,4)="F" S C=C+1 D SETDX

 ;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10 ADDED BMCDTYP="B" TO NXT LINE

 I C=0,BMCDTYP="B" S BMCX=0 F  S BMCX=$O(^BMCDX("AD",R,BMCX)) Q:BMCX'=+BMCX  I $P(^BMCDX(BMCX,0),U,4)="P" S C=C+1 D SETDX

 Q BMCFLG

SETDX ;

 I T="N" S @A@($P(^BMCDX(BMCX,0),U))="" Q

 NEW BMCCDI S BMCCDI=$P(^BMCDX(BMCX,0),U) ;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10

 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10

 ;I T="E" S @A@($P(^ICD9($P(^BMCDX(BMCX,0),U),0),U))="" Q

 ;I T="E" S @A@($P($$ICDDX^ICDCODE($P(^BMCDX(BMCX,0),U),0),U,2))="" Q

 I T="E" S @A@($P($$ICDDX^ICDEX(BMCCDI,,,"I"),U,2))="" Q

 ;I T="I" S @A@($P(^ICD9($P(^BMCDX(BMCX,0),U),0),U,3))="" Q

 ;I T="I" S @A@($P($$ICDDX^ICDCODE($P(^BMCDX(BMCX,0),U),0),U,4))="" Q

 I T="I" S @A@($P($$ICDDX^ICDEX(BMCCDI,,,"I"),U,4))="" Q

 Q

AVOP(R,A,T) ;EP

 NEW BMCFLG,BMCX

 I $G(T)="" S T="N"

 S BMCFLG=0

 I $G(A)="" S A="BMCAVOP"

 K @A

 I 'R S BMCFLG=1 Q BMCFLG

 I '$D(^BMCREF(R)) S BMCFLG=2 Q BMCFLG

 S (BMCX,C)=0 F  S BMCX=$O(^BMCPX("AD",R,BMCX)) Q:BMCX'=+BMCX  I $P(^BMCPX(BMCX,0),U,4)="F" S C=C+1 D SETOP

 I C=0 S BMCX=0 F  S BMCX=$O(^BMCPX("AD",R,BMCX)) Q:BMCX'=+BMCX  I $P(^BMCPX(BMCX,0),U,4)="P" S C=C+1 D SETOP

 Q BMCFLG

SETOP ;

 I T="N" S @A@($P(^BMCPX(BMCX,0),U))="" Q

 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES

 ;I T="E" S @A@($P(^ICPT($P(^BMCPX(BMCX,0),U),0),U))="" Q

 I T="E" S @A@($P($$CPT^ICPTCOD($P(^BMCPX(BMCX,0),U),0),U,2))="" Q

 ;I T="I" S @A@($P(^ICPT($P(^BMCPX(BMCX,0),U),0),U,2))="" Q

 I T="I" S @A@($P($$CPT^ICPTCOD($P(^BMCPX(BMCX,0),U),0),U,3))="" Q

 I T="P",$P(^BMCPX(BMCX,0),U,6) S @A@(BMCX)=$P(^AUTNPOV($P(^BMCPX(BMCX,0),U,6),0),U) Q

 Q

AVDOS(R,F) ;EP - return available date of service (actual or estimated) in either internal or external format

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$S($P($G(^BMCREF(R,11)),U,6)]"":$P(^BMCREF(R,11),U,6),1:$P($G(^BMCREF(R,11)),U,5))

 I BMCDOS="" Q BMCDOS

 I F="N" Q BMCDOS

 I F="E" S BMCDOS=$$FMTE^XLFDT(BMCDOS,"2P")

 I F="S" S BMCDOS=$E(BMCDOS,4,5)_"/"_$E(BMCDOS,6,7)_"/"_$E(BMCDOS,2,3)

 I F="C" S BMCDOS=$E(BMCDOS,4,5)_"/"_$E(BMCDOS,6,7)_"/"_$E(BMCDOS,2,3)_" "_$S($$VAL^XBDIQ1(90001,R,1106)]"":"A",1:"E")

 Q BMCDOS

AVEOS(R,F) ;EP return available end date of service

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$S($P($G(^BMCREF(R,11)),U,8)]"":$P(^BMCREF(R,11),U,8),1:$P($G(^BMCREF(R,11)),U,7))

 I F="E",BMCDOS]"" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S",BMCDOS]"" S Y=BMCDOS D DT1^BMCOSUT S BMCDOS=Y_" "_$S($$VAL^XBDIQ1(90001,R,1106)]"":"A",1:"E")

 I F="N" Q BMCDOS

 Q BMCDOS

AVLOS(R,F) ;EP return available LOS

 I $G(F)="" S F="I"

 NEW %

 S %=$S($P($G(^BMCREF(R,11)),U,10):$P($G(^BMCREF(R,11)),U,10),1:$P($G(^BMCREF(R,11)),U,9))

 I %="" Q %

 I F="C" S %=%_$S($P($G(^BMCREF(R,11)),U,10):" A",1:" E")

 Q %

AVICOST(R) ; EP

 ;best available IHS cost is 1104 if available, else the larger of

 ;1103 or 1117

 I $G(^BMCREF(R,11))="" Q ""

 S %=0 F %1=4,3,17 S %=%+$P(^BMCREF(R,11),U,%1)

 I '% Q ""

 I $P(^BMCREF(R,11),U,4) Q $P(^(11),U,4)

 I $P(^BMCREF(R,11),U,3)>$P(^BMCREF(R,11),U,17) Q $P(^BMCREF(R,11),U,3)

 E  Q $P(^BMCREF(R,11),U,17)

 Q ""

 ;

AVTCOST(R) ; EP

 ;Final Total Referral Costs 1102 if available Else Estimated Total 

 ;Costs 1101 Total Referral Cost to Date 1119 whichever is larger

 I $G(^BMCREF(R,11))="" Q ""

 S %=0 F %1=2,1,19 S %=%+$P(^BMCREF(R,11),U,%1)

 I '% Q ""

 I $P(^BMCREF(R,11),U,2) Q $P(^(11),U,2)

 I $P(^BMCREF(R,11),U)>$P(^BMCREF(R,11),U,19) Q $P(^BMCREF(R,11),U)

 E  Q $P(^BMCREF(R,11),U,19)

 Q ""

FACREF(R) ;EP return facility referred to (piece 7-8-9)

 N BMCF,%

 S %=^BMCREF(R,0)

 S BMCF=$S($P(%,U,7):$P($G(^AUTTVNDR($P(%,U,7),0)),U),$P(%,U,8):$P(^DIC(4,$P(%,U,8),0),U),$P(%,U,9):$P($G(^BMCLPRV($P(%,U,9),0)),U),$P(%,U,23):$P(^DIC(40.7,$P(%,U,23),0),U),1:"<UNKNOWN>")

 Q BMCF

CASEMAN(R) ;EP return case manager

 Q $S($P(^BMCREF(R,0),U,19)]"":$P(^VA(200,$P(^BMCREF(R,0),U,19),0),U),1:"??")

REFDTI(R,F) ; EP - Date Referral Initiated

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$S($P($G(^BMCREF(R,0)),U)]"":$P(^BMCREF(R,0),U),1:$P($G(^BMCREF(R,0)),U,6))

 I BMCDOS="" Q BMCDOS

 I F="E" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S" S BMCDOS=$E(BMCDOS,4,5)_"/"_$E(BMCDOS,6,7)_"/"_$E(BMCDOS,2,3)

 I F="C" S BMCDOS=$E(BMCDOS,4,5)_"/"_$E(BMCDOS,6,7)_"/"_$E(BMCDOS,2,3)_" "_$S($$VAL^XBDIQ1(90001,R,.01)]"":"A",1:"E")

 Q BMCDOS

 ;

 ;

EXPBGDT(R,F) ;Expected Begin Date of Service

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$P($G(^BMCREF(R,11)),U,5)

 I F="E",BMCDOS]"" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S",BMCDOS]"" S Y=BMCDOS D DT1^BMCOSUT S BMCDOS=Y

 I F="N" Q BMCDOS

 Q BMCDOS

 ;

 ;

EXPENDT(R,F) ;Expected End DOS

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$P($G(^BMCREF(R,11)),U,7)

 I F="E",BMCDOS]"" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S",BMCDOS]"" S Y=BMCDOS D DT1^BMCOSUT S BMCDOS=Y

 I F="N" Q BMCDOS

 Q BMCDOS

 ;

ACTBDT(R,F) ;Actual Beginning DOS

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$P($G(^BMCREF(R,11)),U,6)

 I F="E",BMCDOS]"" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S",BMCDOS]"" S Y=BMCDOS D DT1^BMCOSUT S BMCDOS=Y

 I F="N" Q BMCDOS

 Q BMCDOS

ACTDT(R,F) ;Actual End DOS

 NEW BMCDOS

 I $G(F)="" S F="E"

 S BMCDOS=""

 S BMCDOS=$P($G(^BMCREF(R,11)),U,8)

 I F="E",BMCDOS]"" S BMCDOS=$$FMTE^XLFDT(BMCDOS)

 I F="S",BMCDOS]"" S Y=BMCDOS D DT1^BMCOSUT S BMCDOS=Y

 I F="N" Q BMCDOS

 Q BMCDOS

 ;

RAIL(P,D) ;EP - Check for Railroad Retirement Data

 Q $$RRR^BMCRLU1(P,D)

CSECOM(R,D) ;EP -TEST FOR SORT BY, IF BY CSE COM DATES NEED TO TEST FOR DATES

 ;4.0 IHS/OIT/FCJ ADDED FOR CASE COMMENTS

 S X=1,Y=0  F  S Y=$O(^BMCRTMP(BMCRPT,11,Y)) Q:Y'?1N.N  D

 .S (X1,X2)=1

 .I $P(^BMCTSORT(Y,0),U)="Case Rev Comment Dt" D

 ..S X1=0,X3=$P(^BMCCOM(D,0),U)

 ..Q:X3<$P(^BMCRTMP(BMCRPT,11,Y,11,1,0),U)

 ..Q:X3>$P(^BMCRTMP(BMCRPT,11,Y,11,1,0),U,2)

 ..S X1=1

 .I $P(^BMCTSORT(Y,0),U)="Case Reviewer" D

 ..S X2=0

 ..S Y1=0 F  S Y1=$O(^BMCRTMP(BMCRPT,11,Y,11,Y1)) Q:Y1'?1N.N  D  Q:X2=1

 ...Q:$P(^BMCCOM(D,0),U,4)'=$P(^BMCRTMP(BMCRPT,11,Y,11,Y1,0),U)

 ...S X2=1

 .I 'X1!'X2 S X=0

 Q X

BMCRLU    ; IHS/PHXAO/TMJ - GEN RETR UTILITIES ;     

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ REMOVED THE () FOR PRINTING ACT OR EST; FX DT FORMAT

 +3       ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 +4       ;4.0*9 11.2.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE

 +5       ;

RZERO(V,L) ;ep right zero fill 

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=V_"0"

 +3        QUIT V

LZERO(V,L) ;left zero fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V="0"_V

 +3        QUIT V

LBLK(V,L) ;left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=" "_V

 +3        QUIT V

 +4       ;

ANYINS(P,D) ;EP - return 1 or 0 if patient has any insurance

 +1        NEW BMCA

 +2        SET BMCA=0

 +3        SET BMCA=$$MCR^AUPNPAT(P,D)

           IF BMCA

               QUIT BMCA

 +4        SET BMCA=$$MCD^AUPNPAT(P,D)

           IF BMCA

               QUIT BMCA

 +5        SET BMCA=$$PI^AUPNPAT(P,D)

           IF BMCA

               QUIT BMCA

 +6        SET BMCA=$$RAIL(P,D)

 +7        QUIT BMCA

AVDX(R,A,T) ;EP - return array of available dx's

 +1        NEW BMCFLG,BMCX

 +2        IF $GET(T)=""

               SET T="N"

 +3        SET BMCFLG=0

 +4        IF $GET(A)=""

               SET A="BMCAVDX"

 +5        KILL @A

 +6        IF 'R

               SET BMCFLG=1

               QUIT BMCFLG

 +7        IF '$DATA(^BMCREF(R))

               SET BMCFLG=2

               QUIT BMCFLG

 +8        SET (BMCX,C)=0

           FOR 

               SET BMCX=$ORDER(^BMCDX("AD",R,BMCX))

               IF BMCX'=+BMCX

                   QUIT 

               IF $PIECE(^BMCDX(BMCX,0),U,4)="F"

                   SET C=C+1

                   DO SETDX

 +9       ;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10 ADDED BMCDTYP="B" TO NXT LINE

 +10       IF C=0

               IF BMCDTYP="B"

                   SET BMCX=0

                   FOR 

                       SET BMCX=$ORDER(^BMCDX("AD",R,BMCX))

                       IF BMCX'=+BMCX

                           QUIT 

                       IF $PIECE(^BMCDX(BMCX,0),U,4)="P"

                           SET C=C+1

                           DO SETDX

 +11       QUIT BMCFLG

SETDX     ;

 +1        IF T="N"

               SET @A@($PIECE(^BMCDX(BMCX,0),U))=""

               QUIT 

 +2       ;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10

           NEW BMCCDI

           SET BMCCDI=$PIECE(^BMCDX(BMCX,0),U)

 +3       ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES;4.0*9 11.2.2012 IHS.OIT.FCJ CHG FOR ICD-10

 +4       ;I T="E" S @A@($P(^ICD9($P(^BMCDX(BMCX,0),U),0),U))="" Q

 +5       ;I T="E" S @A@($P($$ICDDX^ICDCODE($P(^BMCDX(BMCX,0),U),0),U,2))="" Q

 +6        IF T="E"

               SET @A@($PIECE($$ICDDX^ICDEX(BMCCDI,,,"I"),U,2))=""

               QUIT 

 +7       ;I T="I" S @A@($P(^ICD9($P(^BMCDX(BMCX,0),U),0),U,3))="" Q

 +8       ;I T="I" S @A@($P($$ICDDX^ICDCODE($P(^BMCDX(BMCX,0),U),0),U,4))="" Q

 +9        IF T="I"

               SET @A@($PIECE($$ICDDX^ICDEX(BMCCDI,,,"I"),U,4))=""

               QUIT 

 +10       QUIT 

AVOP(R,A,T) ;EP

 +1        NEW BMCFLG,BMCX

 +2        IF $GET(T)=""

               SET T="N"

 +3        SET BMCFLG=0

 +4        IF $GET(A)=""

               SET A="BMCAVOP"

 +5        KILL @A

 +6        IF 'R

               SET BMCFLG=1

               QUIT BMCFLG

 +7        IF '$DATA(^BMCREF(R))

               SET BMCFLG=2

               QUIT BMCFLG

 +8        SET (BMCX,C)=0

           FOR 

               SET BMCX=$ORDER(^BMCPX("AD",R,BMCX))

               IF BMCX'=+BMCX

                   QUIT 

               IF $PIECE(^BMCPX(BMCX,0),U,4)="F"

                   SET C=C+1

                   DO SETOP

 +9        IF C=0

               SET BMCX=0

               FOR 

                   SET BMCX=$ORDER(^BMCPX("AD",R,BMCX))

                   IF BMCX'=+BMCX

                       QUIT 

                   IF $PIECE(^BMCPX(BMCX,0),U,4)="P"

                       SET C=C+1

                       DO SETOP

 +10       QUIT BMCFLG

SETOP     ;

 +1        IF T="N"

               SET @A@($PIECE(^BMCPX(BMCX,0),U))=""

               QUIT 

 +2       ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 4 LINES

 +3       ;I T="E" S @A@($P(^ICPT($P(^BMCPX(BMCX,0),U),0),U))="" Q

 +4        IF T="E"

               SET @A@($PIECE($$CPT^ICPTCOD($PIECE(^BMCPX(BMCX,0),U),0),U,2))=""

               QUIT 

 +5       ;I T="I" S @A@($P(^ICPT($P(^BMCPX(BMCX,0),U),0),U,2))="" Q

 +6        IF T="I"

               SET @A@($PIECE($$CPT^ICPTCOD($PIECE(^BMCPX(BMCX,0),U),0),U,3))=""

               QUIT 

 +7        IF T="P"

               IF $PIECE(^BMCPX(BMCX,0),U,6)

                   SET @A@(BMCX)=$PIECE(^AUTNPOV($PIECE(^BMCPX(BMCX,0),U,6),0),U)

                   QUIT 

 +8        QUIT 

AVDOS(R,F) ;EP - return available date of service (actual or estimated) in either internal or external format

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$SELECT($PIECE($GET(^BMCREF(R,11)),U,6)]"":$PIECE(^BMCREF(R,11),U,6),1:$PIECE($GET(^BMCREF(R,11)),U,5))

 +5        IF BMCDOS=""

               QUIT BMCDOS

 +6        IF F="N"

               QUIT BMCDOS

 +7        IF F="E"

               SET BMCDOS=$$FMTE^XLFDT(BMCDOS,"2P")

 +8        IF F="S"

               SET BMCDOS=$EXTRACT(BMCDOS,4,5)_"/"_$EXTRACT(BMCDOS,6,7)_"/"_$EXTRACT(BMCDOS,2,3)

 +9        IF F="C"

               SET BMCDOS=$EXTRACT(BMCDOS,4,5)_"/"_$EXTRACT(BMCDOS,6,7)_"/"_$EXTRACT(BMCDOS,2,3)_" "_$SELECT($$VAL^XBDIQ1(90001,R,1106)]"":"A",1:"E")

 +10       QUIT BMCDOS

AVEOS(R,F) ;EP return available end date of service

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$SELECT($PIECE($GET(^BMCREF(R,11)),U,8)]"":$PIECE(^BMCREF(R,11),U,8),1:$PIECE($GET(^BMCREF(R,11)),U,7))

 +5        IF F="E"

               IF BMCDOS]""

                   SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +6        IF F="S"

               IF BMCDOS]""

                   SET Y=BMCDOS

                   DO DT1^BMCOSUT

                   SET BMCDOS=Y_" "_$SELECT($$VAL^XBDIQ1(90001,R,1106)]"":"A",1:"E")

 +7        IF F="N"

               QUIT BMCDOS

 +8        QUIT BMCDOS

AVLOS(R,F) ;EP return available LOS

 +1        IF $GET(F)=""

               SET F="I"

 +2        NEW %

 +3        SET %=$SELECT($PIECE($GET(^BMCREF(R,11)),U,10):$PIECE($GET(^BMCREF(R,11)),U,10),1:$PIECE($GET(^BMCREF(R,11)),U,9))

 +4        IF %=""

               QUIT %

 +5        IF F="C"

               SET %=%_$SELECT($PIECE($GET(^BMCREF(R,11)),U,10):" A",1:" E")

 +6        QUIT %

AVICOST(R) ; EP

 +1       ;best available IHS cost is 1104 if available, else the larger of

 +2       ;1103 or 1117

 +3        IF $GET(^BMCREF(R,11))=""

               QUIT ""

 +4        SET %=0

           FOR %1=4,3,17

               SET %=%+$PIECE(^BMCREF(R,11),U,%1)

 +5        IF '%

               QUIT ""

 +6        IF $PIECE(^BMCREF(R,11),U,4)

               QUIT $PIECE(^(11),U,4)

 +7        IF $PIECE(^BMCREF(R,11),U,3)>$PIECE(^BMCREF(R,11),U,17)

               QUIT $PIECE(^BMCREF(R,11),U,3)

 +8       IF '$TEST

               QUIT $PIECE(^BMCREF(R,11),U,17)

 +9        QUIT ""

 +10      ;

AVTCOST(R) ; EP

 +1       ;Final Total Referral Costs 1102 if available Else Estimated Total 

 +2       ;Costs 1101 Total Referral Cost to Date 1119 whichever is larger

 +3        IF $GET(^BMCREF(R,11))=""

               QUIT ""

 +4        SET %=0

           FOR %1=2,1,19

               SET %=%+$PIECE(^BMCREF(R,11),U,%1)

 +5        IF '%

               QUIT ""

 +6        IF $PIECE(^BMCREF(R,11),U,2)

               QUIT $PIECE(^(11),U,2)

 +7        IF $PIECE(^BMCREF(R,11),U)>$PIECE(^BMCREF(R,11),U,19)

               QUIT $PIECE(^BMCREF(R,11),U)

 +8       IF '$TEST

               QUIT $PIECE(^BMCREF(R,11),U,19)

 +9        QUIT ""

FACREF(R) ;EP return facility referred to (piece 7-8-9)

 +1        NEW BMCF,%

 +2        SET %=^BMCREF(R,0)

 +3        SET BMCF=$SELECT($PIECE(%,U,7):$PIECE($GET(^AUTTVNDR($PIECE(%,U,7),0)),U),$PIECE(%,U,8):$PIECE(^DIC(4,$PIECE(%,U,8),0),U),$PIECE(%,U,9):$PIECE($GET(^BMCLPRV($PIECE(%,U,9),0)),U),$PIECE(%,U,23):$PIECE(^DIC(40.7,$PIECE(%,U,23),0),U),1:"<UNKNOWN>"

)

 +4        QUIT BMCF

CASEMAN(R) ;EP return case manager

 +1        QUIT $SELECT($PIECE(^BMCREF(R,0),U,19)]"":$PIECE(^VA(200,$PIECE(^BMCREF(R,0),U,19),0),U),1:"??")

REFDTI(R,F) ; EP - Date Referral Initiated

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$SELECT($PIECE($GET(^BMCREF(R,0)),U)]"":$PIECE(^BMCREF(R,0),U),1:$PIECE($GET(^BMCREF(R,0)),U,6))

 +5        IF BMCDOS=""

               QUIT BMCDOS

 +6        IF F="E"

               SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +7        IF F="S"

               SET BMCDOS=$EXTRACT(BMCDOS,4,5)_"/"_$EXTRACT(BMCDOS,6,7)_"/"_$EXTRACT(BMCDOS,2,3)

 +8        IF F="C"

               SET BMCDOS=$EXTRACT(BMCDOS,4,5)_"/"_$EXTRACT(BMCDOS,6,7)_"/"_$EXTRACT(BMCDOS,2,3)_" "_$SELECT($$VAL^XBDIQ1(90001,R,.01)]"":"A",1:"E")

 +9        QUIT BMCDOS

 +10      ;

 +11      ;

EXPBGDT(R,F) ;Expected Begin Date of Service

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$PIECE($GET(^BMCREF(R,11)),U,5)

 +5        IF F="E"

               IF BMCDOS]""

                   SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +6        IF F="S"

               IF BMCDOS]""

                   SET Y=BMCDOS

                   DO DT1^BMCOSUT

                   SET BMCDOS=Y

 +7        IF F="N"

               QUIT BMCDOS

 +8        QUIT BMCDOS

 +9       ;

 +10      ;

EXPENDT(R,F) ;Expected End DOS

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$PIECE($GET(^BMCREF(R,11)),U,7)

 +5        IF F="E"

               IF BMCDOS]""

                   SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +6        IF F="S"

               IF BMCDOS]""

                   SET Y=BMCDOS

                   DO DT1^BMCOSUT

                   SET BMCDOS=Y

 +7        IF F="N"

               QUIT BMCDOS

 +8        QUIT BMCDOS

 +9       ;

ACTBDT(R,F) ;Actual Beginning DOS

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$PIECE($GET(^BMCREF(R,11)),U,6)

 +5        IF F="E"

               IF BMCDOS]""

                   SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +6        IF F="S"

               IF BMCDOS]""

                   SET Y=BMCDOS

                   DO DT1^BMCOSUT

                   SET BMCDOS=Y

 +7        IF F="N"

               QUIT BMCDOS

 +8        QUIT BMCDOS

ACTDT(R,F) ;Actual End DOS

 +1        NEW BMCDOS

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BMCDOS=""

 +4        SET BMCDOS=$PIECE($GET(^BMCREF(R,11)),U,8)

 +5        IF F="E"

               IF BMCDOS]""

                   SET BMCDOS=$$FMTE^XLFDT(BMCDOS)

 +6        IF F="S"

               IF BMCDOS]""

                   SET Y=BMCDOS

                   DO DT1^BMCOSUT

                   SET BMCDOS=Y

 +7        IF F="N"

               QUIT BMCDOS

 +8        QUIT BMCDOS

 +9       ;

RAIL(P,D) ;EP - Check for Railroad Retirement Data

 +1        QUIT $$RRR^BMCRLU1(P,D)

CSECOM(R,D) ;EP -TEST FOR SORT BY, IF BY CSE COM DATES NEED TO TEST FOR DATES

 +1       ;4.0 IHS/OIT/FCJ ADDED FOR CASE COMMENTS

 +2        SET X=1

           SET Y=0

           FOR 

               SET Y=$ORDER(^BMCRTMP(BMCRPT,11,Y))

               IF Y'?1N.N

                   QUIT 

               Begin DoDot:1

 +3                SET (X1,X2)=1

 +4                IF $PIECE(^BMCTSORT(Y,0),U)="Case Rev Comment Dt"

                       Begin DoDot:2

 +5                        SET X1=0

                           SET X3=$PIECE(^BMCCOM(D,0),U)

 +6                        IF X3<$PIECE(^BMCRTMP(BMCRPT,11,Y,11,1,0),U)

                               QUIT 

 +7                        IF X3>$PIECE(^BMCRTMP(BMCRPT,11,Y,11,1,0),U,2)

                               QUIT 

 +8                        SET X1=1

                       End DoDot:2

 +9                IF $PIECE(^BMCTSORT(Y,0),U)="Case Reviewer"

                       Begin DoDot:2

 +10                       SET X2=0

 +11                       SET Y1=0

                           FOR 

                               SET Y1=$ORDER(^BMCRTMP(BMCRPT,11,Y,11,Y1))

                               IF Y1'?1N.N

                                   QUIT 

                               Begin DoDot:3

 +12                               IF $PIECE(^BMCCOM(D,0),U,4)'=$PIECE(^BMCRTMP(BMCRPT,11,Y,11,Y1,0),U)

                                       QUIT 

 +13                               SET X2=1

                               End DoDot:3

                               IF X2=1

                                   QUIT 

                       End DoDot:2

 +14               IF 'X1!'X2

                       SET X=0

               End DoDot:1

 +15       QUIT X