BMCLKID2 ; IHS/OIT/FCJ - IDENTIFIERS FOR REFERRAL LOOKUP 3 ; [ 09/27/2006 2:03 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2**;JAN 09, 2006;Build 101
;4.0*2 IHS/OIT/FCJ Added Entry point for API rtn
; and test variable to screen closed variables and sec ref
;This Routine Displays Lookup for BMCREF Global
;This routine is called from ^BMCRDSP and if selected by patient name
;then display of last entered referral is displayed first
;
;At Lookup - Displays Date Initiated
; Referral Number
; Facility or Provider Referred To
; Purpose of Referral
; If Facility Referred to or Purpose are Null Displays UNKNOWN
;
START ; ENTRY POINT -
; IF DISPLAY SELECTED BY PATIENT AND LAST IN FIRST OUT DISPLAY OF REF
W !
S DIR(0)="FO^1:30"
S DIR("A")="Select RCIS REFERRAL by Patient or by Referral Date or #"
S DIR("?")="Enter the Patient name, Referral # or last 5 digits of referral # (and) secondary suffix."
D ^DIR K DIR Q:$D(DIRUT)!$D(DTOUT)
I Y=" " S Y=^DISV(DUZ,"^BMCREF(") G REFLKUP1
W !,Y S X=Y
I $E(Y,1)?1A D PATLKUP,XIT Q
REFLKUP ;
S DIC="^BMCREF(",DIC(0)="QEM",X=Y
D DIC^BMCFMC
Q:Y<1
REFLKUP1 S BMCRIEN=+Y
D XIT
Q
PATLKUP ;EP FOR PATIENT LOOK UP CALLED BY BMCAPI ;BMC*4.0*2 IHS/OIT/FCJ
S DIC="^AUPNPAT(",DIC(0)="QEM",X=Y
D DIC^BMCFMC
Q:Y<1
S BMCDFN=+Y,BMCREC("PAT NAME")=$P(^DPT(+Y,0),U)
REFDISP ;DISPLAY LATEST REFERRAL ENTERED-5 AT A TIME
S BMCFLG=1,BMCQ=1
I '$D(^BMCREF("AA",BMCDFN)) W !,"PATIENT DOES NOT HAVE ANY REFERRALS" Q
S BMCDT="",BMCCT=0,BMCRIENT="",BMCQ=0
F S BMCDT=$O(^BMCREF("AA",BMCDFN,BMCDT),-1) Q:BMCDT'?1N.N D Q:BMCQ
.S BMCRIEN=""
.F S BMCRIEN=$O(^BMCREF("AA",BMCDFN,BMCDT,BMCRIEN),-1) Q:BMCRIEN'?1N.N D Q:BMCQ
.. I $G(BMCAPI) Q:$P(^BMCREF(BMCRIEN,0),U,15)'="A"
.. I $G(BMCAPIS) Q:$P($G(^BMCREF(BMCRIEN,1)),U)'=""
.. S BMCCT=BMCCT+1,^TMP("BMCRDSP",$J,BMCCT)=BMCRIEN
.. D START^BMCLKID1
..I BMCCT#5=0 D CONT
I BMCCT#5'=0 D CONT
S:BMCRIENT BMCRIEN=BMCRIENT Q:BMCRIENT!$D(DUOUT)
I 'BMCRIENT S BMCQ=1
Q
CONT ;Ask to Continue
S DIR("A")="Select referral to display OR Return to continue"
S BMCQ=0
W !! S DIR(0)="NO^1:"_BMCCT
K DA D ^DIR K DIR
I $D(DUOUT) S BMCQ=1 Q
I Y>0 S BMCRIENT=$P(^TMP("BMCRDSP",$J,Y),U),BMCQ=1
Q
;
XIT ;Kill off Variables no longer needed
K BMCPAT,BMCPTDFN,BMCPURP,BMCPURPP,BMCRFAC,BMCSVDT,BMCSVDTP,BMCRDT,BMCRDTP,BMCRNUMB
K BMCFLG,BMCCT,^TMP("BMCRDSP",$J)
Q
;
BMCLKID2 ; IHS/OIT/FCJ - IDENTIFIERS FOR REFERRAL LOOKUP 3 ; [ 09/27/2006 2:03 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2**;JAN 09, 2006;Build 101
+2 ;4.0*2 IHS/OIT/FCJ Added Entry point for API rtn
+3 ; and test variable to screen closed variables and sec ref
+4 ;This Routine Displays Lookup for BMCREF Global
+5 ;This routine is called from ^BMCRDSP and if selected by patient name
+6 ;then display of last entered referral is displayed first
+7 ;
+8 ;At Lookup - Displays Date Initiated
+9 ; Referral Number
+10 ; Facility or Provider Referred To
+11 ; Purpose of Referral
+12 ; If Facility Referred to or Purpose are Null Displays UNKNOWN
+13 ;
START ; ENTRY POINT -
+1 ; IF DISPLAY SELECTED BY PATIENT AND LAST IN FIRST OUT DISPLAY OF REF
+2 WRITE !
+3 SET DIR(0)="FO^1:30"
+4 SET DIR("A")="Select RCIS REFERRAL by Patient or by Referral Date or #"
+5 SET DIR("?")="Enter the Patient name, Referral # or last 5 digits of referral # (and) secondary suffix."
+6 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+7 IF Y=" "
SET Y=^DISV(DUZ,"^BMCREF(")
GOTO REFLKUP1
+8 WRITE !,Y
SET X=Y
+9 IF $EXTRACT(Y,1)?1A
DO PATLKUP
DO XIT
QUIT
REFLKUP ;
+1 SET DIC="^BMCREF("
SET DIC(0)="QEM"
SET X=Y
+2 DO DIC^BMCFMC
+3 IF Y<1
QUIT
REFLKUP1 SET BMCRIEN=+Y
+1 DO XIT
+2 QUIT
PATLKUP ;EP FOR PATIENT LOOK UP CALLED BY BMCAPI ;BMC*4.0*2 IHS/OIT/FCJ
+1 SET DIC="^AUPNPAT("
SET DIC(0)="QEM"
SET X=Y
+2 DO DIC^BMCFMC
+3 IF Y<1
QUIT
+4 SET BMCDFN=+Y
SET BMCREC("PAT NAME")=$PIECE(^DPT(+Y,0),U)
REFDISP ;DISPLAY LATEST REFERRAL ENTERED-5 AT A TIME
+1 SET BMCFLG=1
SET BMCQ=1
+2 IF '$DATA(^BMCREF("AA",BMCDFN))
WRITE !,"PATIENT DOES NOT HAVE ANY REFERRALS"
QUIT
+3 SET BMCDT=""
SET BMCCT=0
SET BMCRIENT=""
SET BMCQ=0
+4 FOR
SET BMCDT=$ORDER(^BMCREF("AA",BMCDFN,BMCDT),-1)
IF BMCDT'?1N.N
QUIT
Begin DoDot:1
+5 SET BMCRIEN=""
+6 FOR
SET BMCRIEN=$ORDER(^BMCREF("AA",BMCDFN,BMCDT,BMCRIEN),-1)
IF BMCRIEN'?1N.N
QUIT
Begin DoDot:2
+7 IF $GET(BMCAPI)
IF $PIECE(^BMCREF(BMCRIEN,0),U,15)'="A"
QUIT
+8 IF $GET(BMCAPIS)
IF $PIECE($GET(^BMCREF(BMCRIEN,1)),U)'=""
QUIT
+9 SET BMCCT=BMCCT+1
SET ^TMP("BMCRDSP",$JOB,BMCCT)=BMCRIEN
+10 DO START^BMCLKID1
+11 IF BMCCT#5=0
DO CONT
End DoDot:2
IF BMCQ
QUIT
End DoDot:1
IF BMCQ
QUIT
+12 IF BMCCT#5'=0
DO CONT
+13 IF BMCRIENT
SET BMCRIEN=BMCRIENT
IF BMCRIENT!$DATA(DUOUT)
QUIT
+14 IF 'BMCRIENT
SET BMCQ=1
+15 QUIT
CONT ;Ask to Continue
+1 SET DIR("A")="Select referral to display OR Return to continue"
+2 SET BMCQ=0
+3 WRITE !!
SET DIR(0)="NO^1:"_BMCCT
+4 KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)
SET BMCQ=1
QUIT
+6 IF Y>0
SET BMCRIENT=$PIECE(^TMP("BMCRDSP",$JOB,Y),U)
SET BMCQ=1
+7 QUIT
+8 ;
XIT ;Kill off Variables no longer needed
+1 KILL BMCPAT,BMCPTDFN,BMCPURP,BMCPURPP,BMCRFAC,BMCSVDT,BMCSVDTP,BMCRDT,BMCRDTP,BMCRNUMB
+2 KILL BMCFLG,BMCCT,^TMP("BMCRDSP",$JOB)
+3 QUIT
+4 ;
