BSDU2 ; IHS/ANMC/LJF - IHS UTILITY CALLS-APPT INFO ; [ 12/22/2003 8:37 AM ]
;;5.3;PIMS;**1004,1005,1010**;MAY 28, 2004
;IHS/OIT/LJF 11/03/2005 PATCH 1004 added EP to BOFF and BON subroutines
;IHS/OIT/LJF 12/29/2005 PATCH 1005 removed BOFF and BON subroutines - no longer needed
;cmi/anch/maw 11/20/2008 PATCH 1010 added print of no shows if parameter turned on
;
SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
NEW X,IEN
S X=0 F S X=$O(^SC(CLINIC,"S",DATE,1,X)) Q:'X Q:$G(IEN) D
. Q:$P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,9)="C" ;cancelled
. I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
Q $G(IEN)
;
OI(PAT,CLINIC,DATE) ;PEP; returns other info comments for patient's appt
NEW X
S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q ""
Q $P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,4)
;
APPTYP(PAT,DATE) ;PEP; -- returns type of appt (scheduled or walk-in)
NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
;
WALKIN(PAT,DATE) ;PEP; -- returns 1 if appt is walk-in
Q $S($P($G(^DPT(PAT,"S",DATE,0)),U,7)=4:1,1:0)
;
CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U)
Q $S(X:1,1:0)
;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
Q $S(X:1,1:0)
;
GETVST(PAT,DATE) ;PEP; returns visit ien for appt date and patient
NEW X
I ('PAT)!('DATE) Q 0
S X=$G(^DPT(PAT,"S",DATE,0)) I 'X Q 0 ;appt node
S X=$P(X,U,20) I 'X Q 0 ;outpt encounter ptr
S X=$G(^SCE(X,0)) I 'X Q 0 ;outpt encounter node
I $P(X,U,2)'=PAT Q 0 ;patient ptr
Q $P(X,U,5) ;visit ptr
;
PEND(DFN,BSDTALK,BSDARRAY) ;PEP - description follows:
; called by SDAM2 & AMER1 to display pending appts
; BSDTALK=1 means display results to current device
; BSDTALK=0 means be silent
; BSDARRAY if set, is array for returning data found
; array(2-9999)=date^clinic name^other info
;
NEW BSDLN,BSDT,BSDCNT,X,I,NODE,BSDSP
S BSDSP=$S(BSDTALK:" ",1:U) ;data item separator
S BSDCNT=1,BSDT=$$NOW^XLFDT ;start with now
F S BSDT=$O(^DPT(DFN,"S",BSDT)) Q:'BSDT D
. S NODE=$G(^DPT(DFN,"S",BSDT,0)) Q:'NODE
. ;
. Q:$P(NODE,U,2)["C" ;skip if canceled
. I $P(NODE,U,2)["N",$P(NODE,U,2)'="NT" Q ;skip if no-show
. ;
. ; if lab, x-ray or ekg appts set, display first
. F I=3,4,5 S X=$P(NODE,U,I) Q:X["" D
.. S BSDCNT=BSDCNT+1
.. S BSDLN(BSDCNT)=$$FMTE^XLFDT(X)_BSDSP_$P("LAB^X-RAY^EKG",U,I-2)
. ;
. ; then display this appt
. S BSDCNT=$G(BSDCNT)+1
. S X=$$FMTE^XLFDT(BSDT)_BSDSP_$$GET1^DIQ(44,+NODE,.01)
. S BSDLN(BSDCNT)=$$PAD(X,43)_BSDSP_$E($$OI^BSDU2(DFN,+NODE,BSDT),1,34)
. S BSDLN(BSDCNT,0)=+NODE
;
I BSDCNT>1 D
. S BSDLN(1,"F")="!!?20",BSDLN(1)="**** PENDING APPOINTMENTS ****"
. F I=1:1:BSDCNT S BSDLN(BSDCNT,"F")="!"
E D
. S BSDLN(1)="No Pending Appointments",BSDLN(1,"F")="!"
;
I $G(BSDTALK) D EN^DDIOL(.BSDLN) ;print to current device
;
I $G(BSDARRAY)]"" D Q ;return data in array
. NEW %X,%Y S %X="BSDLN(",%Y=BSDARRAY D %XY^%RCR
Q
;
APPT(PAT,CLN,DATE,LEN) ;EP; called by SDM1A to display appt made
D MSG^BDGF($$SP(3)_$$REPEAT^XLFSTR("*",60),2,0)
D MSG^BDGF($$SP(5)_LEN_"-MIN. APPOINTMENT MADE FOR "_$$GET1^DIQ(2,PAT,.01),1,0)
D MSG^BDGF($$SP(5)_"IN "_$$GET1^DIQ(44,CLN,.01)_" CLINIC FOR "_$$FMTE^XLFDT(DATE),1,0)
D MSG^BDGF($$SP(3)_$$REPEAT^XLFSTR("*",60),1,1)
Q
;
NOSHOW(DFN,CLINIC) ;EP; -- called to print # noshows for patient
; will count patient's no-shows in this clinic & principal clinic
; date range for search is based on division and clinic parameters
NEW PRINC,TOTL,NOCLN,PCNT,LMT,LMT2,X,X1,X2,APPDT,LINE,LASTNOS
Q:'$G(DFN) Q:'$G(CLINIC)
S PRINC=$P($G(^SC(+CLINIC,"SL")),U,5) ;princ clinic
S (TOTL,NOCLN,PCNT)=0
S LMT=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.15) ;division limit
I 'LMT S LMT=365
S LMT2=$$GET1^DIQ(9009017.2,+CLINIC,.03) ;clinic limit
S LMT2=$S(LMT2="":LMT,1:LMT2) ;clinic overrides div
;
; loop by division date limit to get patient's total no-shows for site
S X1=DT,X2=-LMT D C^%DTC S APPDT=X
F S APPDT=$O(^DPT(DFN,"S",APPDT)) Q:'APPDT D
. S X=$P(^DPT(DFN,"S",APPDT,0),U,2) Q:(X="NT") Q:(X'["N")
. S TOTL=TOTL+1
;
; loop by clinic date range for clinic specific totals
S X1=DT,X2=-LMT2 D C^%DTC S APPDT=X
F S APPDT=$O(^DPT(DFN,"S",APPDT)) Q:'APPDT D
. S X=$P(^DPT(DFN,"S",APPDT,0),U,2) Q:(X="NT") Q:(X'["N")
. ;
. ; if appt for specified clinic, add to subtotal & set last no-show
. I +^DPT(DFN,"S",APPDT,0)=+CLINIC D
.. S NOCLN=NOCLN+1,LASTNOS=$$LASTNOS(DFN,CLINIC,APPDT)
. ;
. ; if part of specified principal clinic, add to its subtotal
. I PRINC]"",$D(^SC("AIHSPC",+PRINC,+^DPT(DFN,"S",APPDT,0))) S PCNT=PCNT+1
;
; set up display lines for totals and subtotals
I TOTL>0!(NOCLN>0)!(PCNT>0) D
. S LINE(1)="Total No-shows (ALL clinics) in last "_(LMT\30)_" months:"
. S LINE(1)=$$PAD(LINE(1),50)_TOTL,LINE(1,"F")="!!"
. I PRINC]"" D
.. S LINE(2)="No-shows in principal clinic (last "_(LMT2\30)
.. S LINE(2)=$$PAD(LINE(2)_" months):",50)_PCNT,LINE(2,"F")="!"
. S X=$S(PRINC]"":3,1:2) ;line number
. S LINE(X)="No-shows in this clinic (last "_(LMT2\30)_" months):"
. S LINE(X)=$$PAD(LINE(X),50)_NOCLN,LINE(X,"F")="!"
. I $G(LASTNOS)]"" S LINE(X+1)="Last No-Show in this clinic: "_LASTNOS
. S LINE(X+1,"F")="!",LINE(X+2,"F")="!"
. D EN^DDIOL(.LINE)
. D NOSHOWA ;cmi/maw 11/20/2008 PATCH 1010 RQMT 2
Q
;
LASTNOS(PAT,CLINIC,DATE) ; -- returns appt display line
NEW X,Y,Z
S X=$$FMTE^XLFDT(DATE,2)_" " ;appt date/time
; get info out of hospital location file entry
S Y=0 F S Y=$O(^SC(+CLINIC,"S",DATE,1,Y)) Q:'Y!$D(Z) D
. Q:$P(^SC(+CLINIC,"S",DATE,1,Y,0),U)'=PAT
. S Z=^SC(+CLINIC,"S",DATE,1,Y,0)
. S X=X_$P(Z,U,2)_"MIN "_$E($P(Z,U,4),1,25) ;appt length&other info
Q X
;
NOSHOWA ;-- ask to print no show list PATCH 1010 RQMT 2
N BSDNSD
S BSDNSD=$$READ^BDGF("YO","Display No Shows","NO")
Q:BSDNSD=U
Q:'BSDNSD ;cmi/maw 08/31/2009 PATCH 1010
W !!,"NO SHOWS FOR PATIENT: "_$$GET1^DIQ(2,DFN,.01)
W !!,"Date",?25,"Clinic"
N BSDDA
S BSDDA=0 F S BSDDA=$O(^DPT(DFN,"S",BSDDA)) Q:'BSDDA D
. N BSDDATA
. S BSDDATA=$G(^DPT(DFN,"S",BSDDA,0))
. Q:$P(BSDDATA,U,2)'="N"
. W !,$$FMTE^XLFDT(BSDDA),?25,$$GET1^DIQ(44,$P(BSDDATA,U),.01)
Q
;
PAD(D,L) ; -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BSDU2 ; IHS/ANMC/LJF - IHS UTILITY CALLS-APPT INFO ; [ 12/22/2003 8:37 AM ]
+1 ;;5.3;PIMS;**1004,1005,1010**;MAY 28, 2004
+2 ;IHS/OIT/LJF 11/03/2005 PATCH 1004 added EP to BOFF and BON subroutines
+3 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 removed BOFF and BON subroutines - no longer needed
+4 ;cmi/anch/maw 11/20/2008 PATCH 1010 added print of no shows if parameter turned on
+5 ;
SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
+1 NEW X,IEN
+2 SET X=0
FOR
SET X=$ORDER(^SC(CLINIC,"S",DATE,1,X))
IF 'X
QUIT
IF $GET(IEN)
QUIT
Begin DoDot:1
+3 ;cancelled
IF $PIECE($GET(^SC(CLINIC,"S",DATE,1,X,0)),U,9)="C"
QUIT
+4 IF +$GET(^SC(CLINIC,"S",DATE,1,X,0))=PAT
SET IEN=X
End DoDot:1
+5 QUIT $GET(IEN)
+6 ;
OI(PAT,CLINIC,DATE) ;PEP; returns other info comments for patient's appt
+1 NEW X
+2 SET X=$$SCIEN(PAT,CLINIC,DATE)
IF 'X
QUIT ""
+3 QUIT $PIECE($GET(^SC(CLINIC,"S",DATE,1,X,0)),U,4)
+4 ;
APPTYP(PAT,DATE) ;PEP; -- returns type of appt (scheduled or walk-in)
+1 NEW X
SET X=$PIECE($GET(^DPT(PAT,"S",DATE,0)),U,7)
+2 QUIT $SELECT(X=3:"SCHED",X=4:"WALK-IN",1:"??")
+3 ;
WALKIN(PAT,DATE) ;PEP; -- returns 1 if appt is walk-in
+1 QUIT $SELECT($PIECE($GET(^DPT(PAT,"S",DATE,0)),U,7)=4:1,1:0)
+2 ;
CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
+1 NEW X
+2 ;ien sent in call
SET X=$GET(SDIEN)
+3 IF 'X
SET X=$$SCIEN(PAT,CLINIC,DATE)
IF 'X
QUIT 0
+4 SET X=$PIECE($GET(^SC(CLINIC,"S",DATE,1,X,"C")),U)
+5 QUIT $SELECT(X:1,1:0)
+6 ;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
+1 NEW X
+2 ;ien sent in call
SET X=$GET(SDIEN)
+3 IF 'X
SET X=$$SCIEN(PAT,CLINIC,DATE)
IF 'X
QUIT 0
+4 SET X=$PIECE($GET(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
+5 QUIT $SELECT(X:1,1:0)
+6 ;
GETVST(PAT,DATE) ;PEP; returns visit ien for appt date and patient
+1 NEW X
+2 IF ('PAT)!('DATE)
QUIT 0
+3 ;appt node
SET X=$GET(^DPT(PAT,"S",DATE,0))
IF 'X
QUIT 0
+4 ;outpt encounter ptr
SET X=$PIECE(X,U,20)
IF 'X
QUIT 0
+5 ;outpt encounter node
SET X=$GET(^SCE(X,0))
IF 'X
QUIT 0
+6 ;patient ptr
IF $PIECE(X,U,2)'=PAT
QUIT 0
+7 ;visit ptr
QUIT $PIECE(X,U,5)
+8 ;
PEND(DFN,BSDTALK,BSDARRAY) ;PEP - description follows:
+1 ; called by SDAM2 & AMER1 to display pending appts
+2 ; BSDTALK=1 means display results to current device
+3 ; BSDTALK=0 means be silent
+4 ; BSDARRAY if set, is array for returning data found
+5 ; array(2-9999)=date^clinic name^other info
+6 ;
+7 NEW BSDLN,BSDT,BSDCNT,X,I,NODE,BSDSP
+8 ;data item separator
SET BSDSP=$SELECT(BSDTALK:" ",1:U)
+9 ;start with now
SET BSDCNT=1
SET BSDT=$$NOW^XLFDT
+10 FOR
SET BSDT=$ORDER(^DPT(DFN,"S",BSDT))
IF 'BSDT
QUIT
Begin DoDot:1
+11 SET NODE=$GET(^DPT(DFN,"S",BSDT,0))
IF 'NODE
QUIT
+12 ;
+13 ;skip if canceled
IF $PIECE(NODE,U,2)["C"
QUIT
+14 ;skip if no-show
IF $PIECE(NODE,U,2)["N"
IF $PIECE(NODE,U,2)'="NT"
QUIT
+15 ;
+16 ; if lab, x-ray or ekg appts set, display first
+17 FOR I=3,4,5
SET X=$PIECE(NODE,U,I)
IF X[""
QUIT
Begin DoDot:2
+18 SET BSDCNT=BSDCNT+1
+19 SET BSDLN(BSDCNT)=$$FMTE^XLFDT(X)_BSDSP_$PIECE("LAB^X-RAY^EKG",U,I-2)
End DoDot:2
+20 ;
+21 ; then display this appt
+22 SET BSDCNT=$GET(BSDCNT)+1
+23 SET X=$$FMTE^XLFDT(BSDT)_BSDSP_$$GET1^DIQ(44,+NODE,.01)
+24 SET BSDLN(BSDCNT)=$$PAD(X,43)_BSDSP_$EXTRACT($$OI^BSDU2(DFN,+NODE,BSDT),1,34)
+25 SET BSDLN(BSDCNT,0)=+NODE
End DoDot:1
+26 ;
+27 IF BSDCNT>1
Begin DoDot:1
+28 SET BSDLN(1,"F")="!!?20"
SET BSDLN(1)="**** PENDING APPOINTMENTS ****"
+29 FOR I=1:1:BSDCNT
SET BSDLN(BSDCNT,"F")="!"
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 SET BSDLN(1)="No Pending Appointments"
SET BSDLN(1,"F")="!"
End DoDot:1
+32 ;
+33 ;print to current device
IF $GET(BSDTALK)
DO EN^DDIOL(.BSDLN)
+34 ;
+35 ;return data in array
IF $GET(BSDARRAY)]""
Begin DoDot:1
+36 NEW %X,%Y
SET %X="BSDLN("
SET %Y=BSDARRAY
DO %XY^%RCR
End DoDot:1
QUIT
+37 QUIT
+38 ;
APPT(PAT,CLN,DATE,LEN) ;EP; called by SDM1A to display appt made
+1 DO MSG^BDGF($$SP(3)_$$REPEAT^XLFSTR("*",60),2,0)
+2 DO MSG^BDGF($$SP(5)_LEN_"-MIN. APPOINTMENT MADE FOR "_$$GET1^DIQ(2,PAT,.01),1,0)
+3 DO MSG^BDGF($$SP(5)_"IN "_$$GET1^DIQ(44,CLN,.01)_" CLINIC FOR "_$$FMTE^XLFDT(DATE),1,0)
+4 DO MSG^BDGF($$SP(3)_$$REPEAT^XLFSTR("*",60),1,1)
+5 QUIT
+6 ;
NOSHOW(DFN,CLINIC) ;EP; -- called to print # noshows for patient
+1 ; will count patient's no-shows in this clinic & principal clinic
+2 ; date range for search is based on division and clinic parameters
+3 NEW PRINC,TOTL,NOCLN,PCNT,LMT,LMT2,X,X1,X2,APPDT,LINE,LASTNOS
+4 IF '$GET(DFN)
QUIT
IF '$GET(CLINIC)
QUIT
+5 ;princ clinic
SET PRINC=$PIECE($GET(^SC(+CLINIC,"SL")),U,5)
+6 SET (TOTL,NOCLN,PCNT)=0
+7 ;division limit
SET LMT=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.15)
+8 IF 'LMT
SET LMT=365
+9 ;clinic limit
SET LMT2=$$GET1^DIQ(9009017.2,+CLINIC,.03)
+10 ;clinic overrides div
SET LMT2=$SELECT(LMT2="":LMT,1:LMT2)
+11 ;
+12 ; loop by division date limit to get patient's total no-shows for site
+13 SET X1=DT
SET X2=-LMT
DO C^%DTC
SET APPDT=X
+14 FOR
SET APPDT=$ORDER(^DPT(DFN,"S",APPDT))
IF 'APPDT
QUIT
Begin DoDot:1
+15 SET X=$PIECE(^DPT(DFN,"S",APPDT,0),U,2)
IF (X="NT")
QUIT
IF (X'["N")
QUIT
+16 SET TOTL=TOTL+1
End DoDot:1
+17 ;
+18 ; loop by clinic date range for clinic specific totals
+19 SET X1=DT
SET X2=-LMT2
DO C^%DTC
SET APPDT=X
+20 FOR
SET APPDT=$ORDER(^DPT(DFN,"S",APPDT))
IF 'APPDT
QUIT
Begin DoDot:1
+21 SET X=$PIECE(^DPT(DFN,"S",APPDT,0),U,2)
IF (X="NT")
QUIT
IF (X'["N")
QUIT
+22 ;
+23 ; if appt for specified clinic, add to subtotal & set last no-show
+24 IF +^DPT(DFN,"S",APPDT,0)=+CLINIC
Begin DoDot:2
+25 SET NOCLN=NOCLN+1
SET LASTNOS=$$LASTNOS(DFN,CLINIC,APPDT)
End DoDot:2
+26 ;
+27 ; if part of specified principal clinic, add to its subtotal
+28 IF PRINC]""
IF $DATA(^SC("AIHSPC",+PRINC,+^DPT(DFN,"S",APPDT,0)))
SET PCNT=PCNT+1
End DoDot:1
+29 ;
+30 ; set up display lines for totals and subtotals
+31 IF TOTL>0!(NOCLN>0)!(PCNT>0)
Begin DoDot:1
+32 SET LINE(1)="Total No-shows (ALL clinics) in last "_(LMT\30)_" months:"
+33 SET LINE(1)=$$PAD(LINE(1),50)_TOTL
SET LINE(1,"F")="!!"
+34 IF PRINC]""
Begin DoDot:2
+35 SET LINE(2)="No-shows in principal clinic (last "_(LMT2\30)
+36 SET LINE(2)=$$PAD(LINE(2)_" months):",50)_PCNT
SET LINE(2,"F")="!"
End DoDot:2
+37 ;line number
SET X=$SELECT(PRINC]"":3,1:2)
+38 SET LINE(X)="No-shows in this clinic (last "_(LMT2\30)_" months):"
+39 SET LINE(X)=$$PAD(LINE(X),50)_NOCLN
SET LINE(X,"F")="!"
+40 IF $GET(LASTNOS)]""
SET LINE(X+1)="Last No-Show in this clinic: "_LASTNOS
+41 SET LINE(X+1,"F")="!"
SET LINE(X+2,"F")="!"
+42 DO EN^DDIOL(.LINE)
+43 ;cmi/maw 11/20/2008 PATCH 1010 RQMT 2
DO NOSHOWA
End DoDot:1
+44 QUIT
+45 ;
LASTNOS(PAT,CLINIC,DATE) ; -- returns appt display line
+1 NEW X,Y,Z
+2 ;appt date/time
SET X=$$FMTE^XLFDT(DATE,2)_" "
+3 ; get info out of hospital location file entry
+4 SET Y=0
FOR
SET Y=$ORDER(^SC(+CLINIC,"S",DATE,1,Y))
IF 'Y!$DATA(Z)
QUIT
Begin DoDot:1
+5 IF $PIECE(^SC(+CLINIC,"S",DATE,1,Y,0),U)'=PAT
QUIT
+6 SET Z=^SC(+CLINIC,"S",DATE,1,Y,0)
+7 ;appt length&other info
SET X=X_$PIECE(Z,U,2)_"MIN "_$EXTRACT($PIECE(Z,U,4),1,25)
End DoDot:1
+8 QUIT X
+9 ;
NOSHOWA ;-- ask to print no show list PATCH 1010 RQMT 2
+1 NEW BSDNSD
+2 SET BSDNSD=$$READ^BDGF("YO","Display No Shows","NO")
+3 IF BSDNSD=U
QUIT
+4 ;cmi/maw 08/31/2009 PATCH 1010
IF 'BSDNSD
QUIT
+5 WRITE !!,"NO SHOWS FOR PATIENT: "_$$GET1^DIQ(2,DFN,.01)
+6 WRITE !!,"Date",?25,"Clinic"
+7 NEW BSDDA
+8 SET BSDDA=0
FOR
SET BSDDA=$ORDER(^DPT(DFN,"S",BSDDA))
IF 'BSDDA
QUIT
Begin DoDot:1
+9 NEW BSDDATA
+10 SET BSDDATA=$GET(^DPT(DFN,"S",BSDDA,0))
+11 IF $PIECE(BSDDATA,U,2)'="N"
QUIT
+12 WRITE !,$$FMTE^XLFDT(BSDDA),?25,$$GET1^DIQ(44,$PIECE(BSDDATA,U),.01)
End DoDot:1
+13 QUIT
+14 ;
PAD(D,L) ; -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
