BMCLKID ; IHS/PHXAO/TMJ - IDENTIFIERS FOR REFERRAL LOOKUP 2 ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;IHS/ITSC/FCJ ADDED DISPLAY OF SEC VEND INFO; FX PAT DISPLAY
; Secondary provider exist then will display Date created,
; apt date, purpose and vendor
;
;This Routine Displays Lookup for BMCREF Global
;The DD(90001,0,"ID","IHS0") Runs this Routine
;At Lookup - Displays Date Initiated
; Referral Number
; Patient Name
; Facility or Provider Referred To
; Purpose of Referral
; If Facility Referred to or Purpose are Null Displays UNKNOWN
;
;
START ; EXTERNAL ENTRY POINT -
; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
W:$X>50 !
W ?5,$P(^(0),U,2),$P($G(^(1)),U)
W " "
;FILEMAN VERSION LOOKUP
S BMCPTDFN=$P(^(0),U,3) S BMCPAT=$P(^DPT(BMCPTDFN,0),U)
I $G(^DD("VERSION"))>21 D
. I $G(DZ)["?"!($G(X)=" ")!($G(DINDEX)="B")!($G(DINDEX)="BS1") W $E(BMCPAT,1,15)," " ;4.0 FCJ ADDED BS1
. E W " "
I $G(^DD("VERSION"))<22 D
. W $E(BMCPAT,1,15)," "
;W @("$E("_DIC_"Y,0),0)") ; reset the naked
S BMCRFAC=$$FACREF^BMCRLU(Y) W ?55,$E($S(BMCRFAC'="":BMCRFAC,1:"UNKNOWN"),1,25)
S BMCVST=$P($G(^BMCREF(Y,11)),U,11) S BMCVSTP=$S(BMCVST'="":BMCVST,1:"I")
W @("$E("_DIC_"Y,0),0)") ; reset the naked
;Returns either Estimated or Actual Beg Service Date
S BMCSVDT=$$AVDOS^BMCRLU(Y,"C") S BMCSVDTP=$S(BMCSVDT'="":BMCSVDT,1:"UNKNOWN SERVICE DATE") W !,?30,BMCSVDTP_" - "_BMCVSTP
W @("$E("_DIC_"Y,0),0)") ; reset the naked
;
S BMCPURP=$P($G(^BMCREF(Y,12)),U) S BMCPURPP=$S(BMCPURP'="":BMCPURP,1:"Purpose - NONE RECORDED") W ?55,$E(BMCPURPP,1,25)
W @("$E("_DIC_"Y,0),0)") ; reset the naked
W !
S BMCRNUMB=$P(^BMCREF(Y,0),U,2)
I $P($G(^BMCREF(Y,1)),U)="" D SEC
;W @("$E("_DIC_"Y,0),0)") ; reset the naked
XIT ;Kill off Variables no longer needed
K BMCPAT,BMCPTDFN,BMCPURP,BMCPURPP,BMCRFAC,BMCSVDT,BMCSVDTP
K BMCRIEN,BMCSEC
Q
SEC ;ENTRY POINT FR BMCLKID1; DISPLAY THE SECONDARY PROVIDER INFORMATION
Q:BMCRNUMB=""
I $D(^BMCREF("S",BMCRNUMB)) S BMCSUF=0 D
.F S BMCSUF=$O(^BMCREF("S",BMCRNUMB,BMCSUF)) Q:BMCSUF'?1A.N D
..S BMCSRIEN=0
..F S BMCSRIEN=$O(^BMCREF("S",BMCRNUMB,BMCSUF,BMCSRIEN)) Q:BMCSRIEN'?1N.N D
...S Y=$P(^BMCREF(BMCSRIEN,0),U) D DT^BMCOSUT S BMCSCDT=Y
...S Y=$S($P(^BMCREF(BMCSRIEN,11),U,6)'="":$P(^BMCREF(BMCSRIEN,11),U,6),1:$P(^BMCREF(BMCSRIEN,11),U,5)) D DT^BMCOSUT S BMCSRDT=Y
...S BMCSVND=""
...S:$P(^BMCREF(BMCSRIEN,0),U,7)'="" Y=$P(^BMCREF(BMCSRIEN,0),U,7),BMCSVND=$P(^AUTTVNDR(Y,0),U)
...I BMCSVND="",$P(^BMCREF(BMCSRIEN,0),U,8)'="" S Y=$P(^BMCREF(BMCSRIEN,0),U,8),BMCSVND=$P(^DIC(4,Y,0),U)
...S BMCSPUR=$$VAL^XBDIQ1(90001,BMCSRIEN,1201)
...W ?10,"SEC ",BMCSCDT," ",BMCSRDT," ",$E(BMCSPUR,1,15)," ",$E(BMCSVND,1,25)
...W !
K BMCSUF,BMCSRIEN,BMCSCDT,BMCSRDT,BMCSPUR,BMCSVND
Q
BMCLKID ; IHS/PHXAO/TMJ - IDENTIFIERS FOR REFERRAL LOOKUP 2 ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;IHS/ITSC/FCJ ADDED DISPLAY OF SEC VEND INFO; FX PAT DISPLAY
+3 ; Secondary provider exist then will display Date created,
+4 ; apt date, purpose and vendor
+5 ;
+6 ;This Routine Displays Lookup for BMCREF Global
+7 ;The DD(90001,0,"ID","IHS0") Runs this Routine
+8 ;At Lookup - Displays Date Initiated
+9 ; Referral Number
+10 ; Patient Name
+11 ; Facility or Provider Referred To
+12 ; Purpose of Referral
+13 ; If Facility Referred to or Purpose are Null Displays UNKNOWN
+14 ;
+15 ;
START ; EXTERNAL ENTRY POINT -
+1 ; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
+2 IF $X>50
WRITE !
+3 WRITE ?5,$PIECE(^(0),U,2),$PIECE($GET(^(1)),U)
+4 WRITE " "
+5 ;FILEMAN VERSION LOOKUP
+6 SET BMCPTDFN=$PIECE(^(0),U,3)
SET BMCPAT=$PIECE(^DPT(BMCPTDFN,0),U)
+7 IF $GET(^DD("VERSION"))>21
Begin DoDot:1
+8 ;4.0 FCJ ADDED BS1
IF $GET(DZ)["?"!($GET(X)=" ")!($GET(DINDEX)="B")!($GET(DINDEX)="BS1")
WRITE $EXTRACT(BMCPAT,1,15)," "
+9 IF '$TEST
WRITE " "
End DoDot:1
+10 IF $GET(^DD("VERSION"))<22
Begin DoDot:1
+11 WRITE $EXTRACT(BMCPAT,1,15)," "
End DoDot:1
+12 ;W @("$E("_DIC_"Y,0),0)") ; reset the naked
+13 SET BMCRFAC=$$FACREF^BMCRLU(Y)
WRITE ?55,$EXTRACT($SELECT(BMCRFAC'="":BMCRFAC,1:"UNKNOWN"),1,25)
+14 SET BMCVST=$PIECE($GET(^BMCREF(Y,11)),U,11)
SET BMCVSTP=$SELECT(BMCVST'="":BMCVST,1:"I")
+15 ; reset the naked
WRITE @("$E("_DIC_"Y,0),0)")
+16 ;Returns either Estimated or Actual Beg Service Date
+17 SET BMCSVDT=$$AVDOS^BMCRLU(Y,"C")
SET BMCSVDTP=$SELECT(BMCSVDT'="":BMCSVDT,1:"UNKNOWN SERVICE DATE")
WRITE !,?30,BMCSVDTP_" - "_BMCVSTP
+18 ; reset the naked
WRITE @("$E("_DIC_"Y,0),0)")
+19 ;
+20 SET BMCPURP=$PIECE($GET(^BMCREF(Y,12)),U)
SET BMCPURPP=$SELECT(BMCPURP'="":BMCPURP,1:"Purpose - NONE RECORDED")
WRITE ?55,$EXTRACT(BMCPURPP,1,25)
+21 ; reset the naked
WRITE @("$E("_DIC_"Y,0),0)")
+22 WRITE !
+23 SET BMCRNUMB=$PIECE(^BMCREF(Y,0),U,2)
+24 IF $PIECE($GET(^BMCREF(Y,1)),U)=""
DO SEC
+25 ;W @("$E("_DIC_"Y,0),0)") ; reset the naked
XIT ;Kill off Variables no longer needed
+1 KILL BMCPAT,BMCPTDFN,BMCPURP,BMCPURPP,BMCRFAC,BMCSVDT,BMCSVDTP
+2 KILL BMCRIEN,BMCSEC
+3 QUIT
SEC ;ENTRY POINT FR BMCLKID1; DISPLAY THE SECONDARY PROVIDER INFORMATION
+1 IF BMCRNUMB=""
QUIT
+2 IF $DATA(^BMCREF("S",BMCRNUMB))
SET BMCSUF=0
Begin DoDot:1
+3 FOR
SET BMCSUF=$ORDER(^BMCREF("S",BMCRNUMB,BMCSUF))
IF BMCSUF'?1A.N
QUIT
Begin DoDot:2
+4 SET BMCSRIEN=0
+5 FOR
SET BMCSRIEN=$ORDER(^BMCREF("S",BMCRNUMB,BMCSUF,BMCSRIEN))
IF BMCSRIEN'?1N.N
QUIT
Begin DoDot:3
+6 SET Y=$PIECE(^BMCREF(BMCSRIEN,0),U)
DO DT^BMCOSUT
SET BMCSCDT=Y
+7 SET Y=$SELECT($PIECE(^BMCREF(BMCSRIEN,11),U,6)'="":$PIECE(^BMCREF(BMCSRIEN,11),U,6),1:$PIECE(^BMCREF(BMCSRIEN,11),U,5))
DO DT^BMCOSUT
SET BMCSRDT=Y
+8 SET BMCSVND=""
+9 IF $PIECE(^BMCREF(BMCSRIEN,0),U,7)'=""
SET Y=$PIECE(^BMCREF(BMCSRIEN,0),U,7)
SET BMCSVND=$PIECE(^AUTTVNDR(Y,0),U)
+10 IF BMCSVND=""
IF $PIECE(^BMCREF(BMCSRIEN,0),U,8)'=""
SET Y=$PIECE(^BMCREF(BMCSRIEN,0),U,8)
SET BMCSVND=$PIECE(^DIC(4,Y,0),U)
+11 SET BMCSPUR=$$VAL^XBDIQ1(90001,BMCSRIEN,1201)
+12 WRITE ?10,"SEC ",BMCSCDT," ",BMCSRDT," ",$EXTRACT(BMCSPUR,1,15)," ",$EXTRACT(BMCSVND,1,25)
+13 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL BMCSUF,BMCSRIEN,BMCSCDT,BMCSRDT,BMCSPUR,BMCSVND
+15 QUIT
