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