- ADGFTRP ; IHS/ADC/PDW/ENM - TRANSFERS BETWEEN FACILITIES(PRINT) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ;***> initialize variables
- S DGPAGE=0,DGSTOP="",DGDUZ=$P(^VA(200,DUZ,0),U,2)
- S DGFAC=$P(^DIC(4,DUZ(2),0),U) ;set site
- S DGLINE="",$P(DGLINE,"=",80)=""
- S DGLINE2="",$P(DGLINE2,"-",80)=""
- S (DGTI,DGTO)=0 ;zero out totals
- ;
- ;***> if listing only
- G ^ADGFTRP1:DGTYP=1
- ;
- STAT ;***> print stats by facility
- D HEAD S DGF=0 ;print heading
- STAT1 S DGF=$O(DGCT(DGF)) G TOTAL:DGF="" S DGSV=0
- W !,$E(DGF,1,24) ;print facility
- STAT2 S DGSV=$O(DGCT(DGF,DGSV)) G STAT1:DGSV=""
- W ?26,DGSV ;print service
- ;***> print transfer counts and increment totals
- W ?55,$P(DGCT(DGF,DGSV),U) S DGTI=DGTI+$P(DGCT(DGF,DGSV),U)
- W ?70,$P(DGCT(DGF,DGSV),U,2) S DGTO=DGTO+$P(DGCT(DGF,DGSV),U,2)
- W ! I $Y>(IOSL-6) D NEWPG G END:DGSTOP=U
- G STAT2
- ;
- TOTAL ;***> print transfer totals
- W !,DGLINE,!?30,"TOTALS:",?55,DGTI,?70,DGTO,!
- G ^ADGFTRP1:DGTYP=3
- ;
- END G END^ADGFTRP1
- ;
- NEWPG ;***> subrtn for end of page control
- 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="STATISTICS" W ?80-$L(DGX)/2,DGX
- W !,DGLINE,!,"Facility Name",?26,"Admit/Dsch Service"
- W ?50,"Transfers In",?65,"Transfers Out"
- W !,DGLINE2,!
- Q
- ADGFTRP ; IHS/ADC/PDW/ENM - TRANSFERS BETWEEN FACILITIES(PRINT) ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ;***> initialize variables
- +4 SET DGPAGE=0
- SET DGSTOP=""
- SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
- +5 ;set site
- SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
- +6 SET DGLINE=""
- SET $PIECE(DGLINE,"=",80)=""
- +7 SET DGLINE2=""
- SET $PIECE(DGLINE2,"-",80)=""
- +8 ;zero out totals
- SET (DGTI,DGTO)=0
- +9 ;
- +10 ;***> if listing only
- +11 IF DGTYP=1
- GOTO ^ADGFTRP1
- +12 ;
- STAT ;***> print stats by facility
- +1 ;print heading
- DO HEAD
- SET DGF=0
- STAT1 SET DGF=$ORDER(DGCT(DGF))
- IF DGF=""
- GOTO TOTAL
- SET DGSV=0
- +1 ;print facility
- WRITE !,$EXTRACT(DGF,1,24)
- STAT2 SET DGSV=$ORDER(DGCT(DGF,DGSV))
- IF DGSV=""
- GOTO STAT1
- +1 ;print service
- WRITE ?26,DGSV
- +2 ;***> print transfer counts and increment totals
- +3 WRITE ?55,$PIECE(DGCT(DGF,DGSV),U)
- SET DGTI=DGTI+$PIECE(DGCT(DGF,DGSV),U)
- +4 WRITE ?70,$PIECE(DGCT(DGF,DGSV),U,2)
- SET DGTO=DGTO+$PIECE(DGCT(DGF,DGSV),U,2)
- +5 WRITE !
- IF $Y>(IOSL-6)
- DO NEWPG
- IF DGSTOP=U
- GOTO END
- +6 GOTO STAT2
- +7 ;
- TOTAL ;***> print transfer totals
- +1 WRITE !,DGLINE,!?30,"TOTALS:",?55,DGTI,?70,DGTO,!
- +2 IF DGTYP=3
- GOTO ^ADGFTRP1
- +3 ;
- END GOTO END^ADGFTRP1
- +1 ;
- NEWPG ;***> subrtn for end of page control
- +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="STATISTICS"
- WRITE ?80-$LENGTH(DGX)/2,DGX
- +8 WRITE !,DGLINE,!,"Facility Name",?26,"Admit/Dsch Service"
- +9 WRITE ?50,"Transfers In",?65,"Transfers Out"
- +10 WRITE !,DGLINE2,!
- +11 QUIT
