BSDNXAA ; IHS/ANMC/LJF - # DAYS TIL NEXT APPT ;
;;5.3;PIMS;**1010,1011**;APR 26, 2002
;
;
;cmi/anch/maw 11/17/2008 PATCH 1010 put fix in NA per Walt Reisch for find of cancelled appointments
;
ASK ; -- ask user for clinics and device
NEW VAUTC,VAUTD,BSD3RD,POP
S BSD3RD=$$READ^BDGF("YO","Search for Next 3rd Available Appt.","","^D HELP1^BSDNXAA")
Q:BSD3RD=U Q:BSD3RD=""
D CLINIC^BSDU(2) Q:$D(BSDQ)
S Y=$$BROWSE^BDGF Q:"PB"'[Y I Y="B" D EN Q ;browse in list mgr mode
D ZIS^BDGF("PQ","START^BSDNXAA","NEXT AVAIL APPT","VAUTC*;VAUTD*;BSD3RD")
Q
;
START ;EP; -- re-entry for printing to paper
D INIT,PRINT Q
;
EN ;EP; -- main entry point for BSDRM NEXT AVAIL APPT
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDRM NEXT AVAIL APPT")
D CLEAR^VALM1
Q
;
HDR ; -- header code
Q
;
INIT ; -- init variables and list array
NEW ARRAY,CLINIC,PC,NAME
S VALMCNT=0 K ^TMP("BSDNXAA",$J),^TMP("BSDNXAA1",$J)
S ARRAY=$S(VAUTC:"^SC",1:"VAUTC")
S CLINIC=0
F S CLINIC=$O(@ARRAY@(CLINIC)) Q:'CLINIC D
. Q:'$$OKAY(CLINIC) ;quit if inactive clinic
. I $D(^SC("AIHSPC",CLINIC)) Q ;quit if principal clinic
. S PC=$$PRIN^BSDU(CLINIC) ;get princ clinic name
. S NAME=$$GET1^DIQ(44,CLINIC,.01) ;clinic's name
. ;
. ; put in principal clinic order, then by clinic name
. S ^TMP("BSDNXAA1",$J,PC,NAME,CLINIC)=""
;
I '$D(^TMP("BSDNXAA1",$J)) D SET("NONE FOUND",.VALMCNT) Q
;
; pull in sorted order and get display data
S PC=0 F S PC=$O(^TMP("BSDNXAA1",$J,PC)) Q:PC="" D
. D SET(PC,.VALMCNT) ;principal clinic subheading
. S NAME=0 F S NAME=$O(^TMP("BSDNXAA1",$J,PC,NAME)) Q:NAME="" D
.. S CLINIC=0
.. F S CLINIC=$O(^TMP("BSDNXAA1",$J,PC,NAME,CLINIC)) Q:'CLINIC D
... D SET($$DAY(CLINIC,NAME),.VALMCNT) ;put into display global
;
K ^TMP("BSDNXAA1",$J)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BSDNXAA",$J),VALMCNT,POP
Q
;
EXPND ; -- expand code
Q
;
;
DAY(CLN,NAME) ; -- loop visit days / clinic and print next appt
NEW BSDAY,LINE,BSD3CT
S LINE=$$PAD($$SP(26)_NAME,57)
S BSDAY=DT-.0001,BSD3CT=0
; find next available appt
F S BSDAY=$O(^SC(CLN,"ST",BSDAY)) Q:'BSDAY Q:$$NA
;
I 'BSDAY Q LINE_"none" ;if none found, say so
;
; if found set line with date and # of days
Q $$PAD(LINE_$$FMTE^XLFDT(BSDAY),71)_$J($$D(BSDAY),2)_" days"
Q
;
NA() ; -- next appointment
NEW X,Y,Z,J
S Y=$O(^SC(CLN,"ST",BSDAY,0)) Q:'Y 0
I $D(^SC(CLN,"ST",BSDAY,"CAN")) Q 0 ;cmi/maw 11/17/2008 PATCH 1010 added per walt reisch find at PIMC dont count if cancelled
;S X="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" ;cmi/11/2/2009 PATCH 1011 orig line
S X="#@!$* ZYXXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqponmlkjihgfedcba0123456789" ;cmi/11/2/2009 PATCH 1011 add remaining letters to lower case
S Z=$E(^SC(CLN,"ST",BSDAY,Y),6,$L(^SC(CLN,"ST",BSDAY,Y)))
I BSD3RD F J=1:1:$L(Z) D
. I $E(X,$F(X,"0"),$L(X))[$E(Z,J) S:BSD3RD BSD3CT=BSD3CT+1
I 'BSD3RD F J=1:1:$L(Z) D
. I $E(X,$F(X,"0"),$L(X))[$E(Z,J) S J=999
Q $S(J=999:1,BSD3CT>2:1,1:0)
;
D(X1,X2,X) ; -- number of days from today
S X2=DT D ^%DTC Q X
;
;
SET(DATA,NUM) ; -- set display data into global
S NUM=NUM+1
S ^TMP("BSDNXAA",$J,NUM,0)=DATA
Q
;
PRINT ; -- print display global to paper
U IO D HD
NEW X
S X=0 F S X=$O(^TMP("BSDNXAA",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HD
. W !,^TMP("BSDNXAA",$J,X,0)
D ^%ZISC,EXIT,HOME^%ZIS
Q
;
HD ; -- heading
W @IOF,!!,?2,"Next Available Appointment by Principle Clinic"
W ?50,"Printed at ",$$FMTE^XLFDT($$NOW^XLFDT),!
Q
;
OKAY(C) ; -- active clinic? (yes=true)
NEW X
S X=$G(^SC(C,"I")) Q:'$D(^SC(C,"ST")) 0 Q:'$O(^("ST",DT)) 0
Q $S($P(^SC(C,0),U,3)'="C":0,'X:1,(DT>(X-1))&('$P(X,U,2)):0,1:1)
;
HELP1 ;EP; help for 3rd appt question
D MSG^BDGF("Answer YES to use the 3rd next available appointment",2,0)
D MSG^BDGF("in your calculations. Some research has shown that",1,0)
D MSG^BDGF("using the 3rd next available appointment instead of",1,0)
D MSG^BDGF("the very next one, gives a clearer picture of the",1,0)
D MSG^BDGF("clinic schedule.",1,0)
D MSG^BDGF("Answer NO to use next available appointment.",2,1)
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)
BSDNXAA ; IHS/ANMC/LJF - # DAYS TIL NEXT APPT ;
+1 ;;5.3;PIMS;**1010,1011**;APR 26, 2002
+2 ;
+3 ;
+4 ;cmi/anch/maw 11/17/2008 PATCH 1010 put fix in NA per Walt Reisch for find of cancelled appointments
+5 ;
ASK ; -- ask user for clinics and device
+1 NEW VAUTC,VAUTD,BSD3RD,POP
+2 SET BSD3RD=$$READ^BDGF("YO","Search for Next 3rd Available Appt.","","^D HELP1^BSDNXAA")
+3 IF BSD3RD=U
QUIT
IF BSD3RD=""
QUIT
+4 DO CLINIC^BSDU(2)
IF $DATA(BSDQ)
QUIT
+5 ;browse in list mgr mode
SET Y=$$BROWSE^BDGF
IF "PB"'[Y
QUIT
IF Y="B"
DO EN
QUIT
+6 DO ZIS^BDGF("PQ","START^BSDNXAA","NEXT AVAIL APPT","VAUTC*;VAUTD*;BSD3RD")
+7 QUIT
+8 ;
START ;EP; -- re-entry for printing to paper
+1 DO INIT
DO PRINT
QUIT
+2 ;
EN ;EP; -- main entry point for BSDRM NEXT AVAIL APPT
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BSDRM NEXT AVAIL APPT")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 QUIT
+2 ;
INIT ; -- init variables and list array
+1 NEW ARRAY,CLINIC,PC,NAME
+2 SET VALMCNT=0
KILL ^TMP("BSDNXAA",$JOB),^TMP("BSDNXAA1",$JOB)
+3 SET ARRAY=$SELECT(VAUTC:"^SC",1:"VAUTC")
+4 SET CLINIC=0
+5 FOR
SET CLINIC=$ORDER(@ARRAY@(CLINIC))
IF 'CLINIC
QUIT
Begin DoDot:1
+6 ;quit if inactive clinic
IF '$$OKAY(CLINIC)
QUIT
+7 ;quit if principal clinic
IF $DATA(^SC("AIHSPC",CLINIC))
QUIT
+8 ;get princ clinic name
SET PC=$$PRIN^BSDU(CLINIC)
+9 ;clinic's name
SET NAME=$$GET1^DIQ(44,CLINIC,.01)
+10 ;
+11 ; put in principal clinic order, then by clinic name
+12 SET ^TMP("BSDNXAA1",$JOB,PC,NAME,CLINIC)=""
End DoDot:1
+13 ;
+14 IF '$DATA(^TMP("BSDNXAA1",$JOB))
DO SET("NONE FOUND",.VALMCNT)
QUIT
+15 ;
+16 ; pull in sorted order and get display data
+17 SET PC=0
FOR
SET PC=$ORDER(^TMP("BSDNXAA1",$JOB,PC))
IF PC=""
QUIT
Begin DoDot:1
+18 ;principal clinic subheading
DO SET(PC,.VALMCNT)
+19 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BSDNXAA1",$JOB,PC,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+20 SET CLINIC=0
+21 FOR
SET CLINIC=$ORDER(^TMP("BSDNXAA1",$JOB,PC,NAME,CLINIC))
IF 'CLINIC
QUIT
Begin DoDot:3
+22 ;put into display global
DO SET($$DAY(CLINIC,NAME),.VALMCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 KILL ^TMP("BSDNXAA1",$JOB)
+25 QUIT
+26 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDNXAA",$JOB),VALMCNT,POP
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
+3 ;
DAY(CLN,NAME) ; -- loop visit days / clinic and print next appt
+1 NEW BSDAY,LINE,BSD3CT
+2 SET LINE=$$PAD($$SP(26)_NAME,57)
+3 SET BSDAY=DT-.0001
SET BSD3CT=0
+4 ; find next available appt
+5 FOR
SET BSDAY=$ORDER(^SC(CLN,"ST",BSDAY))
IF 'BSDAY
QUIT
IF $$NA
QUIT
+6 ;
+7 ;if none found, say so
IF 'BSDAY
QUIT LINE_"none"
+8 ;
+9 ; if found set line with date and # of days
+10 QUIT $$PAD(LINE_$$FMTE^XLFDT(BSDAY),71)_$JUSTIFY($$D(BSDAY),2)_" days"
+11 QUIT
+12 ;
NA() ; -- next appointment
+1 NEW X,Y,Z,J
+2 SET Y=$ORDER(^SC(CLN,"ST",BSDAY,0))
IF 'Y
QUIT 0
+3 ;cmi/maw 11/17/2008 PATCH 1010 added per walt reisch find at PIMC dont count if cancelled
IF $DATA(^SC(CLN,"ST",BSDAY,"CAN"))
QUIT 0
+4 ;S X="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" ;cmi/11/2/2009 PATCH 1011 orig line
+5 ;cmi/11/2/2009 PATCH 1011 add remaining letters to lower case
SET X="#@!$* ZYXXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqponmlkjihgfedcba0123456789"
+6 SET Z=$EXTRACT(^SC(CLN,"ST",BSDAY,Y),6,$LENGTH(^SC(CLN,"ST",BSDAY,Y)))
+7 IF BSD3RD
FOR J=1:1:$LENGTH(Z)
Begin DoDot:1
+8 IF $EXTRACT(X,$FIND(X,"0"),$LENGTH(X))[$EXTRACT(Z,J)
IF BSD3RD
SET BSD3CT=BSD3CT+1
End DoDot:1
+9 IF 'BSD3RD
FOR J=1:1:$LENGTH(Z)
Begin DoDot:1
+10 IF $EXTRACT(X,$FIND(X,"0"),$LENGTH(X))[$EXTRACT(Z,J)
SET J=999
End DoDot:1
+11 QUIT $SELECT(J=999:1,BSD3CT>2:1,1:0)
+12 ;
D(X1,X2,X) ; -- number of days from today
+1 SET X2=DT
DO ^%DTC
QUIT X
+2 ;
+3 ;
SET(DATA,NUM) ; -- set display data into global
+1 SET NUM=NUM+1
+2 SET ^TMP("BSDNXAA",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
PRINT ; -- print display global to paper
+1 USE IO
DO HD
+2 NEW X
+3 SET X=0
FOR
SET X=$ORDER(^TMP("BSDNXAA",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO HD
+5 WRITE !,^TMP("BSDNXAA",$JOB,X,0)
End DoDot:1
+6 DO ^%ZISC
DO EXIT
DO HOME^%ZIS
+7 QUIT
+8 ;
HD ; -- heading
+1 WRITE @IOF,!!,?2,"Next Available Appointment by Principle Clinic"
+2 WRITE ?50,"Printed at ",$$FMTE^XLFDT($$NOW^XLFDT),!
+3 QUIT
+4 ;
OKAY(C) ; -- active clinic? (yes=true)
+1 NEW X
+2 SET X=$GET(^SC(C,"I"))
IF '$DATA(^SC(C,"ST"))
QUIT 0
IF '$ORDER(^("ST",DT))
QUIT 0
+3 QUIT $SELECT($PIECE(^SC(C,0),U,3)'="C":0,'X:1,(DT>(X-1))&('$PIECE(X,U,2)):0,1:1)
+4 ;
HELP1 ;EP; help for 3rd appt question
+1 DO MSG^BDGF("Answer YES to use the 3rd next available appointment",2,0)
+2 DO MSG^BDGF("in your calculations. Some research has shown that",1,0)
+3 DO MSG^BDGF("using the 3rd next available appointment instead of",1,0)
+4 DO MSG^BDGF("the very next one, gives a clearer picture of the",1,0)
+5 DO MSG^BDGF("clinic schedule.",1,0)
+6 DO MSG^BDGF("Answer NO to use next available appointment.",2,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)
