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

BSDU2.m

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