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

BSDPRV.m

Go to the documentation of this file. 
  1. BSDPRV ; IHS/ANMC/LJF - 1ST AVAIL APPT BY PROVIDER/TEAM ;  [ 04/01/2004  4:29 PM ]
  1.  ;;5.3;PIMS;;APR 26, 2002
  1.  ;
  1. ASK ; -- ask provider/PCP/PCT
  1.  ; BSDPRV set here or under PCP or PCT
  1.  ; BSDCL array of clinics used by GATHER subroutine
  1.  ; BSDQUIT used by calling routine to exit
  1.  ;NEW Y,BSDPRV,BSDCL,X K BSDQUIT
  1.  NEW Y,BSDPRV,BSDCL,X,BSDPCP K BSDQUIT  ;IHS/ITSC/LJF 3/31/2004 added kill of BSDPCP
  1.  S Y=$$READ^BDGF("FO^3:30","Select Provider/PCPR/PCTM","","^D HELP1^BSDPRV")
  1.  I (Y="")!(Y=U) S BSDQUIT=1 Q
  1.  S Y=$$UP^XLFSTR(Y)    ;convert to uppercase
  1.  I (Y="PCPR")!(Y="PCTM")!(Y="WHPR")!(Y="WHTM") D GETALL(Y) D EN Q
  1.  S X=Y,DIC=200,DIC(0)="EMQZ" D ^DIC I Y<1 D ASK Q
  1.  S BSDPRV=$P(Y,U,2),BSDPCP(+Y)="" D FINDCL(.BSDPCP) D EN Q    ;provider ien
  1.  ;
  1.  ;
  1. EN ;EP; called by SDM with SDPC set
  1.  NEW BSDAY,BSDEND
  1.  S BSDAY=$$READ^BDGF("DO^::E","Enter EARLIEST POSSIBLE APPT DATE","TODAY")
  1.  Q:BSDAY<1
  1.  ;
  1.  S BSDEND=$$READ^BDGF("DO^::E","Enter LATEST POSSIBLE APPT DATE","T+15")
  1.  Q:BSDEND<1  S BSDEND=BSDEND_".2400"
  1.  ;
  1.  NEW VALMCNT
  1.  S VALMCC=1 ;1=screen mode, 0=scrolling mode
  1.  D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BSDAM PROVIDER AVAIL")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ;EP; -- header code
  1.  NEW X,Y
  1.  S VALMHDR(1)=$$SP(20)_"First 3 days with Appointments"
  1.  S VALMHDR(2)=$$SP(15)_BSDPRV  ;provider or team name
  1.  S X=$$FMTE^XLFDT(BSDAY),Y=$$FMTE^XLFDT(BSDEND,"D")
  1.  S VALMHDR(2)=VALMHDR(2)_" from "_X_" to "_Y
  1.  Q
  1.  ;
  1. INIT ;EP; -- init variables and list array
  1.  K ^TMP("BSDPRV",$J),^TMP("BSDPRV1",$J)
  1.  D GUIR^XBLM("GATHER^BSDPRV","^TMP(""BSDPRV1"",$J,")
  1.  S X=$O(^TMP("BSDPRV1",$J,999999),-1) I X,^TMP("BSDPRV1",$J,X)="" K ^TMP("BSDPRV1",$J,X)
  1.  S X=0 F  S X=$O(^TMP("BSDPRV1",$J,X)) Q:'X  D
  1.  . S VALMCNT=X
  1.  . S ^TMP("BSDPRV",$J,X,0)=^TMP("BSDPRV1",$J,X)
  1.  ;
  1.  I '$D(^TMP("BSDPRV",$J)) S VALMCNT=1,^TMP("BSDPRV",$J,1,0)="NO APPOINTMENTS FOUND FOR DATE RANGE"
  1.  K ^TMP("BSDPRV1",$J)
  1.  Q
  1.  ;
  1. HELP ;EP; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. HELP1 ;EP; -- help called by DIR call for Provider/PCPR/PCTM
  1.  D MSG^BDGF("Enter a provider's name",2,0)
  1.  D MSG^BDGF("  or PCPR for patient's primary care provider",1,0)
  1.  D MSG^BDGF("  or PCTM for patient's primary care team.",1,0)
  1.  D MSG^BDGF("  or WHPR for patient's women's health provider",1,0)
  1.  D MSG^BDGF("  or WHTM for women's health provider team.",1,1)
  1.  D MSG^BDGF("Display will be similar to that for principal clinic in",1,0)
  1.  D MSG^BDGF("that the first 3 days with appointments will display.",1,0)
  1.  D MSG^BDGF("Once a clinic has been found, exit the display and enter",1,0)
  1.  D MSG^BDGF("that clinic name at the ""Select CLINIC"" prompt.",1,1)
  1.  Q
  1.  ;
  1. EXIT ;EP; -- exit code
  1.  K ^TMP("BSDPRV",$J) D CLEAN^VALM10
  1.  S VALMNOFF=1  ;suppress form feed 
  1.  Q
  1.  ;
  1. EXPND ;EP; -- expand code
  1.  Q
  1.  ;
  1.  ;
  1. GATHER ;EP; loop thru clinics selected
  1.  ; assumes BSDCL array of clinics and BSDAY, BSDEND are set
  1.  NEW BSDNM,BSDN
  1.  I '$D(BSDCL) W !!?20,"NO PROVIDER/TEAM FOUND" Q
  1.  S BSDNM=0 F  S BSDNM=$O(BSDCL(BSDNM)) Q:BSDNM=""  D
  1.  . S BSDN=BSDCL(BSDNM) D DAY
  1.  Q
  1.  ;
  1. HD ;Write month heading lines  ;IHS/ITSC/LJF 4/1/2004 added subroutine
  1.  I $G(SI)="" D
  1.  .S SI=$P($G(^SC(BSDN,"SL")),U,6),SI=$S(SI<3:4,1:SI)
  1.  I $G(STARTDAY)="" D
  1.  .S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S(X:X,1:8),SC=+Y
  1.  W !!,?18,"TIME",?SI+SI-1 F Y=STARTDAY:1:65\(SI+SI)+STARTDAY W $E("|"_$S('Y:0,1:(Y-1#12+1))_"                 ",1,SI+SI)
  1.  W !,?18,"DATE",?SI+SI-1,"|" K J F Y=0:1:6 I $D(^SC(+BSDN,"T"_Y)) S J(Y)=""
  1.  F Y=1:1:65\(SI+SI) W $J("|",SI+SI)
  1.  Q
  1.  ;
  1. DAY ; for clinic & date range, find first 3 days with appts
  1.  NEW DATE,DAYCNT,IEN,Z,I,SLOT
  1.  S DATE=BSDAY-.001,Z="",SLOT=0,DAYCNT=0
  1.  F  S DATE=$O(^SC(BSDN,"ST",DATE)) Q:'DATE  Q:DATE>BSDEND  Q:DAYCNT=3  D
  1.  . S IEN=0
  1.  . F  S IEN=$O(^SC(BSDN,"ST",DATE,IEN)) Q:'IEN  Q:DAYCNT=3  D
  1.  .. S Z=$E(^SC(BSDN,"ST",DATE,IEN),6,$L(^SC(BSDN,"ST",DATE,IEN)))
  1.  .. Q:Z["CANCELLED"
  1.  .. I (Z'["|"),(Z'["[") Q
  1.  .. I Z["|" S SLOT=$P(Z,"|",2,999)
  1.  .. I Z'["|" S SLOT=$E(Z,6,999)
  1.  .. F I="|","[","]","*"," ","0" S SLOT=$$STRIP^XLFSTR(SLOT,I)
  1.  .. F I="A","B","C","D","E","F" S SLOT=$$STRIP^XLFSTR(SLOT,I)
  1.  .. F I="j","k","l","m","n","o" S SLOT=$$STRIP^XLFSTR(SLOT,I)
  1.  .. S SLOT=$TR(Z,"|[@#]!$* ABCDEFXjklmno",0)   ;IHS/ITSC/LJF 4/1/2004
  1.  .. Q:+SLOT<1                            ;no appt slots found
  1.  .. ;I DAYCNT=0 W !!,$P(^SC(BSDN,0),U,1)  ;display clinic name
  1.  .. I DAYCNT=0 D HD W !,$P(^SC(BSDN,0),U,1)  ;display times & clinic name  ;IHS/ITSC/LJF 4/1/2004
  1.  .. S Y=$$FMTE^XLFDT(DATE)               ;printable date
  1.  .. W !,Y,?15,^SC(BSDN,"ST",DATE,IEN)    ;display day's appts
  1.  .. S DAYCNT=DAYCNT+1                  ;display up to 3 days per clinic
  1.  Q
  1.  ;
  1. GETALL(BSDP) ; -- get primary care provider or team
  1.  ; BSDP="PCPR for primary care provider or "PCTM" for primary care team
  1.  ; BSDP="WHPR" for women's health provider or "WHTM" for wh team
  1.  ; returns BSDPCP array of all providers selected
  1.  ; returns BSDPRV=pcp provider or team name
  1.  ;
  1.  NEW X,I,TEAM
  1.  ; find patient's PCP or WH PCP
  1.  S BSDPRV=$S(BSDP["PC":"Primary Care ",1:"Women's Health ")_$S(BSDP["PR":"Provider",1:"Team")
  1.  ;IHS/ITSC/WAR 1/5/04 mods per Linda.
  1.  ;I BSDP["PC" S X=$$GET1^DIQ(9000001,DFN,.14,"I") I 'X S BSDQUIT=1 Q
  1.  ;I BSDP["WH" S X=$$GET1^DIQ(9002086,DFN,.25,"I") I 'X S BSDQUIT=1 Q
  1.  I BSDP["PC" S X=$$GET1^DIQ(9000001,DFN,.14,"I") I 'X Q
  1.  I BSDP["WH" S X=$$GET1^DIQ(9002086,DFN,.25,"I") I 'X Q
  1.  S BSDPCP(X)=""
  1.  I BSDP["PR" D FINDCL(.BSDPCP) Q
  1.  ;END OF 12/31/03 Changes (now removed) & 1/5/04 changes
  1.  ;
  1.  ; if using team, find all teams to which this PCP belongs
  1.  S X=0 F  S X=$O(^BSDPCT("AB",+$O(BSDPCP(X)),X)) Q:'X  S TEAM(X)=""
  1.  I '$D(TEAM) S BSDQUIT=1 Q
  1.  ;
  1.  ; now find all providers on those teams
  1.  S X=0 F  S X=$O(TEAM(X)) Q:'X  D
  1.  . S Y=0 F  S Y=$O(^BSDPCT(X,1,Y)) Q:'Y  D
  1.  .. S BSDPCP(+$G(^BSDPCT(X,1,Y,0)))=""     ;add providers from team
  1.  ;
  1.  ; then find all clinics linked to those providers
  1.  D FINDCL(.BSDPCP)
  1.  Q
  1.  ;
  1.  ;
  1. FINDCL(BSDX) ;EP; -- sets array of clinics for provider or team
  1.  ; returns BSDCL array with clinic name and then ien
  1.  ; BSDX=array of providers
  1.  K BSDCL NEW PRV,X
  1.  S PRV=0 F  S PRV=$O(BSDX(PRV)) Q:'PRV  D
  1.  . S X=0 F  S X=$O(^SC("AIHSDPR",PRV,X)) Q:'X  D
  1.  .. S BSDCL($$GET1^DIQ(44,X,.01))=X
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- 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)
  1.  ;