BSDROUT0 ; IHS/ANMC/LJF - ROUTING SLIPS CALC ; [ 08/20/2004 11:57 AM ]
;;5.3;PIMS;**1001,1004**;MAY 28, 2004
;IHS/OIT/LJF 11/03/2005 PATCH 1004 added EP to FIRST subroutine
;
FIND(CLN,APPT,APPN,ORDER,BSDMODE) ;EP; -- set up ^tmp sort for patient's appt
; called by START^BSDROUT and SINGLE^BSDROUT
; assumes SD variables SDX,SDSTART,SDREP,SDATE are set
; CLN=clinic ien, APPT=appt date/time, APPN=appt ien in ^SC
; ORDER=1 means sort by terminal digit (or chart # per site param)
; ORDER=2 means sort by clinic; ORDER=3 means sort by principal clinic
; ORDER=4 means sort by name; ORDER="" means single routing slip
; BSDMODE="WI" for walkins, "SD" for same day, "" for all others
; BSDMODE="CR" used for chart requests in routine BSDROUT
;
;
NEW DFN,HRCN,TERM,FIRST
NEW BSDSC,BSDGD,BSDL
S DFN=$P(^SC(CLN,"S",APPT,1,APPN,0),U) ;patient ien
S HRCN=$$HRCN^BDGF2(DFN,$$FAC^BSDU(CLN)) ;chart #
S TERM=$$HRCNT^BDGF2(HRCN) ;terminal digit format
I $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(CLN),.18)="NO" D
. S TERM=$$HRCND^BDGF2(HRCN) ;use chart # per site param
;
Q:'$$PRTOK(DFN,APPT,TERM) ;okay to print this appt?
;
S FIRST=$$FIRST(DFN,APPT) ;first appt that day?
;
D STOPS(DFN,APPT,CLN,TERM,ORDER) ;xray, lab, ekg stops
I ORDER=1 D TDO(DFN,APPT,CLN,TERM,"",FIRST) Q
I ORDER=2 D CLO(DFN,APPT,CLN,TERM,"",FIRST) Q
I ORDER=3 D PCO(DFN,APPT,CLN,TERM,"",FIRST) Q
D NMO(DFN,APPT,CLN,TERM,"",FIRST) Q
;
TDO(P,D,C,T,S,F) ; -- sort by terminal digit
I $G(F) S ^TMP("SDRS",$J," "_T," "_T,P)=1 ;1st for patient for date
S ^TMP("SDRS",$J," "_T," "_T,P,D)=C_U_$G(S)_U_$G(BSDMODE)
Q
;
CLO(P,D,C,T,S,F) ; -- sort by clinic
NEW N S N=$$GET1^DIQ(44,C,.01) Q:N="" ;clinic name
I SDX["ALL",SDSTART]"",SDSTART]N Q ;not in print range
I SDX["ALL",SDSTOP]"",N]SDSTOP Q ;not in print range
;
;IHS/ITSC/LJF 4/2/2004 set to find all appts later
;I $G(F) S ^TMP("SDRS",$J,N," "_T,P)=1 ;1st for patient for date
I $G(F),'$D(^TMP("SDRS",$J,P)) S ^TMP("SDRS",$J,P,N)=1 ;1st for patient for date
S ^TMP("SDRS1",$J,P,D)=N
;IHS/ITSC/LJF 4/2/2004 end of changes
;
S ^TMP("SDRS",$J,N," "_T,P,D)=C_U_$G(S)_U_$G(BSDMODE)
Q
;
PCO(P,D,C,T,S,F) ; -- sort by principal clinic
;IHS/ITSC/LJF 4/8/2004 rewrote subroutine to use clinic name for unaffiliated clinics
NEW PRINC S PRINC=$$PRIN^BSDU(C)
I PRINC="UNAFFILIATED CLINICS" S PRINC=$$GET1^DIQ(44,+C,.01)
I SDX["ALL",SDSTART]"",SDSTART]PRINC Q ;not print range
I SDX["ALL",SDSTOP]"",PRINC]SDSTOP Q ;not print range
;
I $G(F),'$D(^TMP("SDRS",$J,P)) S ^TMP("SDRS",$J,P,PRINC)=1 ;1st 4 pat 4 dt
S ^TMP("SDRS1",$J,P,D)=PRINC ;sort by patient then date/time
;
S ^TMP("SDRS",$J,PRINC," "_T,P,D)=C_U_$G(S)_U_$G(BSDMODE)
Q
;
NMO(P,D,C,T,S,F) ; -- sort by name
NEW N S N=$$GET1^DIQ(2,P,.01) ;patient name
I $G(F) S ^TMP("SDRS",$J,N," "_T,P)=1 ;1st for patient for date
S ^TMP("SDRS",$J,N," "_T,P,D)=C_U_$G(S)_U_$G(BSDMODE)
Q
;
;
STOPS(P,D,C,T,ORDER) ; checks for xray, lab or ekg stops
NEW I,A,STOP
F I=3,4,5 I $P(^DPT(P,"S",D,0),U,I)]"" D
. S A=$P(^DPT(P,"S",D,0),U,I),STOP=$S(I=3:"LAB",I=4:"XRAY",1:"EKG")
. I ORDER=1 D TDO(P,A,C,T,STOP) Q
. I ORDER=2 D CLO(P,A,C,T,STOP) Q
. I ORDER=3 D PCO(P,A,C,T,STOP) Q
. D NMO(P,A,C,T,STOP)
Q
;
PRTOK(P,D,TERM) ; -- check to see if rs should be printed for patient
; remove cancelled appts from list
I ('$G(^DPT(P,"S",D,0)))!($P($G(^DPT(P,"S",D,0)),U,2)["C") Q 0
;
I SDX["ALL",SDSTART="" Q 1 ;1st printing of all routing slips
;
; can have range of items to print; checking range
; clinic ranges to be checked later
;NEW X S X=1 I SDX["ALL" D Q X ;IHS/ITSC/LJF 5/20/2004; PATCH #1001
NEW X S X=1 I 'SDREP D Q X ;IHS/ITSC/LJF 5/20/2004; PATCH #1001
. I SDX["ADD",$P(^DPT(P,"S",D,0),U,13)]"" S X=0 Q ;if add-on, don't print if already printed; PATCH #1001
. I ORDER=1,SDSTART]"",SDSTART]$E(TERM,1,2) S X=0 Q ;before beginning
. I ORDER=1,SDSTOP]"",$E(TERM,1,2)]SDSTOP S X=0 Q ;after end
. I ORDER=4,SDSTART]$$GET1^DIQ(2,P,.01) S X=0 Q ;before beginning
. I ORDER=4,$$GET1^DIQ(2,P,.01)]SDSTOP S X=0 Q ;before beginning
;
; if reprinting add-ons, only reprint those already printed that day
I SDREP,SDX["ADD" Q $S($P($G(^DPT(P,"S",D,0)),U,13)\1=SDSTART:1,1:0)
;
Q 1 ;PATCH #1001
;if add-ons & already printed, don't print
;Q $S($P(^DPT(P,"S",D,0),U,13)]"":0,1:1)
;
FIRST(DFN,DATE) ;EP -- returns 1 if first appt that day for patient
;IHS/ITSC/LJF 4/2/2004 rewrote subroutine so it works correctly
I (ORDER'=2),(ORDER'=3) Q 0 ;for sorts by clinic only
NEW X,Y
S X=DATE\1
F S X=$O(^DPT(DFN,"S",X)) Q:(X\1>DATE\1) Q:'X Q:$D(Y) D
. Q:$P(^DPT(DFN,"S",X,0),U,2)["C" ;ignore cancelled appts
. S Y=$S(X=DATE:1,1:0)
Q $G(Y)
BSDROUT0 ; IHS/ANMC/LJF - ROUTING SLIPS CALC ; [ 08/20/2004 11:57 AM ]
+1 ;;5.3;PIMS;**1001,1004**;MAY 28, 2004
+2 ;IHS/OIT/LJF 11/03/2005 PATCH 1004 added EP to FIRST subroutine
+3 ;
FIND(CLN,APPT,APPN,ORDER,BSDMODE) ;EP; -- set up ^tmp sort for patient's appt
+1 ; called by START^BSDROUT and SINGLE^BSDROUT
+2 ; assumes SD variables SDX,SDSTART,SDREP,SDATE are set
+3 ; CLN=clinic ien, APPT=appt date/time, APPN=appt ien in ^SC
+4 ; ORDER=1 means sort by terminal digit (or chart # per site param)
+5 ; ORDER=2 means sort by clinic; ORDER=3 means sort by principal clinic
+6 ; ORDER=4 means sort by name; ORDER="" means single routing slip
+7 ; BSDMODE="WI" for walkins, "SD" for same day, "" for all others
+8 ; BSDMODE="CR" used for chart requests in routine BSDROUT
+9 ;
+10 ;
+11 NEW DFN,HRCN,TERM,FIRST
+12 NEW BSDSC,BSDGD,BSDL
+13 ;patient ien
SET DFN=$PIECE(^SC(CLN,"S",APPT,1,APPN,0),U)
+14 ;chart #
SET HRCN=$$HRCN^BDGF2(DFN,$$FAC^BSDU(CLN))
+15 ;terminal digit format
SET TERM=$$HRCNT^BDGF2(HRCN)
+16 IF $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(CLN),.18)="NO"
Begin DoDot:1
+17 ;use chart # per site param
SET TERM=$$HRCND^BDGF2(HRCN)
End DoDot:1
+18 ;
+19 ;okay to print this appt?
IF '$$PRTOK(DFN,APPT,TERM)
QUIT
+20 ;
+21 ;first appt that day?
SET FIRST=$$FIRST(DFN,APPT)
+22 ;
+23 ;xray, lab, ekg stops
DO STOPS(DFN,APPT,CLN,TERM,ORDER)
+24 IF ORDER=1
DO TDO(DFN,APPT,CLN,TERM,"",FIRST)
QUIT
+25 IF ORDER=2
DO CLO(DFN,APPT,CLN,TERM,"",FIRST)
QUIT
+26 IF ORDER=3
DO PCO(DFN,APPT,CLN,TERM,"",FIRST)
QUIT
+27 DO NMO(DFN,APPT,CLN,TERM,"",FIRST)
QUIT
+28 ;
TDO(P,D,C,T,S,F) ; -- sort by terminal digit
+1 ;1st for patient for date
IF $GET(F)
SET ^TMP("SDRS",$JOB," "_T," "_T,P)=1
+2 SET ^TMP("SDRS",$JOB," "_T," "_T,P,D)=C_U_$GET(S)_U_$GET(BSDMODE)
+3 QUIT
+4 ;
CLO(P,D,C,T,S,F) ; -- sort by clinic
+1 ;clinic name
NEW N
SET N=$$GET1^DIQ(44,C,.01)
IF N=""
QUIT
+2 ;not in print range
IF SDX["ALL"
IF SDSTART]""
IF SDSTART]N
QUIT
+3 ;not in print range
IF SDX["ALL"
IF SDSTOP]""
IF N]SDSTOP
QUIT
+4 ;
+5 ;IHS/ITSC/LJF 4/2/2004 set to find all appts later
+6 ;I $G(F) S ^TMP("SDRS",$J,N," "_T,P)=1 ;1st for patient for date
+7 ;1st for patient for date
IF $GET(F)
IF '$DATA(^TMP("SDRS",$JOB,P))
SET ^TMP("SDRS",$JOB,P,N)=1
+8 SET ^TMP("SDRS1",$JOB,P,D)=N
+9 ;IHS/ITSC/LJF 4/2/2004 end of changes
+10 ;
+11 SET ^TMP("SDRS",$JOB,N," "_T,P,D)=C_U_$GET(S)_U_$GET(BSDMODE)
+12 QUIT
+13 ;
PCO(P,D,C,T,S,F) ; -- sort by principal clinic
+1 ;IHS/ITSC/LJF 4/8/2004 rewrote subroutine to use clinic name for unaffiliated clinics
+2 NEW PRINC
SET PRINC=$$PRIN^BSDU(C)
+3 IF PRINC="UNAFFILIATED CLINICS"
SET PRINC=$$GET1^DIQ(44,+C,.01)
+4 ;not print range
IF SDX["ALL"
IF SDSTART]""
IF SDSTART]PRINC
QUIT
+5 ;not print range
IF SDX["ALL"
IF SDSTOP]""
IF PRINC]SDSTOP
QUIT
+6 ;
+7 ;1st 4 pat 4 dt
IF $GET(F)
IF '$DATA(^TMP("SDRS",$JOB,P))
SET ^TMP("SDRS",$JOB,P,PRINC)=1
+8 ;sort by patient then date/time
SET ^TMP("SDRS1",$JOB,P,D)=PRINC
+9 ;
+10 SET ^TMP("SDRS",$JOB,PRINC," "_T,P,D)=C_U_$GET(S)_U_$GET(BSDMODE)
+11 QUIT
+12 ;
NMO(P,D,C,T,S,F) ; -- sort by name
+1 ;patient name
NEW N
SET N=$$GET1^DIQ(2,P,.01)
+2 ;1st for patient for date
IF $GET(F)
SET ^TMP("SDRS",$JOB,N," "_T,P)=1
+3 SET ^TMP("SDRS",$JOB,N," "_T,P,D)=C_U_$GET(S)_U_$GET(BSDMODE)
+4 QUIT
+5 ;
+6 ;
STOPS(P,D,C,T,ORDER) ; checks for xray, lab or ekg stops
+1 NEW I,A,STOP
+2 FOR I=3,4,5
IF $PIECE(^DPT(P,"S",D,0),U,I)]""
Begin DoDot:1
+3 SET A=$PIECE(^DPT(P,"S",D,0),U,I)
SET STOP=$SELECT(I=3:"LAB",I=4:"XRAY",1:"EKG")
+4 IF ORDER=1
DO TDO(P,A,C,T,STOP)
QUIT
+5 IF ORDER=2
DO CLO(P,A,C,T,STOP)
QUIT
+6 IF ORDER=3
DO PCO(P,A,C,T,STOP)
QUIT
+7 DO NMO(P,A,C,T,STOP)
End DoDot:1
+8 QUIT
+9 ;
PRTOK(P,D,TERM) ; -- check to see if rs should be printed for patient
+1 ; remove cancelled appts from list
+2 IF ('$GET(^DPT(P,"S",D,0)))!($PIECE($GET(^DPT(P,"S",D,0)),U,2)["C")
QUIT 0
+3 ;
+4 ;1st printing of all routing slips
IF SDX["ALL"
IF SDSTART=""
QUIT 1
+5 ;
+6 ; can have range of items to print; checking range
+7 ; clinic ranges to be checked later
+8 ;NEW X S X=1 I SDX["ALL" D Q X ;IHS/ITSC/LJF 5/20/2004; PATCH #1001
+9 ;IHS/ITSC/LJF 5/20/2004; PATCH #1001
NEW X
SET X=1
IF 'SDREP
Begin DoDot:1
+10 ;if add-on, don't print if already printed; PATCH #1001
IF SDX["ADD"
IF $PIECE(^DPT(P,"S",D,0),U,13)]""
SET X=0
QUIT
+11 ;before beginning
IF ORDER=1
IF SDSTART]""
IF SDSTART]$EXTRACT(TERM,1,2)
SET X=0
QUIT
+12 ;after end
IF ORDER=1
IF SDSTOP]""
IF $EXTRACT(TERM,1,2)]SDSTOP
SET X=0
QUIT
+13 ;before beginning
IF ORDER=4
IF SDSTART]$$GET1^DIQ(2,P,.01)
SET X=0
QUIT
+14 ;before beginning
IF ORDER=4
IF $$GET1^DIQ(2,P,.01)]SDSTOP
SET X=0
QUIT
End DoDot:1
QUIT X
+15 ;
+16 ; if reprinting add-ons, only reprint those already printed that day
+17 IF SDREP
IF SDX["ADD"
QUIT $SELECT($PIECE($GET(^DPT(P,"S",D,0)),U,13)\1=SDSTART:1,1:0)
+18 ;
+19 ;PATCH #1001
QUIT 1
+20 ;if add-ons & already printed, don't print
+21 ;Q $S($P(^DPT(P,"S",D,0),U,13)]"":0,1:1)
+22 ;
FIRST(DFN,DATE) ;EP -- returns 1 if first appt that day for patient
+1 ;IHS/ITSC/LJF 4/2/2004 rewrote subroutine so it works correctly
+2 ;for sorts by clinic only
IF (ORDER'=2)
IF (ORDER'=3)
QUIT 0
+3 NEW X,Y
+4 SET X=DATE\1
+5 FOR
SET X=$ORDER(^DPT(DFN,"S",X))
IF (X\1>DATE\1)
QUIT
IF 'X
QUIT
IF $DATA(Y)
QUIT
Begin DoDot:1
+6 ;ignore cancelled appts
IF $PIECE(^DPT(DFN,"S",X,0),U,2)["C"
QUIT
+7 SET Y=$SELECT(X=DATE:1,1:0)
End DoDot:1
+8 QUIT $GET(Y)
