ADGFTRP.m

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