Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDROUT0

BSDROUT0.m

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