BSDRFC ; IHS/ANMC/LJF - RADIOLOGY PULL LIST ; [ 11/02/2004 11:45 AM ]
;;5.3;PIMS;**1001**;APR 26, 2002
;
ASK ; -- ask user for division/clinic selections
D CLINIC^BSDU(1) Q:$D(BSDU)
S BSDT=$$READ^BDGF("DO^::EX","Print For Which Date") Q:BSDT<1
;IHS/ITSC/WAR 8/3/04 PATCH #1001 Added .VALMHDR variable for printing
;D ZIS^BDGF("QP","BEG^BSDRFC","RAD PULL LIST","VAUTC;VAUTD;BSDT;.HALMHDR")
D ZIS^BDGF("QP","BEG^BSDRFC","RAD PULL LIST","VAUTC;VAUTD;BSDT;VALMHDR") ;IHS/ITSC/LJF 10/25/2004
Q
;
BEG ;EP; entry point when queuing
I $E(IOST,1,2)="C-" D EN Q
D INIT,PRINT Q
;
EN ; -- main entry point for BSDRM RAD PULL LIST
NEW VALMCNT D TERM^VALM0
D EN^VALM("BSDRM RAD PULL LIST")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
NEW X S X="The following patients have appointments on "
S VALMHDR(2)=$$SP(10)_X_$$FMTE^XLFDT(BSDT)
S VALMHDR(3)=$$SP(15)_"and need their previous radiology films pulled"
;IHS/ITSC/WAR 8/3/04 PATCH #1001 Added next 2 lineS - missing on printout
S VALMHDR(4)=" "
S VALMHDR(5)="Chart # Patient Name Clinic Appt Time"
Q
;
INIT ; -- init variables and list array
NEW CLINIC,DATE,END,DFN,HRCN,TERM
S BSDLN=0 K ^TMP("BSDRFC",$J),^TMP("BSDRFC1",$J)
;
; loop thru ARAD xref to find charts to pull
S CLINIC=0 F S CLINIC=$O(^SC("ARAD",CLINIC)) Q:'CLINIC D
. I 'VAUTD,'$D(VAUTD(+$$DIVC^BSDU(CLINIC))) Q ;not in division selectd
. I 'VAUTC,'$D(VAUTC($$GET1^DIQ(44,CLINIC,.01))) Q ;clnc not selctd
. ;
. ; loop thru selected date and set into order
. S DATE=BSDT-.0001,END=BSDT_".2400"
. F S DATE=$O(^SC("ARAD",CLINIC,DATE)) Q:'DATE Q:(DATE>END) D
.. S DFN=0 F S DFN=$O(^SC("ARAD",CLINIC,DATE,DFN)) Q:'DFN D
... Q:$P(^SC("ARAD",CLINIC,DATE,DFN),U)="N" ;don't pull
... S HRCN=$$HRCN^BDGF2(DFN,$$FAC^BSDU(CLINIC)) ;chart #
... I $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(CLINIC),.18)'="NO" D
.... S TERM=$$HRCNT^BDGF2(HRCN) ;convert to terminal digit
... E S TERM=$$HRCND^BDGF2(HRCN) ;add dashes to sort properly
... S ^TMP("BSDRFC1",$J,TERM,DFN,DATE)=CLINIC_U_HRCN
;
; if none found, say so
I '$D(^TMP("BSDRFC1",$J)) D Q
. D SET($$SP(20)_"** NO CHARTS TO PULL FOR DATE **",.BSDLN) S VALMCNT=1
;
; loop thru sorted list & create display array
NEW A,B,C,LINE,NODE
S A=0 F S A=$O(^TMP("BSDRFC1",$J,A)) Q:A="" D
. S B=0 F S B=$O(^TMP("BSDRFC1",$J,A,B)) Q:'B D
.. S C=0 F S C=$O(^TMP("BSDRFC1",$J,A,B,C)) Q:'C D
... S NODE=^TMP("BSDRFC1",$J,A,B,C)
... ;
... ; set up line: chart # - name - clinic - appt time
... S LINE=$J($P(NODE,U,2),7)_" "_$E($$GET1^DIQ(2,B,.01),1,18)
... S LINE=$$PAD(LINE,34)_$$GET1^DIQ(44,+NODE,.01)
... S LINE=$$PAD(LINE,60)_$$FMTE^XLFDT(C,5)
... D SET(LINE,.BSDLN) ;add to display array
... I $$DEAD^BDGF2(B) D
.... S LINE=$$SP(10)_$G(IORVON)_"** Patient Died on "_$$DOD^BDGF2(B)_" **"_$G(IORVOFF)
.... D SET(LINE,.BSDLN),SET("",.BSDLN)
;
S VALMCNT=BSDLN K ^TMP("BSDRFC1",$J)
Q
;
SET(DATA,NUM) ; -- stuff line into array
S NUM=NUM+1
S ^TMP("BSDRFC",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K BSDLN,BSDT,VAUTC,VAUTD,POP K ^TMP("BSDRFC",$J)
Q
;
EXPND ; -- expand code
Q
;
PRINT ; -- print report to paper
NEW BSDN
U IO D HDG S BSDN=0
F S BSDN=$O(^TMP("BSDRFC",$J,BSDN)) Q:'BSDN D
. ;I $Y>(IOST-4) D HDG
. I $Y>(IOSL-4) D HDG ;IHS/ITSC/LJF 4/29/2004 PATCH #1001
. W !,^TMP("BSDRFC",$J,BSDN,0)
D ^%ZISC,EXIT
Q
;
HDG ; -- print heading on paper
NEW VALMHDR D HDR
W @IOF W !!?20,"RADIOLOGY PULL LIST"
;IHS/ITSC/WAR 3/1/04 added the missing subscript
;F I=1:1 Q:'$D(VALMHDR) W VALMHDR(I)
;F I=1:1 Q:'$D(VALMHDR(I)) W VALMHDR(I)
F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I) ;IHS/ITSC/LJF 4/29/2004 PATCH #1001
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)
BSDRFC ; IHS/ANMC/LJF - RADIOLOGY PULL LIST ; [ 11/02/2004 11:45 AM ]
+1 ;;5.3;PIMS;**1001**;APR 26, 2002
+2 ;
ASK ; -- ask user for division/clinic selections
+1 DO CLINIC^BSDU(1)
IF $DATA(BSDU)
QUIT
+2 SET BSDT=$$READ^BDGF("DO^::EX","Print For Which Date")
IF BSDT<1
QUIT
+3 ;IHS/ITSC/WAR 8/3/04 PATCH #1001 Added .VALMHDR variable for printing
+4 ;D ZIS^BDGF("QP","BEG^BSDRFC","RAD PULL LIST","VAUTC;VAUTD;BSDT;.HALMHDR")
+5 ;IHS/ITSC/LJF 10/25/2004
DO ZIS^BDGF("QP","BEG^BSDRFC","RAD PULL LIST","VAUTC;VAUTD;BSDT;VALMHDR")
+6 QUIT
+7 ;
BEG ;EP; entry point when queuing
+1 IF $EXTRACT(IOST,1,2)="C-"
DO EN
QUIT
+2 DO INIT
DO PRINT
QUIT
+3 ;
EN ; -- main entry point for BSDRM RAD PULL LIST
+1 NEW VALMCNT
DO TERM^VALM0
+2 DO EN^VALM("BSDRM RAD PULL LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+2 NEW X
SET X="The following patients have appointments on "
+3 SET VALMHDR(2)=$$SP(10)_X_$$FMTE^XLFDT(BSDT)
+4 SET VALMHDR(3)=$$SP(15)_"and need their previous radiology films pulled"
+5 ;IHS/ITSC/WAR 8/3/04 PATCH #1001 Added next 2 lineS - missing on printout
+6 SET VALMHDR(4)=" "
+7 SET VALMHDR(5)="Chart # Patient Name Clinic Appt Time"
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 NEW CLINIC,DATE,END,DFN,HRCN,TERM
+2 SET BSDLN=0
KILL ^TMP("BSDRFC",$JOB),^TMP("BSDRFC1",$JOB)
+3 ;
+4 ; loop thru ARAD xref to find charts to pull
+5 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^SC("ARAD",CLINIC))
IF 'CLINIC
QUIT
Begin DoDot:1
+6 ;not in division selectd
IF 'VAUTD
IF '$DATA(VAUTD(+$$DIVC^BSDU(CLINIC)))
QUIT
+7 ;clnc not selctd
IF 'VAUTC
IF '$DATA(VAUTC($$GET1^DIQ(44,CLINIC,.01)))
QUIT
+8 ;
+9 ; loop thru selected date and set into order
+10 SET DATE=BSDT-.0001
SET END=BSDT_".2400"
+11 FOR
SET DATE=$ORDER(^SC("ARAD",CLINIC,DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:2
+12 SET DFN=0
FOR
SET DFN=$ORDER(^SC("ARAD",CLINIC,DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+13 ;don't pull
IF $PIECE(^SC("ARAD",CLINIC,DATE,DFN),U)="N"
QUIT
+14 ;chart #
SET HRCN=$$HRCN^BDGF2(DFN,$$FAC^BSDU(CLINIC))
+15 IF $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(CLINIC),.18)'="NO"
Begin DoDot:4
+16 ;convert to terminal digit
SET TERM=$$HRCNT^BDGF2(HRCN)
End DoDot:4
+17 ;add dashes to sort properly
IF '$TEST
SET TERM=$$HRCND^BDGF2(HRCN)
+18 SET ^TMP("BSDRFC1",$JOB,TERM,DFN,DATE)=CLINIC_U_HRCN
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ; if none found, say so
+21 IF '$DATA(^TMP("BSDRFC1",$JOB))
Begin DoDot:1
+22 DO SET($$SP(20)_"** NO CHARTS TO PULL FOR DATE **",.BSDLN)
SET VALMCNT=1
End DoDot:1
QUIT
+23 ;
+24 ; loop thru sorted list & create display array
+25 NEW A,B,C,LINE,NODE
+26 SET A=0
FOR
SET A=$ORDER(^TMP("BSDRFC1",$JOB,A))
IF A=""
QUIT
Begin DoDot:1
+27 SET B=0
FOR
SET B=$ORDER(^TMP("BSDRFC1",$JOB,A,B))
IF 'B
QUIT
Begin DoDot:2
+28 SET C=0
FOR
SET C=$ORDER(^TMP("BSDRFC1",$JOB,A,B,C))
IF 'C
QUIT
Begin DoDot:3
+29 SET NODE=^TMP("BSDRFC1",$JOB,A,B,C)
+30 ;
+31 ; set up line: chart # - name - clinic - appt time
+32 SET LINE=$JUSTIFY($PIECE(NODE,U,2),7)_" "_$EXTRACT($$GET1^DIQ(2,B,.01),1,18)
+33 SET LINE=$$PAD(LINE,34)_$$GET1^DIQ(44,+NODE,.01)
+34 SET LINE=$$PAD(LINE,60)_$$FMTE^XLFDT(C,5)
+35 ;add to display array
DO SET(LINE,.BSDLN)
+36 IF $$DEAD^BDGF2(B)
Begin DoDot:4
+37 SET LINE=$$SP(10)_$GET(IORVON)_"** Patient Died on "_$$DOD^BDGF2(B)_" **"_$GET(IORVOFF)
+38 DO SET(LINE,.BSDLN)
DO SET("",.BSDLN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 SET VALMCNT=BSDLN
KILL ^TMP("BSDRFC1",$JOB)
+41 QUIT
+42 ;
SET(DATA,NUM) ; -- stuff line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BSDRFC",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL BSDLN,BSDT,VAUTC,VAUTD,POP
KILL ^TMP("BSDRFC",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ; -- print report to paper
+1 NEW BSDN
+2 USE IO
DO HDG
SET BSDN=0
+3 FOR
SET BSDN=$ORDER(^TMP("BSDRFC",$JOB,BSDN))
IF 'BSDN
QUIT
Begin DoDot:1
+4 ;I $Y>(IOST-4) D HDG
+5 ;IHS/ITSC/LJF 4/29/2004 PATCH #1001
IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BSDRFC",$JOB,BSDN,0)
End DoDot:1
+7 DO ^%ZISC
DO EXIT
+8 QUIT
+9 ;
HDG ; -- print heading on paper
+1 NEW VALMHDR
DO HDR
+2 WRITE @IOF
WRITE !!?20,"RADIOLOGY PULL LIST"
+3 ;IHS/ITSC/WAR 3/1/04 added the missing subscript
+4 ;F I=1:1 Q:'$D(VALMHDR) W VALMHDR(I)
+5 ;F I=1:1 Q:'$D(VALMHDR(I)) W VALMHDR(I)
+6 ;IHS/ITSC/LJF 4/29/2004 PATCH #1001
FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+7 WRITE !,$$REPEAT^XLFSTR("=",80),!
+8 QUIT
+9 ;
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)
