- 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
