Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGILD63

BDGILD63.m

Go to the documentation of this file.
  1. BDGILD63 ; IHS/ANMC/LJF - TRANSFERS BETWEEN FACILITIES(PRINT) ;
  1. ;;5.3;PIMS;;APR 26, 2002
  1. ;
  1. S DGSTOP=""
  1. ;***> print admissions by date, service, then facility
  1. S DGDT=0 D NEWPG:BDGTYP=3,HEAD:BDGTYP=1 W !?30,"ADMISSIONS",!
  1. ADM1 S DGDT=$O(^TMP("BDGILD61A",$J,DGDT)) G DSCH:DGDT="" S DGSV=0
  1. ADM2 S DGSV=$O(^TMP("BDGILD61A",$J,DGDT,DGSV)) G ADM1:DGSV="" S DGF=0
  1. ADM3 S DGF=$O(^TMP("BDGILD61A",$J,DGDT,DGSV,DGF)) G ADM2:DGF="" S DFN=0
  1. ADM4 S DFN=$O(^TMP("BDGILD61A",$J,DGDT,DGSV,DGF,DFN)) G ADM3:DFN=""
  1. D LINE G END1:DGSTOP=U,ADM4
  1. ;
  1. ;
  1. DSCH ;***> print discharges by date, service, then facility
  1. S DGDT=0 D NEWPG:$Y>(IOSL-6) W !!?30,"DISCHARGES",!
  1. DSCH1 S DGDT=$O(^TMP("BDGILD61D",$J,DGDT)) G END:DGDT="" S DGSV=0
  1. DSCH2 S DGSV=$O(^TMP("BDGILD61D",$J,DGDT,DGSV)) G DSCH1:DGSV="" S DGF=0
  1. DSCH3 S DGF=$O(^TMP("BDGILD61D",$J,DGDT,DGSV,DGF)) G DSCH2:DGF="" S DFN=0
  1. DSCH4 S DFN=$O(^TMP("BDGILD61D",$J,DGDT,DGSV,DGF,DFN)) G DSCH3:DFN=""
  1. D LINE G END1:DGSTOP=U,DSCH4
  1. ;
  1. ;
  1. END ;EP; ***> eoj
  1. I IOST["C-" K DIR S DIR(0)="E" D ^DIR
  1. END1 ;EP;
  1. W @IOF D KILL^ADGUTIL
  1. D ^%ZISC K ^TMP("BDGILD61A") K ^TMP("BDGILD61D") Q
  1. ;
  1. LINE ;***> subrtn to print line
  1. S DGTM=$E(DGDT,9,12),DGTM=$E(DGTM_"0000",1,4) ;time in readable form
  1. W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3)_"@"_DGTM ;date
  1. W ?17,$E($P(^DPT(DFN,0),U),1,20) ;patient
  1. S DGHR=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) W ?40,$J(DGHR,6) ;chart #
  1. W ?52,$E(DGSV,1,3),?60,$E(DGF,1,18) ;service & facility
  1. I $Y>(IOSL-6) D NEWPG ;end of page check
  1. Q
  1. ;
  1. NEWPG ;***> subrtn for end of page code
  1. I IOST'?1"C-".E D HEAD S DGSTOP="" Q
  1. K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
  1. I DGSTOP'=U D HEAD
  1. Q
  1. ;
  1. I (IOST["C-")!(DGPAGE>0) W @IOF
  1. W !,DGLINE S DGPAGE=DGPAGE+1
  1. W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
  1. W !,DGDUZ,?80-$L(DGFAC)/2,DGFAC S DGTY="INTER-FACILITY TRANSFERS"
  1. W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
  1. S Y=DT X ^DD("DD") W !,Y
  1. S DGX="PATIENT LISTING" W ?80-$L(DGX)/2,DGX
  1. W !,DGLINE,!,"Date/Time",?17,"Patient Name",?40,"Chart #"
  1. W ?50,"Service",?60,"Facility",!,DGLINE2,!
  1. Q