BDGILD6.m

BDGILD6 ; IHS/ANMC/LJF - FACILITY TRANSFERS ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

EN ; -- main entry point for BDG ILD FACILITY TRANSFERS

 I $E(IOST,1,2)="P-" D INIT,PRINT Q

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG ILD FACILITY TRANSFERS")

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

 S VALMHDR(1)=$$SP(15)_$$CONF^BDGF

 S X="Transfers to/from "_$$GET1^DIQ(4,DUZ(2),.01)

 S VALMHDR(2)=$$SP(79-$L(X)\2)_X

 S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 S VALMHDR(3)=$$SP(79-$L(X)\2)_X

 ;

 I BDGTYP=1 S VALMCAP=$$PAD($$PAD($$PAD($$PAD($$PAD(" Admt/Dsch Date",17)_"Patient Name",41)_"HRCN",52)_"Serv",60)_"Facility",80)

 Q

 ;

INIT ; -- init variables and list array

 K ^TMP("BDGILD6",$J)

 S VALMCNT=0

 D ^BDGILD61

 ;

 I '$D(^TMP("BDGILD6",$J)) D

 . S VALMCNT=1,^TMP("BDGILD6",$J,1,0)="No data found"

 ;

 Q

 ;

PRINT ; print report to paper

 NEW LINE,BDGPG

 U IO D INIT^BDGF,HDG

 ;

 S LINE=0 F  S LINE=$O(^TMP("BDGILD6",$J,LINE)) Q:'LINE  D

 . I $Y>(IOSL-4) D HDG

 . W !,^TMP("BDGILD6",$J,LINE,0)

 ;

 D ^%ZISC,PRTKL^BDGF,EXIT

 Q

 ;

HDG ; heading for paper report

 S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF

 W !,BDGUSR,?13,"***",$$CONF^BDGF,"***"

 S X="Inter-Facility Transfers to/from "_$$GET1^DIQ(4,DUZ(2),.01)

 W !,BDGDATE,?(80-$L(X)\2),X,?71,"Page: ",BDGPG

 S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 W !,BDGTIME,?(80-$L(X)\2),X

 W !,$$REPEAT^XLFSTR("-",80)

 I BDGTYP=1 S X=$$PAD($$PAD($$PAD($$PAD($$PAD(" Admt/Dsch Date",17)_"Patient Name",41)_"HRCN",52)_"Serv",60)_"Facility",80)

 E  S X=$$PAD($$PAD($$PAD("Facility",27)_"Service",55)_"Tran In",70)_"Tran Out"

 W !,X,!,$$REPEAT^XLFSTR("=",80)

 Q

 ;

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGILD6",$J)

 Q

 ;

EXPND ; -- expand code

 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)

BDGILD6   ; IHS/ANMC/LJF - FACILITY TRANSFERS ; 

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

EN        ; -- main entry point for BDG ILD FACILITY TRANSFERS

 +1        IF $EXTRACT(IOST,1,2)="P-"

               DO INIT

               DO PRINT

               QUIT 

 +2        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

 +3        DO EN^VALM("BDG ILD FACILITY TRANSFERS")

 +4        DO CLEAR^VALM1

 +5        QUIT 

 +6       ;

HDR       ; -- header code

 +1        NEW X

 +2        SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF

 +3        SET X="Transfers to/from "_$$GET1^DIQ(4,DUZ(2),.01)

 +4        SET VALMHDR(2)=$$SP(79-$LENGTH(X)\2)_X

 +5        SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 +6        SET VALMHDR(3)=$$SP(79-$LENGTH(X)\2)_X

 +7       ;

 +8        IF BDGTYP=1

               SET VALMCAP=$$PAD($$PAD($$PAD($$PAD($$PAD(" Admt/Dsch Date",17)_"Patient Name",41)_"HRCN",52)_"Serv",60)_"Facility",80)

 +9        QUIT 

 +10      ;

INIT      ; -- init variables and list array

 +1        KILL ^TMP("BDGILD6",$JOB)

 +2        SET VALMCNT=0

 +3        DO ^BDGILD61

 +4       ;

 +5        IF '$DATA(^TMP("BDGILD6",$JOB))

               Begin DoDot:1

 +6                SET VALMCNT=1

                   SET ^TMP("BDGILD6",$JOB,1,0)="No data found"

               End DoDot:1

 +7       ;

 +8        QUIT 

 +9       ;

PRINT     ; print report to paper

 +1        NEW LINE,BDGPG

 +2        USE IO

           DO INIT^BDGF

           DO HDG

 +3       ;

 +4        SET LINE=0

           FOR 

               SET LINE=$ORDER(^TMP("BDGILD6",$JOB,LINE))

               IF 'LINE

                   QUIT 

               Begin DoDot:1

 +5                IF $Y>(IOSL-4)

                       DO HDG

 +6                WRITE !,^TMP("BDGILD6",$JOB,LINE,0)

               End DoDot:1

 +7       ;

 +8        DO ^%ZISC

           DO PRTKL^BDGF

           DO EXIT

 +9        QUIT 

 +10      ;

HDG       ; heading for paper report

 +1        SET BDGPG=$GET(BDGPG)+1

           IF BDGPG>1

               WRITE @IOF

 +2        WRITE !,BDGUSR,?13,"***",$$CONF^BDGF,"***"

 +3        SET X="Inter-Facility Transfers to/from "_$$GET1^DIQ(4,DUZ(2),.01)

 +4        WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?71,"Page: ",BDGPG

 +5        SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 +6        WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X

 +7        WRITE !,$$REPEAT^XLFSTR("-",80)

 +8        IF BDGTYP=1

               SET X=$$PAD($$PAD($$PAD($$PAD($$PAD(" Admt/Dsch Date",17)_"Patient Name",41)_"HRCN",52)_"Serv",60)_"Facility",80)

 +9       IF '$TEST

               SET X=$$PAD($$PAD($$PAD("Facility",27)_"Service",55)_"Tran In",70)_"Tran Out"

 +10       WRITE !,X,!,$$REPEAT^XLFSTR("=",80)

 +11       QUIT 

 +12      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BDGILD6",$JOB)

 +2        QUIT 

 +3       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

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)