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