BSDAMR2 ; IHS/ANMC/LJF - APPTS REQ ACTION ;
;;5.3;PIMS;**1007**;FEB 27, 2007
;
;cmi/anch/maw 11/22/2006 PATCH 1007 added code in INIT for item 1007.17
;
ASK ; -- ask user questions
NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDSUB,BSDTT
;
S BSDSUB=$$READ^BDGF("SO^C:Clinic;P:Principal Clinic;V:Provider;T:Team","Subtotal Report by","","^D HELP1^BSDWKR1")
Q:BSDSUB="" Q:BSDSUB=U
;
; get clinic arrays based on subtotal category
I (BSDSUB="C")!(BSDSUB="P") D CLINIC^BSDU(2) Q:$D(BSDQ)
I (BSDSUB="V")!(BSDSUB="T") D PCASK^BSDU(2,BSDSUB) Q:$D(BSDQ)
;
S BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search") Q:'BSDBD
S BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search") Q:'BSDED
;
S Y=$$BROWSE^BDGF Q:"PB"'[Y I Y="B" D EN Q ;browse in list mgr mode
D ZIS^BDGF("PQ","START^BSDAMR2","APPT REQ ACTION","BSDSUB;BSDBD;BSDED;VAUTC*;VAUTD*")
Q
;
START ;EP; -- re-entry for printing to paper
D INIT,PRINT Q
;
EN ; -- main entry point for BSDRM APPT MGT NO ACTION
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDRM APPT MGT NO ACTION")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(15)_$$CONF^BSDU
S VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)
Q
;
INIT ; -- init variables and list array
S VALMCNT=0 K ^TMP("BSDAMR2",$J),^TMP("BSD",$J)
NEW BSDAR S BSDAR=$S(VAUTC:"^SC",1:"VAUTC")
;
; -- loop by clinic
NEW CLN,NAME,SUB,APPT,APPN,PAT,STATUS,TYPE,END,LINE
S CLN=0 F S CLN=$O(@BSDAR@(CLN)) Q:'CLN D
. Q:$D(^SC("AIHSPC",CLN)) ;quit if principal clinic
. S NAME=$$GET1^DIQ(44,CLN,.01) ;set clinic's name
. S SUB=$$SUB1^BSDWKR1(CLN,NAME) ;get subcategory for clinic
. I '$G(VAUTD) Q:'$D(VAUTD(+$P($G(^SC(CLN,0)),U,15))) ;cmi/anch/maw 11/22/06 added to screen on division item 1007.17 patch 1007
. ;
. ; -- then by appt date (within range)
. S APPT=BSDBD,END=BSDED+.2400
. F S APPT=$O(^SC(CLN,"S",APPT)) Q:'APPT!(APPT>END) D
.. ;
.. ; -- then find appts to count
.. S APPN=0
.. F S APPN=$O(^SC(CLN,"S",APPT,1,APPN)) Q:'APPN D
... S PAT=+^SC(CLN,"S",APPT,1,APPN,0) ;patient ien
... S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100) ;current status
... I STATUS]"",STATUS'["NO ACTION TAKEN" Q
... S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS) ;type of appt
... ;
... ; put appts into display array
... S LINE=$$PAD($$FMTE^XLFDT(APPT),22) ;appt date
... S LINE=$$PAD(LINE_TYPE,33) ;appt type
... S LINE=LINE_$J($$HRCN^BDGF2(PAT,$$FAC^BSDU(CLN)),7) ;chart#
... S LINE=$$PAD(LINE,43)_$E($$GET1^DIQ(2,PAT,.01),1,18) ;patient name
... S LINE=$$PAD(LINE,63)_$$GET1^DIQ(2,PAT,.02,"I") ;sex
... S LINE=$$PAD(LINE,68)_$$GET1^DIQ(2,PAT,.033) ;age
... S ^TMP("BSD",$J,SUB,NAME,APPT)=LINE ;sort by category,clinic,date
;
; put sorted list into display array
NEW S1,S2,S3
S S1=0 F S S1=$O(^TMP("BSD",$J,S1)) Q:S1="" D
. D SET(S1,.VALMCNT)
. S S2=0 F S S2=$O(^TMP("BSD",$J,S1,S2)) Q:S2="" D
.. I S1'=S2 D SET($$SP(2)_S2,.VALMCNT)
.. S S3=0 F S S3=$O(^TMP("BSD",$J,S1,S2,S3)) Q:S3="" D
... D SET(^TMP("BSD",$J,S1,S2,S3),.VALMCNT)
.. I S1'=S2 D SET("",.VALMCNT)
. D SET("",.VALMCNT)
;
K ^TMP("BSD",$J)
Q
;
TYPE(C,D,N,P,S) ; return type of appt
; returns sched, same day, walk-in, overbook, inpt
I S["INPAT" Q "Inpatient"
I $G(^SC(C,"S",D,1,N,"OB"))="O" Q "Overbook"
NEW X S X=$$VALI^XBDIQ1(2.98,P_","_D,9) I X=4 Q "Walkin"
I X=3,(D\1)=($P($G(^DPT(P,"S",D,0)),U,19)\1) Q "Same Day"
I X=3 Q "Scheduled"
Q "??" ;error in case one slips thru
;
SET(LINE,NUM) ; set line into display array
S NUM=NUM+1
S ^TMP("BSDAMR2",$J,NUM,0)=LINE
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BSDAMR2",$J)
Q
;
EXPND ; -- expand code
Q
;
PRINT ; print report to paper
U IO D HDG
NEW X S X=0 F S X=$O(^TMP("BSDAMR2",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BSDAMR2",$J,X,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
D HDR W @IOF,?30,"Appointments with No Action Taken"
F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
W !,$$REPEAT^XLFSTR("-",80)
W !,"Appt Date",?22,"Type",?33,"Chart #",?43,"Sex",?48,"Age",?57,"Status"
W !,$$REPEAT^XLFSTR("=",80)
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)
BSDAMR2 ; IHS/ANMC/LJF - APPTS REQ ACTION ;
+1 ;;5.3;PIMS;**1007**;FEB 27, 2007
+2 ;
+3 ;cmi/anch/maw 11/22/2006 PATCH 1007 added code in INIT for item 1007.17
+4 ;
ASK ; -- ask user questions
+1 NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDSUB,BSDTT
+2 ;
+3 SET BSDSUB=$$READ^BDGF("SO^C:Clinic;P:Principal Clinic;V:Provider;T:Team","Subtotal Report by","","^D HELP1^BSDWKR1")
+4 IF BSDSUB=""
QUIT
IF BSDSUB=U
QUIT
+5 ;
+6 ; get clinic arrays based on subtotal category
+7 IF (BSDSUB="C")!(BSDSUB="P")
DO CLINIC^BSDU(2)
IF $DATA(BSDQ)
QUIT
+8 IF (BSDSUB="V")!(BSDSUB="T")
DO PCASK^BSDU(2,BSDSUB)
IF $DATA(BSDQ)
QUIT
+9 ;
+10 SET BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search")
IF 'BSDBD
QUIT
+11 SET BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search")
IF 'BSDED
QUIT
+12 ;
+13 ;browse in list mgr mode
SET Y=$$BROWSE^BDGF
IF "PB"'[Y
QUIT
IF Y="B"
DO EN
QUIT
+14 DO ZIS^BDGF("PQ","START^BSDAMR2","APPT REQ ACTION","BSDSUB;BSDBD;BSDED;VAUTC*;VAUTD*")
+15 QUIT
+16 ;
START ;EP; -- re-entry for printing to paper
+1 DO INIT
DO PRINT
QUIT
+2 ;
EN ; -- main entry point for BSDRM APPT MGT NO ACTION
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BSDRM APPT MGT NO ACTION")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(15)_$$CONF^BSDU
+2 SET VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 SET VALMCNT=0
KILL ^TMP("BSDAMR2",$JOB),^TMP("BSD",$JOB)
+2 NEW BSDAR
SET BSDAR=$SELECT(VAUTC:"^SC",1:"VAUTC")
+3 ;
+4 ; -- loop by clinic
+5 NEW CLN,NAME,SUB,APPT,APPN,PAT,STATUS,TYPE,END,LINE
+6 SET CLN=0
FOR
SET CLN=$ORDER(@BSDAR@(CLN))
IF 'CLN
QUIT
Begin DoDot:1
+7 ;quit if principal clinic
IF $DATA(^SC("AIHSPC",CLN))
QUIT
+8 ;set clinic's name
SET NAME=$$GET1^DIQ(44,CLN,.01)
+9 ;get subcategory for clinic
SET SUB=$$SUB1^BSDWKR1(CLN,NAME)
+10 ;cmi/anch/maw 11/22/06 added to screen on division item 1007.17 patch 1007
IF '$GET(VAUTD)
IF '$DATA(VAUTD(+$PIECE($GET(^SC(CLN,0)),U,15)))
QUIT
+11 ;
+12 ; -- then by appt date (within range)
+13 SET APPT=BSDBD
SET END=BSDED+.2400
+14 FOR
SET APPT=$ORDER(^SC(CLN,"S",APPT))
IF 'APPT!(APPT>END)
QUIT
Begin DoDot:2
+15 ;
+16 ; -- then find appts to count
+17 SET APPN=0
+18 FOR
SET APPN=$ORDER(^SC(CLN,"S",APPT,1,APPN))
IF 'APPN
QUIT
Begin DoDot:3
+19 ;patient ien
SET PAT=+^SC(CLN,"S",APPT,1,APPN,0)
+20 ;current status
SET STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100)
+21 IF STATUS]""
IF STATUS'["NO ACTION TAKEN"
QUIT
+22 ;type of appt
SET TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS)
+23 ;
+24 ; put appts into display array
+25 ;appt date
SET LINE=$$PAD($$FMTE^XLFDT(APPT),22)
+26 ;appt type
SET LINE=$$PAD(LINE_TYPE,33)
+27 ;chart#
SET LINE=LINE_$JUSTIFY($$HRCN^BDGF2(PAT,$$FAC^BSDU(CLN)),7)
+28 ;patient name
SET LINE=$$PAD(LINE,43)_$EXTRACT($$GET1^DIQ(2,PAT,.01),1,18)
+29 ;sex
SET LINE=$$PAD(LINE,63)_$$GET1^DIQ(2,PAT,.02,"I")
+30 ;age
SET LINE=$$PAD(LINE,68)_$$GET1^DIQ(2,PAT,.033)
+31 ;sort by category,clinic,date
SET ^TMP("BSD",$JOB,SUB,NAME,APPT)=LINE
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ; put sorted list into display array
+34 NEW S1,S2,S3
+35 SET S1=0
FOR
SET S1=$ORDER(^TMP("BSD",$JOB,S1))
IF S1=""
QUIT
Begin DoDot:1
+36 DO SET(S1,.VALMCNT)
+37 SET S2=0
FOR
SET S2=$ORDER(^TMP("BSD",$JOB,S1,S2))
IF S2=""
QUIT
Begin DoDot:2
+38 IF S1'=S2
DO SET($$SP(2)_S2,.VALMCNT)
+39 SET S3=0
FOR
SET S3=$ORDER(^TMP("BSD",$JOB,S1,S2,S3))
IF S3=""
QUIT
Begin DoDot:3
+40 DO SET(^TMP("BSD",$JOB,S1,S2,S3),.VALMCNT)
End DoDot:3
+41 IF S1'=S2
DO SET("",.VALMCNT)
End DoDot:2
+42 DO SET("",.VALMCNT)
End DoDot:1
+43 ;
+44 KILL ^TMP("BSD",$JOB)
+45 QUIT
+46 ;
TYPE(C,D,N,P,S) ; return type of appt
+1 ; returns sched, same day, walk-in, overbook, inpt
+2 IF S["INPAT"
QUIT "Inpatient"
+3 IF $GET(^SC(C,"S",D,1,N,"OB"))="O"
QUIT "Overbook"
+4 NEW X
SET X=$$VALI^XBDIQ1(2.98,P_","_D,9)
IF X=4
QUIT "Walkin"
+5 IF X=3
IF (D\1)=($PIECE($GET(^DPT(P,"S",D,0)),U,19)\1)
QUIT "Same Day"
+6 IF X=3
QUIT "Scheduled"
+7 ;error in case one slips thru
QUIT "??"
+8 ;
SET(LINE,NUM) ; set line into display array
+1 SET NUM=NUM+1
+2 SET ^TMP("BSDAMR2",$JOB,NUM,0)=LINE
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDAMR2",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ; print report to paper
+1 USE IO
DO HDG
+2 NEW X
SET X=0
FOR
SET X=$ORDER(^TMP("BSDAMR2",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-4)
DO HDG
+4 WRITE !,^TMP("BSDAMR2",$JOB,X,0)
End DoDot:1
+5 DO ^%ZISC
DO EXIT
+6 QUIT
+7 ;
HDG ; heading for paper report
+1 DO HDR
WRITE @IOF,?30,"Appointments with No Action Taken"
+2 FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+3 WRITE !,$$REPEAT^XLFSTR("-",80)
+4 WRITE !,"Appt Date",?22,"Type",?33,"Chart #",?43,"Sex",?48,"Age",?57,"Status"
+5 WRITE !,$$REPEAT^XLFSTR("=",80)
+6 QUIT
+7 ;
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)
