- 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