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