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
