Routine: BSDRFC

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

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

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"

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)

SET(DATA,NUM) ; -- stuff line into array

 S NUM=NUM+1

 S ^TMP("BSDRFC",$J,NUM,0)=DATA

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

 K BSDLN,BSDT,VAUTC,VAUTD,POP K ^TMP("BSDRFC",$J)

EXPND ; -- expand code

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

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),!

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)

BSDRFC.m