DGPTODB1.m

DGPTODB1 ;ALB/AS - PTF DRG BREAKEVEN REPORTS (DRIVER ROUTINE) ; 26 JUN 87  10:00

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 S $P(DGLN,"=",132)="",$P(DGLN2,"-",132)="",DGCPG(2)="For "_$S(DGD:"Discharge dates from ",1:"Active Admissions")

 I DGD S Y=(DGSD+.1) X ^DD("DD") S DGCPG(2)=DGCPG(2)_$P(Y,"@")_" to ",Y=$P(DGED,".") X ^DD("DD") S DGCPG(2)=DGCPG(2)_Y,DGCPG(3)=$S('DGB:"not ",1:"")_"including TRANSFER DRGs"

 I DGS'="S"&($D(^UTILITY($J,"DGPTFR","D"))) D IN S DGRNO=1,DGFLAG="Medical Center by DRG",DGCPG(1)="BREAKEVEN Report for "_DGFLAG,DGTCH="Breakeven by DRG^DRG^PAGE #" D C^DGUTL,HD,^DGPTODB2 G:DGS="D" Q

 G:'$D(^UTILITY($J,"DGPTFR","SB")) Q D IN S DGRNO=2 F %=1:1:7 S (DGMC(%),DGAMT(%))=0

 S DGSV="",DGCPG(1)="BREAKEVEN Report by SERVICE by SPECIALTY",DGTCH=DGCPG(1)_"^SPECIALTY^PAGE #" D C^DGUTL

 F D=0:0 D:DGSV]"" WS^DGPTODB2 S DGSV=$O(^UTILITY($J,"DGPTFR","SB",DGSV)) Q:DGSV']""  S ^UTILITY($J,"DGBE",DGSV)=^(DGSV),DGFLAG=^UTILITY($J,"DGBE",DGSV)_" Service by Specialty by DRG" D HD,SV^DGPTODB2

 K DGBNM F %=1:1:7 S DGTT(%)=DGMC(%)

 D WM^DGPTODB2 K D5,DGMC,DGBS

 D IN S DGRNO=3,DGSV="",DGCPG(1)="BREAKEVEN Report by SERVICE",DGTCH=DGCPG(1)_"^SERVICE^PAGE #" D C^DGUTL

 F I=0:0 D:DGSV]"" WS^DGPTODB2 S DGSV=$O(^UTILITY($J,"DGBE",DGSV)) Q:DGSV']""  S X=^(DGSV),DGFLAG=X_" Service" D HD S (DRG,^UTILITY($J,"DGTC",X,DGPAG))="" F J=0:0 S DRG=$O(^UTILITY($J,"DGBE",DGSV,DRG)) Q:DRG']""  S Z=^(DRG) D LN

 F %=1:1:7 S DGTT(%)=DGAMT(%)

 D WM^DGPTODB2 G Q

LN D LN^DGPTODB2 S D3=0 F D=0:0 S D3=$O(^UTILITY($J,"DGBE",DGSV,DRG,D3)) Q:D3']""  S Z=^UTILITY($J,"DGBE",DGSV,DRG,D3) S:D3="AA" DGA="A",DGLA=$P(Z,"^"),DGDA=$P(Z,"^",2),DGHI=$P(Z,"^",3),DGTT(3)=DGTT(3)+DGDA,DGTT(4)=DGTT(4)+DGLA I D3="BA" D BA

 D WLN^DGPTODB2 Q

BA S DGU="B",DGLU=$P(Z,"^"),DGDU=$P(Z,"^",2),DG1DAY=$P(Z,"^",4),DGLODAY=$P(Z,"^",5),DGTT(1)=DGTT(1)+DGDU,DGTT(2)=DGTT(2)+DGLU Q

HD I DGPAG>0 S %=$S($D(IOSL):(IOSL-12),1:54) F I=$Y:1:% W !

 I DGPAG>0 D BE^DGPTOD1 W !!?64,"-",DGPAG,"-",!

 S DGPAG=DGPAG+1 W @IOF,!!,"BREAKEVEN Report for ",DGFLAG,?110,"PRINTED: " S Y=DT X ^DD("DD") W $P(Y,"@"),!,$P(DGCPG(2),U) I DGD W " ",$P(DGCPG(3),U)

 W !!?37,"|",?42,"BELOW BREAKEVEN",?60,"|   ABOVE BREAKEVEN    |",?92,"TOTAL",?107,"|",!?29,"Facility|----------------------|----------------------|-----------------------|",!,?16,"National",?31,"Break"

 W " | Total  Total   ALOS/ | Total  Total   ALOS/ | Total  Total    ALOS/ | ",?110,"Total",?120,"Estimated",!,"DRG  Low  High    ALOS    WWU  Even  | Disch   LOS    Disch | Disch   LOS    Disch | Disch   LOS     Disch |"

 W ?111,"WWU",?121,"Total $",!,DGLN Q

IN F %=1:1:7 S DGTT(%)=0

 S DGPAG=0 K DGBNM,^UTILITY($J,"DGTC") Q

Q W @IOF K DGTT,DGAMT,%,DGDA,DGA,DGLA,DGU,DGDU,DGLU,D,D3,DGHI,DG1DAY,DGFLAG,DGLN,DGLN2,DGPAG,DGRNO,DGSV,DGTCH,DRG,I,J,X,X2,Y,DGWU,DGTD,DGTL,DGTWW,DGLODAY,DGLOTRIM,^UTILITY($J,"DGBE"),DGCPG,DGLODC,Z Q

DGPTODB1  ;ALB/AS - PTF DRG BREAKEVEN REPORTS (DRIVER ROUTINE) ; 26 JUN 87  10:00

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +2        SET $PIECE(DGLN,"=",132)=""

           SET $PIECE(DGLN2,"-",132)=""

           SET DGCPG(2)="For "_$SELECT(DGD:"Discharge dates from ",1:"Active Admissions")

 +3        IF DGD

               SET Y=(DGSD+.1)

               XECUTE ^DD("DD")

               SET DGCPG(2)=DGCPG(2)_$PIECE(Y,"@")_" to "

               SET Y=$PIECE(DGED,".")

               XECUTE ^DD("DD")

               SET DGCPG(2)=DGCPG(2)_Y

               SET DGCPG(3)=$SELECT('DGB:"not ",1:"")_"including TRANSFER DRGs"

 +4        IF DGS'="S"&($DATA(^UTILITY($JOB,"DGPTFR","D")))

               DO IN

               SET DGRNO=1

               SET DGFLAG="Medical Center by DRG"

               SET DGCPG(1)="BREAKEVEN Report for "_DGFLAG

               SET DGTCH="Breakeven by DRG^DRG^PAGE #"

               DO C^DGUTL

               DO HD

               DO ^DGPTODB2

               IF DGS="D"

                   GOTO Q

 +5        IF '$DATA(^UTILITY($JOB,"DGPTFR","SB"))

               GOTO Q

           DO IN

           SET DGRNO=2

           FOR %=1:1:7

               SET (DGMC(%),DGAMT(%))=0

 +6        SET DGSV=""

           SET DGCPG(1)="BREAKEVEN Report by SERVICE by SPECIALTY"

           SET DGTCH=DGCPG(1)_"^SPECIALTY^PAGE #"

           DO C^DGUTL

 +7        FOR D=0:0

               IF DGSV]""

                   DO WS^DGPTODB2

               SET DGSV=$ORDER(^UTILITY($JOB,"DGPTFR","SB",DGSV))

               IF DGSV']""

                   QUIT 

               SET ^UTILITY($JOB,"DGBE",DGSV)=^(DGSV)

               SET DGFLAG=^UTILITY($JOB,"DGBE",DGSV)_" Service by Specialty by DRG"

               DO HD

               DO SV^DGPTODB2

 +8        KILL DGBNM

           FOR %=1:1:7

               SET DGTT(%)=DGMC(%)

 +9        DO WM^DGPTODB2

           KILL D5,DGMC,DGBS

 +10       DO IN

           SET DGRNO=3

           SET DGSV=""

           SET DGCPG(1)="BREAKEVEN Report by SERVICE"

           SET DGTCH=DGCPG(1)_"^SERVICE^PAGE #"

           DO C^DGUTL

 +11       FOR I=0:0

               IF DGSV]""

                   DO WS^DGPTODB2

               SET DGSV=$ORDER(^UTILITY($JOB,"DGBE",DGSV))

               IF DGSV']""

                   QUIT 

               SET X=^(DGSV)

               SET DGFLAG=X_" Service"

               DO HD

               SET (DRG,^UTILITY($JOB,"DGTC",X,DGPAG))=""

               FOR J=0:0

                   SET DRG=$ORDER(^UTILITY($JOB,"DGBE",DGSV,DRG))

                   IF DRG']""

                       QUIT 

                   SET Z=^(DRG)

                   DO LN

 +12       FOR %=1:1:7

               SET DGTT(%)=DGAMT(%)

 +13       DO WM^DGPTODB2

           GOTO Q

LN         DO LN^DGPTODB2

           SET D3=0

           FOR D=0:0

               SET D3=$ORDER(^UTILITY($JOB,"DGBE",DGSV,DRG,D3))

               IF D3']""

                   QUIT 

               SET Z=^UTILITY($JOB,"DGBE",DGSV,DRG,D3)

               IF D3="AA"

                   SET DGA="A"

                   SET DGLA=$PIECE(Z,"^")

                   SET DGDA=$PIECE(Z,"^",2)

                   SET DGHI=$PIECE(Z,"^",3)

                   SET DGTT(3)=DGTT(3)+DGDA

                   SET DGTT(4)=DGTT(4)+DGLA

               IF D3="BA"

                   DO BA

 +1        DO WLN^DGPTODB2

           QUIT 

BA         SET DGU="B"

           SET DGLU=$PIECE(Z,"^")

           SET DGDU=$PIECE(Z,"^",2)

           SET DG1DAY=$PIECE(Z,"^",4)

           SET DGLODAY=$PIECE(Z,"^",5)

           SET DGTT(1)=DGTT(1)+DGDU

           SET DGTT(2)=DGTT(2)+DGLU

           QUIT 

HD         IF DGPAG>0

               SET %=$SELECT($DATA(IOSL):(IOSL-12),1:54)

               FOR I=$Y:1:%

                   WRITE !

 +1        IF DGPAG>0

               DO BE^DGPTOD1

               WRITE !!?64,"-",DGPAG,"-",!

 +2        SET DGPAG=DGPAG+1

           WRITE @IOF,!!,"BREAKEVEN Report for ",DGFLAG,?110,"PRINTED: "

           SET Y=DT

           XECUTE ^DD("DD")

           WRITE $PIECE(Y,"@"),!,$PIECE(DGCPG(2),U)

           IF DGD

               WRITE " ",$PIECE(DGCPG(3),U)

 +3        WRITE !!?37,"|",?42,"BELOW BREAKEVEN",?60,"|   ABOVE BREAKEVEN    |",?92,"TOTAL",?107,"|",!?29,"Facility|----------------------|----------------------|-----------------------|",!,?16,"National",?31,"Break"

 +4        WRITE " | Total  Total   ALOS/ | Total  Total   ALOS/ | Total  Total    ALOS/ | ",?110,"Total",?120,"Estimated",!,"DRG  Low  High    ALOS    WWU  Even  | Disch   LOS    Disch | Disch   LOS    Disch | Disch   LOS     Disch |"

 +5        WRITE ?111,"WWU",?121,"Total $",!,DGLN

           QUIT 

IN         FOR %=1:1:7

               SET DGTT(%)=0

 +1        SET DGPAG=0

           KILL DGBNM,^UTILITY($JOB,"DGTC")

           QUIT 

Q          WRITE @IOF

           KILL DGTT,DGAMT,%,DGDA,DGA,DGLA,DGU,DGDU,DGLU,D,D3,DGHI,DG1DAY,DGFLAG,DGLN,DGLN2,DGPAG,DGRNO,DGSV,DGTCH,DRG,I,J,X,X2,Y,DGWU,DGTD,DGTL,DGTWW,DGLODAY,DGLOTRIM,^UTILITY($JOB,"DGBE"),DGCPG,DGLODC,Z

           QUIT