BSDFRL ; IHS/ANMC/LJF - IHS FILE ROOM LIST ;
;;5.3;PIMS;**1007,1008**;DEC 01, 2006
;
;cmi/anch/maw 11/22/2006 PATCH 1007 added code in GETAPPT,GATHER,SORTS for item 1007.07
;cmi/anch/maw 2/5/2007 PATCH 1007 added code in GATHER to look for appt on same day and print if there
;
NEW BSDDT,VAUTD,VAUTC,BSDSRT,BSDCRI ;IHS/ITSC/LJF 1/9/2004
DATE ; -- select date
S BSDDT=$$READ^BDGF("D0^::EX","List Appointments for What Date")
Q:BSDDT<1
;
CLINIC ; -- all clinics or selected ones?
; if ALL clinics are selected, VAUTC=1
; otherwise the VAUTC array is set and VAUTC=0
D CLINIC^BSDU(1) I Y<0 D EXIT Q
;
SORTS ; -- sort by
NEW DIR0,DIRA,DIRB
;S DIR0="S^C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT"
;S DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT" ;IHS/ITSC/LJF 1/9/2004 cmi/anch/maw 11/5/2006 maw orig line item 1007.07 patch 1007
S DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT;A:BY APPOINTMENT TIME;U:BY PATIENT NAME" ;cmi/anch/maw 11/5/2006 maw new line item 1007.07 patch 1007
S DIRA="FILE ROOM LIST SORT ORDER"
S DIRB=$$GET1^DIQ(9009020.2,+$$DIV^BSDU,.17)
S BSDSRT=$$READ^BDGF(DIR0,DIRA,DIRB,"^D HELP^BSDFRL")
;I "CPT"'[BSDSRT D EXIT Q
;I "NCPT"'[BSDSRT D EXIT Q ;IHS/ITSC/LJF 1/9/2004 cmi/anch/maw 11/5/2006 original line item 1007.07 patch 1007
I "NCPTAU"'[BSDSRT D EXIT Q ;cmi/anch/maw 11/5/2006 new line item 1007.07 patch 1007
;
CHTRQ ; -- ask to include chart requests ;IHS/ITSC/LJF 1/9/2004
S BSDCRI=$$READ^BDGF("Y","Include CHART REQUESTS","NO") ;IHS/ITSC/LJF 1/9/2004
;
DEVICE ; -- select device
NEW DGVAR,PGM,POP
;S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT",PGM="START^BSDFRL"
S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT^BSDCRI",PGM="START^BSDFRL" ;IHS/ITSC/LJF 1/9/2004
D ZIS^DGUTQ I POP D EXIT Q
I '$D(IO("Q")) D START^BSDFRL
Q
;
;
START ;EP; entry to report after calling print device
;I $E(IOST,1,2)="C-" D EN Q ;use listman if using screen TODO
D GATHER,PRINT Q ;otherwise print to paper
;
EN ;EP; -- entry for list manager interface
NEW VALMCNT D TERM^VALM0
D EN^VALM("BSDRM FILE ROOM LIST")
D CLEAR^VALM1
Q
;
HDR ;EP; -- report heading
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
S VALMHDR(2)="FILE ROOM LIST FOR APPOINTMENTS & CHART REQUESTS for "
S VALMHDR(2)=$$SP(10)_VALMHDR(2)_$$FMTE^XLFDT(BSDDT)
Q
;
GATHER ;EP; -- gathers data and sets into display array
; build sorted array
K ^TMP("BSDFRL",$J),^TMP("BSDFRL1",$J)
S X=$S(VAUTC=1:"ALL",1:"SOME") D @X
;
; reset sorted array into display array
NEW A,B,C,D S BSDLN=0
S A=0 F S A=$O(^TMP("BSDFRL1",$J,A)) Q:A="" D
. ; add sort subheading
. I BSDSRT'="T" D
.. ;cmi/anch/maw 11/5/2006 added the next 2 lines for appointment time item 1007.07 patch 1007
.. I BSDSRT="A" D Q
... D SET("",.BSDLN),SET($$SP(3)_"**"_$$TM($P(A,".",2))_"**",.BSDLN)
.. ;cmi/anch/maw 11/5/2006 end of mods item 1007.07 patch 1007
.. D SET("",.BSDLN),SET($$SP(3)_"**"_A_"**",.BSDLN)
. ;
. S B=0 F S B=$O(^TMP("BSDFRL1",$J,A,B)) Q:B="" D
.. S C=0 F S C=$O(^TMP("BSDFRL1",$J,A,B,C)) Q:C="" D
... S D=0 F S D=$O(^TMP("BSDFRL1",$J,A,B,C,D)) Q:D="" D
.... D SET(^TMP("BSDFRL1",$J,A,B,C,D),.BSDLN)
.... I "ANC"[BSDSRT D CHKOC(A,C,D) ;cmi/anch/maw 2/5/2007 added to check to see if patient is in another clinic PATCH 1007 item 1007.10
;
S VALMCNT=BSDLN
K ^TMP("BSDFRL1",$J)
Q
;
CHKOC(CLN,PAT,DATE) ;-- check to see if the patient has another appointment on today
;cmi/anch/maw 2/5/2007 added to check for other appointments same day PATCH 1007 item 1007.10
S DATE=$P(DATE,".")
N J,K,L,M
S J=0 F S J=$O(^TMP("BSDFRL1",$J,J)) Q:J="" D
. I J=CLN Q
. ; add sort subheading
. S K=0 F S K=$O(^TMP("BSDFRL1",$J,J,K)) Q:K="" D
.. S L=0 F S L=$O(^TMP("BSDFRL1",$J,J,K,L)) Q:L="" D
... I L'=PAT Q
... S M=0 F S M=$O(^TMP("BSDFRL1",$J,J,K,L,M)) Q:M="" D
.... I $P(M,".")'=DATE Q
.... N SIX
.... S SIX=$E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)
.... S $E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)="*OTHER*"
.... D SET(^TMP("BSDFRL1",$J,J,K,L,M),.BSDLN)
.... S $E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)=SIX
Q
;
ALL ; -- loop thru all clinics
NEW BSDCLN,BSDSUB
S BSDCLN=0 F S BSDCLN=$O(^SC(BSDCLN)) Q:'BSDCLN D
. Q:'$$OKAY(BSDCLN) ;quit if not okay for file room list
. Q:'$$ACTV^BSDU(BSDCLN,BSDDT) ;quit if inactive
. I VAUTD=0 Q:'$D(VAUTD(+$$DIVC^BSDU(BSDCLN))) ;quit if not select div
. F BSDSUB="S","C" D GETAPPT ;get all appt & chart requests
Q
;
SOME ; -- loop thru selected clinics
NEW BSDCL,BSDCLN,BSDSUB
S BSDCL=0 F S BSDCL=$O(VAUTC(BSDCL)) Q:BSDCL="" D
. S BSDCLN=VAUTC(BSDCL) ;clinic ien
. Q:'$$OKAY(BSDCLN) ;quit if not okay for file room list
. Q:'$$ACTV^BSDU(BSDCLN,BSDDT) ;quit if inactive
. F BSDSUB="S","C" D GETAPPT ;get all appt & chart requests
Q
;
GETAPPT ; -- for clinic, get appts & chart requests for date
I BSDSUB="C",BSDCRI=0 Q ;don't include chart requests;IHS/ITSC/LJF 1/9/2004
NEW BSDT,BSDEND,BSDN,NODE,HRCN,TERM,SORT,LINE,X,BSDDFN
S BSDT=BSDDT-.0001,BSDEND=BSDDT_".2400"
F S BSDT=$O(^SC(BSDCLN,BSDSUB,BSDT)) Q:'BSDT Q:(BSDT>BSDEND) D
. S BSDN=0
. F S BSDN=$O(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN)) Q:'BSDN D
.. S NODE=$G(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN,0)) Q:'NODE
.. ;
.. ; set sort values
.. S BSDDFN=$P(NODE,U) ;cmi/anch/maw 11/7/2006 patient dfn item 1007.09 patch 1007
.. I BSDSRT="N" S SORT=$$GET1^DIQ(44,BSDCLN,.01) ;clinic name
.. I BSDSRT="C" S SORT=$$CLNCODE^BSDU(BSDCLN) ;clinic code
.. I BSDSRT="P" S SORT=$$PRIN^BSDU(BSDCLN) ;principal clinic
.. I BSDSRT="U" S SORT=$$GET1^DIQ(2,BSDDFN,.01) ;patient name cmi/anch/maw 11/5/2006 item 1007.07 patch 1007
.. I BSDSRT="A" S SORT=BSDT ;appointment time cmi/anch/maw 11/5/206 item 1007.07 patch 1007
.. S HRCN=$$HRCN^BDGF2(+NODE,$$FAC^BSDU(BSDCLN)) ;chart #
.. S TERM=$$HRCNT^BDGF2(HRCN) ;terminal digit format
.. I $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(BSDCLN),.18)="NO" D
... S TERM=$$HRCND^BDGF2(HRCN) ;no terminal digit per site param
.. I BSDSRT="T" S SORT=TERM ;terminal digit sort
.. ;
.. ; set display line
.. S LINE=$J(HRCN,7)_" "_$E($$GET1^DIQ(2,+NODE,.01),1,20) ;pat
.. ;S LINE=$$PAD(LINE,33)_"DOB: "_$$DOB(+NODE) ;dob cmi/anch/maw 11/5/2006 removed dob item 1007.09 patch 1007
.. S LINE=$$PAD(LINE,33)_$$GET1^DIQ(44,BSDCLN,.01) ;cln name cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
.. ;S LINE=LINE_" "_$E($$GET1^DIQ(44,BSDCLN,.01),1,15) ;cln name cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
.. I BSDSUB="S" D ;appt time
... ;I $P(NODE,U,9)="C" S LINE=$$PAD(LINE,65)_"**CANCELLED**"
... I $P(NODE,U,9)="C" S LINE=$$PAD(LINE,58)_"*CANCELLED*" ;IHS/ITSC/LJF 1/8/2004
... ;E S LINE=$$PAD(LINE,68)_"at "_$P($$FMTE^XLFDT(BSDT),"@",2) ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
... E S LINE=$$PAD(LINE,58)_$P($$FMTE^XLFDT(BSDT),"@",2) ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
... S LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$P(BSDT,".")) ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
.. ;I BSDSUB="C" S LINE=$$PAD(LINE,58)_"Cht Req" ;chart req cmi/anch/maw 11/7/2006 orig line
.. I BSDSUB="C" D ;chart req
... S LINE=$$PAD(LINE,58)_"Cht Req" ;chart req cmi/anch/maw 11/7/2006 new line for item 1007.09 patch 1007
... S LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$P(BSDT,".")) ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
.. ;
.. S ^TMP("BSDFRL1",$J,SORT,TERM,+NODE,BSDT)=LINE
.. ;
.. I $$DEAD^BDGF2(+NODE) S ^TMP("BSDFRL1",$J,SORT,TERM,+NODE,BSDT+.00001)=$$SP(10)_$G(IORVON)_"** Patient Died on "_$$DOD^BDGF2(+NODE)_" **"_$G(IORVOFF)
;
Q
;
PRINT ; -- print to paper
;IHS/ITSC/WAR 7/30/04 PATCH #1001
;U IO D HDR NEW X
U IO NEW BSDLN
I BSDSRT="T" D HEADING
I BSDSRT="U" D HEADING ;cmi/anch/maw 10/29/2007 patch 1008
;S X=0 F S X=$O(^TMP("BSDFRL",$J,X)) Q:'X D
S BSDLN=0 F S BSDLN=$O(^TMP("BSDFRL",$J,BSDLN)) Q:'BSDLN D
. ;I ^TMP("BSDFRL",$J,X,0)["**" D HEADING ;IHS/ITSC/LJF 1/2/2004
. ;I ^TMP("BSDFRL",$J,BSDLN,0)["**" D HEADING cmi/anch/maw 10/29/2007 orig line
. I ^TMP("BSDFRL",$J,BSDLN,0)["**",BSDSRT'="U" D HEADING ;cmi/anch/maw 10/29/2007 patch 1008
. I $Y>(IOSL-4) D HEADING
. ;W !,^TMP("BSDFRL",$J,X,0)
. W !,^TMP("BSDFRL",$J,BSDLN,0)
;PATCH #1001 END OF CHANGES
D ^%ZISC,EXIT
Q
;
HEADING ; -- heading for paper report
NEW X ;IHS/ITSC/LJF 12/11/2003
D HDR W @IOF,!,VALMHDR(1),!,VALMHDR(2)
;IHS/ITSC/WAR 8/26/04 PATCH #1001 added in Col. headings
;W !,?55,"Printed on ",$$FMTE^XLFDT(DT),!,$$REPEAT^XLFSTR("=",79),!
;W !,?3,"HRCN",?9,"Patient Name",?33,"Date of Birth",?50,"Clinic",?68,"Appt Time",!,$$REPEAT^XLFSTR("=",79),! ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
W !,?3,"HRCN",?9,"Patient Name",?33,"Clinic",?58,"Appt Time",?68,"Insurance",!,$$REPEAT^XLFSTR("=",79),! ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
Q
;
EXIT ;
K ^TMP("BSDFRL",$J) K BSDLN
Q
;
HELP1 ;
S X="?" D DISP^XQORM1 W !!
Q
;
OKAY(CLN) ; -- returns 1 if okay to use in file room list
I $$GET1^DIQ(44,CLN,2,"I")'="C" Q 0 ;not a clinic
NEW X,Y
S X=$$GET1^DIQ(44,CLN,2502) ;non-count clinic value
S Y=$$GET1^DIQ(44,CLN,2502.5) ;include on file room list value
;IHS/ITSC/WAR 5/27/2004 P #1001 added next line
I X="NO"&(Y="NO") Q 0
I X'="YES" Q 1 ;counted clinic
I Y="YES" Q 1 ;okay to include
Q 0 ;else don't include
;
SET(DATA,LINE) ; -- puts data into display array
S LINE=LINE+1
S ^TMP("BSDFRL",$J,LINE,0)=DATA
Q
;
HELP ;EP; -- help for SORTS question
D MSG^BDGF("Enter N to print by Clinic Name then terminal digit",2,0) ;IHS/ITSC/LJF 1/9/2004
D MSG^BDGF("Enter C to print by Clinic Code then terminal digit",2,1)
D MSG^BDGF("Enter P to print by Principal Clinic then terminal digit")
D MSG^BDGF("Enter T to print by Terminal Digit order only",2,1)
D MSG^BDGF("If your file room does NOT sort by terminal digit",1,0)
D MSG^BDGF(" AND you set the site parameter that way,",1,0)
D MSG^BDGF(" then the report will use chart # order.",1,1)
Q
;
DOB(PAT) ; -- return date of birth in numerical format with leading zeros
NEW X S X=$$GET1^DIQ(2,PAT,.03,"I")
Q $S('X:"??",1:$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)))
;
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)
;
TM(T) ; -- cmi/anch/maw 11/5/26 item 1007.07 patch 1007 return trailing zeroes on time
N I,J,Z
S Z=(4-$L(T)) F I=1:1:Z S T=T_"0"
S T=$E(T,1,2)_":"_$E(T,3,4)
Q T
;
BSDFRL ; IHS/ANMC/LJF - IHS FILE ROOM LIST ;
+1 ;;5.3;PIMS;**1007,1008**;DEC 01, 2006
+2 ;
+3 ;cmi/anch/maw 11/22/2006 PATCH 1007 added code in GETAPPT,GATHER,SORTS for item 1007.07
+4 ;cmi/anch/maw 2/5/2007 PATCH 1007 added code in GATHER to look for appt on same day and print if there
+5 ;
+6 ;IHS/ITSC/LJF 1/9/2004
NEW BSDDT,VAUTD,VAUTC,BSDSRT,BSDCRI
DATE ; -- select date
+1 SET BSDDT=$$READ^BDGF("D0^::EX","List Appointments for What Date")
+2 IF BSDDT<1
QUIT
+3 ;
CLINIC ; -- all clinics or selected ones?
+1 ; if ALL clinics are selected, VAUTC=1
+2 ; otherwise the VAUTC array is set and VAUTC=0
+3 DO CLINIC^BSDU(1)
IF Y<0
DO EXIT
QUIT
+4 ;
SORTS ; -- sort by
+1 NEW DIR0,DIRA,DIRB
+2 ;S DIR0="S^C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT"
+3 ;S DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT" ;IHS/ITSC/LJF 1/9/2004 cmi/anch/maw 11/5/2006 maw orig line item 1007.07 patch 1007
+4 ;cmi/anch/maw 11/5/2006 maw new line item 1007.07 patch 1007
SET DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT;A:BY APPOINTMENT TIME;U:BY PATIENT NAME"
+5 SET DIRA="FILE ROOM LIST SORT ORDER"
+6 SET DIRB=$$GET1^DIQ(9009020.2,+$$DIV^BSDU,.17)
+7 SET BSDSRT=$$READ^BDGF(DIR0,DIRA,DIRB,"^D HELP^BSDFRL")
+8 ;I "CPT"'[BSDSRT D EXIT Q
+9 ;I "NCPT"'[BSDSRT D EXIT Q ;IHS/ITSC/LJF 1/9/2004 cmi/anch/maw 11/5/2006 original line item 1007.07 patch 1007
+10 ;cmi/anch/maw 11/5/2006 new line item 1007.07 patch 1007
IF "NCPTAU"'[BSDSRT
DO EXIT
QUIT
+11 ;
CHTRQ ; -- ask to include chart requests ;IHS/ITSC/LJF 1/9/2004
+1 ;IHS/ITSC/LJF 1/9/2004
SET BSDCRI=$$READ^BDGF("Y","Include CHART REQUESTS","NO")
+2 ;
DEVICE ; -- select device
+1 NEW DGVAR,PGM,POP
+2 ;S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT",PGM="START^BSDFRL"
+3 ;IHS/ITSC/LJF 1/9/2004
SET DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT^BSDCRI"
SET PGM="START^BSDFRL"
+4 DO ZIS^DGUTQ
IF POP
DO EXIT
QUIT
+5 IF '$DATA(IO("Q"))
DO START^BSDFRL
+6 QUIT
+7 ;
+8 ;
START ;EP; entry to report after calling print device
+1 ;I $E(IOST,1,2)="C-" D EN Q ;use listman if using screen TODO
+2 ;otherwise print to paper
DO GATHER
DO PRINT
QUIT
+3 ;
EN ;EP; -- entry for list manager interface
+1 NEW VALMCNT
DO TERM^VALM0
+2 DO EN^VALM("BSDRM FILE ROOM LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ;EP; -- report heading
+1 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+2 SET VALMHDR(2)="FILE ROOM LIST FOR APPOINTMENTS & CHART REQUESTS for "
+3 SET VALMHDR(2)=$$SP(10)_VALMHDR(2)_$$FMTE^XLFDT(BSDDT)
+4 QUIT
+5 ;
GATHER ;EP; -- gathers data and sets into display array
+1 ; build sorted array
+2 KILL ^TMP("BSDFRL",$JOB),^TMP("BSDFRL1",$JOB)
+3 SET X=$SELECT(VAUTC=1:"ALL",1:"SOME")
DO @X
+4 ;
+5 ; reset sorted array into display array
+6 NEW A,B,C,D
SET BSDLN=0
+7 SET A=0
FOR
SET A=$ORDER(^TMP("BSDFRL1",$JOB,A))
IF A=""
QUIT
Begin DoDot:1
+8 ; add sort subheading
+9 IF BSDSRT'="T"
Begin DoDot:2
+10 ;cmi/anch/maw 11/5/2006 added the next 2 lines for appointment time item 1007.07 patch 1007
+11 IF BSDSRT="A"
Begin DoDot:3
+12 DO SET("",.BSDLN)
DO SET($$SP(3)_"**"_$$TM($PIECE(A,".",2))_"**",.BSDLN)
End DoDot:3
QUIT
+13 ;cmi/anch/maw 11/5/2006 end of mods item 1007.07 patch 1007
+14 DO SET("",.BSDLN)
DO SET($$SP(3)_"**"_A_"**",.BSDLN)
End DoDot:2
+15 ;
+16 SET B=0
FOR
SET B=$ORDER(^TMP("BSDFRL1",$JOB,A,B))
IF B=""
QUIT
Begin DoDot:2
+17 SET C=0
FOR
SET C=$ORDER(^TMP("BSDFRL1",$JOB,A,B,C))
IF C=""
QUIT
Begin DoDot:3
+18 SET D=0
FOR
SET D=$ORDER(^TMP("BSDFRL1",$JOB,A,B,C,D))
IF D=""
QUIT
Begin DoDot:4
+19 DO SET(^TMP("BSDFRL1",$JOB,A,B,C,D),.BSDLN)
+20 ;cmi/anch/maw 2/5/2007 added to check to see if patient is in another clinic PATCH 1007 item 1007.10
IF "ANC"[BSDSRT
DO CHKOC(A,C,D)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 SET VALMCNT=BSDLN
+23 KILL ^TMP("BSDFRL1",$JOB)
+24 QUIT
+25 ;
CHKOC(CLN,PAT,DATE) ;-- check to see if the patient has another appointment on today
+1 ;cmi/anch/maw 2/5/2007 added to check for other appointments same day PATCH 1007 item 1007.10
+2 SET DATE=$PIECE(DATE,".")
+3 NEW J,K,L,M
+4 SET J=0
FOR
SET J=$ORDER(^TMP("BSDFRL1",$JOB,J))
IF J=""
QUIT
Begin DoDot:1
+5 IF J=CLN
QUIT
+6 ; add sort subheading
+7 SET K=0
FOR
SET K=$ORDER(^TMP("BSDFRL1",$JOB,J,K))
IF K=""
QUIT
Begin DoDot:2
+8 SET L=0
FOR
SET L=$ORDER(^TMP("BSDFRL1",$JOB,J,K,L))
IF L=""
QUIT
Begin DoDot:3
+9 IF L'=PAT
QUIT
+10 SET M=0
FOR
SET M=$ORDER(^TMP("BSDFRL1",$JOB,J,K,L,M))
IF M=""
QUIT
Begin DoDot:4
+11 IF $PIECE(M,".")'=DATE
QUIT
+12 NEW SIX
+13 SET SIX=$EXTRACT(^TMP("BSDFRL1",$JOB,J,K,L,M),1,7)
+14 SET $EXTRACT(^TMP("BSDFRL1",$JOB,J,K,L,M),1,7)="*OTHER*"
+15 DO SET(^TMP("BSDFRL1",$JOB,J,K,L,M),.BSDLN)
+16 SET $EXTRACT(^TMP("BSDFRL1",$JOB,J,K,L,M),1,7)=SIX
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
ALL ; -- loop thru all clinics
+1 NEW BSDCLN,BSDSUB
+2 SET BSDCLN=0
FOR
SET BSDCLN=$ORDER(^SC(BSDCLN))
IF 'BSDCLN
QUIT
Begin DoDot:1
+3 ;quit if not okay for file room list
IF '$$OKAY(BSDCLN)
QUIT
+4 ;quit if inactive
IF '$$ACTV^BSDU(BSDCLN,BSDDT)
QUIT
+5 ;quit if not select div
IF VAUTD=0
IF '$DATA(VAUTD(+$$DIVC^BSDU(BSDCLN)))
QUIT
+6 ;get all appt & chart requests
FOR BSDSUB="S","C"
DO GETAPPT
End DoDot:1
+7 QUIT
+8 ;
SOME ; -- loop thru selected clinics
+1 NEW BSDCL,BSDCLN,BSDSUB
+2 SET BSDCL=0
FOR
SET BSDCL=$ORDER(VAUTC(BSDCL))
IF BSDCL=""
QUIT
Begin DoDot:1
+3 ;clinic ien
SET BSDCLN=VAUTC(BSDCL)
+4 ;quit if not okay for file room list
IF '$$OKAY(BSDCLN)
QUIT
+5 ;quit if inactive
IF '$$ACTV^BSDU(BSDCLN,BSDDT)
QUIT
+6 ;get all appt & chart requests
FOR BSDSUB="S","C"
DO GETAPPT
End DoDot:1
+7 QUIT
+8 ;
GETAPPT ; -- for clinic, get appts & chart requests for date
+1 ;don't include chart requests;IHS/ITSC/LJF 1/9/2004
IF BSDSUB="C"
IF BSDCRI=0
QUIT
+2 NEW BSDT,BSDEND,BSDN,NODE,HRCN,TERM,SORT,LINE,X,BSDDFN
+3 SET BSDT=BSDDT-.0001
SET BSDEND=BSDDT_".2400"
+4 FOR
SET BSDT=$ORDER(^SC(BSDCLN,BSDSUB,BSDT))
IF 'BSDT
QUIT
IF (BSDT>BSDEND)
QUIT
Begin DoDot:1
+5 SET BSDN=0
+6 FOR
SET BSDN=$ORDER(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN))
IF 'BSDN
QUIT
Begin DoDot:2
+7 SET NODE=$GET(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN,0))
IF 'NODE
QUIT
+8 ;
+9 ; set sort values
+10 ;cmi/anch/maw 11/7/2006 patient dfn item 1007.09 patch 1007
SET BSDDFN=$PIECE(NODE,U)
+11 ;clinic name
IF BSDSRT="N"
SET SORT=$$GET1^DIQ(44,BSDCLN,.01)
+12 ;clinic code
IF BSDSRT="C"
SET SORT=$$CLNCODE^BSDU(BSDCLN)
+13 ;principal clinic
IF BSDSRT="P"
SET SORT=$$PRIN^BSDU(BSDCLN)
+14 ;patient name cmi/anch/maw 11/5/2006 item 1007.07 patch 1007
IF BSDSRT="U"
SET SORT=$$GET1^DIQ(2,BSDDFN,.01)
+15 ;appointment time cmi/anch/maw 11/5/206 item 1007.07 patch 1007
IF BSDSRT="A"
SET SORT=BSDT
+16 ;chart #
SET HRCN=$$HRCN^BDGF2(+NODE,$$FAC^BSDU(BSDCLN))
+17 ;terminal digit format
SET TERM=$$HRCNT^BDGF2(HRCN)
+18 IF $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(BSDCLN),.18)="NO"
Begin DoDot:3
+19 ;no terminal digit per site param
SET TERM=$$HRCND^BDGF2(HRCN)
End DoDot:3
+20 ;terminal digit sort
IF BSDSRT="T"
SET SORT=TERM
+21 ;
+22 ; set display line
+23 ;pat
SET LINE=$JUSTIFY(HRCN,7)_" "_$EXTRACT($$GET1^DIQ(2,+NODE,.01),1,20)
+24 ;S LINE=$$PAD(LINE,33)_"DOB: "_$$DOB(+NODE) ;dob cmi/anch/maw 11/5/2006 removed dob item 1007.09 patch 1007
+25 ;cln name cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
SET LINE=$$PAD(LINE,33)_$$GET1^DIQ(44,BSDCLN,.01)
+26 ;S LINE=LINE_" "_$E($$GET1^DIQ(44,BSDCLN,.01),1,15) ;cln name cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
+27 ;appt time
IF BSDSUB="S"
Begin DoDot:3
+28 ;I $P(NODE,U,9)="C" S LINE=$$PAD(LINE,65)_"**CANCELLED**"
+29 ;IHS/ITSC/LJF 1/8/2004
IF $PIECE(NODE,U,9)="C"
SET LINE=$$PAD(LINE,58)_"*CANCELLED*"
+30 ;E S LINE=$$PAD(LINE,68)_"at "_$P($$FMTE^XLFDT(BSDT),"@",2) ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
+31 ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
IF '$TEST
SET LINE=$$PAD(LINE,58)_$PIECE($$FMTE^XLFDT(BSDT),"@",2)
+32 ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
SET LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$PIECE(BSDT,"."))
End DoDot:3
+33 ;I BSDSUB="C" S LINE=$$PAD(LINE,58)_"Cht Req" ;chart req cmi/anch/maw 11/7/2006 orig line
+34 ;chart req
IF BSDSUB="C"
Begin DoDot:3
+35 ;chart req cmi/anch/maw 11/7/2006 new line for item 1007.09 patch 1007
SET LINE=$$PAD(LINE,58)_"Cht Req"
+36 ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
SET LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$PIECE(BSDT,"."))
End DoDot:3
+37 ;
+38 SET ^TMP("BSDFRL1",$JOB,SORT,TERM,+NODE,BSDT)=LINE
+39 ;
+40 IF $$DEAD^BDGF2(+NODE)
SET ^TMP("BSDFRL1",$JOB,SORT,TERM,+NODE,BSDT+.00001)=$$SP(10)_$GET(IORVON)_"** Patient Died on "_$$DOD^BDGF2(+NODE)_" **"_$GET(IORVOFF)
End DoDot:2
End DoDot:1
+41 ;
+42 QUIT
+43 ;
PRINT ; -- print to paper
+1 ;IHS/ITSC/WAR 7/30/04 PATCH #1001
+2 ;U IO D HDR NEW X
+3 USE IO
NEW BSDLN
+4 IF BSDSRT="T"
DO HEADING
+5 ;cmi/anch/maw 10/29/2007 patch 1008
IF BSDSRT="U"
DO HEADING
+6 ;S X=0 F S X=$O(^TMP("BSDFRL",$J,X)) Q:'X D
+7 SET BSDLN=0
FOR
SET BSDLN=$ORDER(^TMP("BSDFRL",$JOB,BSDLN))
IF 'BSDLN
QUIT
Begin DoDot:1
+8 ;I ^TMP("BSDFRL",$J,X,0)["**" D HEADING ;IHS/ITSC/LJF 1/2/2004
+9 ;I ^TMP("BSDFRL",$J,BSDLN,0)["**" D HEADING cmi/anch/maw 10/29/2007 orig line
+10 ;cmi/anch/maw 10/29/2007 patch 1008
IF ^TMP("BSDFRL",$JOB,BSDLN,0)["**"
IF BSDSRT'="U"
DO HEADING
+11 IF $Y>(IOSL-4)
DO HEADING
+12 ;W !,^TMP("BSDFRL",$J,X,0)
+13 WRITE !,^TMP("BSDFRL",$JOB,BSDLN,0)
End DoDot:1
+14 ;PATCH #1001 END OF CHANGES
+15 DO ^%ZISC
DO EXIT
+16 QUIT
+17 ;
HEADING ; -- heading for paper report
+1 ;IHS/ITSC/LJF 12/11/2003
NEW X
+2 DO HDR
WRITE @IOF,!,VALMHDR(1),!,VALMHDR(2)
+3 ;IHS/ITSC/WAR 8/26/04 PATCH #1001 added in Col. headings
+4 ;W !,?55,"Printed on ",$$FMTE^XLFDT(DT),!,$$REPEAT^XLFSTR("=",79),!
+5 ;W !,?3,"HRCN",?9,"Patient Name",?33,"Date of Birth",?50,"Clinic",?68,"Appt Time",!,$$REPEAT^XLFSTR("=",79),! ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
+6 ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
WRITE !,?3,"HRCN",?9,"Patient Name",?33,"Clinic",?58,"Appt Time",?68,"Insurance",!,$$REPEAT^XLFSTR("=",79),!
+7 QUIT
+8 ;
EXIT ;
+1 KILL ^TMP("BSDFRL",$JOB)
KILL BSDLN
+2 QUIT
+3 ;
HELP1 ;
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
OKAY(CLN) ; -- returns 1 if okay to use in file room list
+1 ;not a clinic
IF $$GET1^DIQ(44,CLN,2,"I")'="C"
QUIT 0
+2 NEW X,Y
+3 ;non-count clinic value
SET X=$$GET1^DIQ(44,CLN,2502)
+4 ;include on file room list value
SET Y=$$GET1^DIQ(44,CLN,2502.5)
+5 ;IHS/ITSC/WAR 5/27/2004 P #1001 added next line
+6 IF X="NO"&(Y="NO")
QUIT 0
+7 ;counted clinic
IF X'="YES"
QUIT 1
+8 ;okay to include
IF Y="YES"
QUIT 1
+9 ;else don't include
QUIT 0
+10 ;
SET(DATA,LINE) ; -- puts data into display array
+1 SET LINE=LINE+1
+2 SET ^TMP("BSDFRL",$JOB,LINE,0)=DATA
+3 QUIT
+4 ;
HELP ;EP; -- help for SORTS question
+1 ;IHS/ITSC/LJF 1/9/2004
DO MSG^BDGF("Enter N to print by Clinic Name then terminal digit",2,0)
+2 DO MSG^BDGF("Enter C to print by Clinic Code then terminal digit",2,1)
+3 DO MSG^BDGF("Enter P to print by Principal Clinic then terminal digit")
+4 DO MSG^BDGF("Enter T to print by Terminal Digit order only",2,1)
+5 DO MSG^BDGF("If your file room does NOT sort by terminal digit",1,0)
+6 DO MSG^BDGF(" AND you set the site parameter that way,",1,0)
+7 DO MSG^BDGF(" then the report will use chart # order.",1,1)
+8 QUIT
+9 ;
DOB(PAT) ; -- return date of birth in numerical format with leading zeros
+1 NEW X
SET X=$$GET1^DIQ(2,PAT,.03,"I")
+2 QUIT $SELECT('X:"??",1:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3)))
+3 ;
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 ;
TM(T) ; -- cmi/anch/maw 11/5/26 item 1007.07 patch 1007 return trailing zeroes on time
+1 NEW I,J,Z
+2 SET Z=(4-$LENGTH(T))
FOR I=1:1:Z
SET T=T_"0"
+3 SET T=$EXTRACT(T,1,2)_":"_$EXTRACT(T,3,4)
+4 QUIT T
+5 ;
