DGPTOD1.m

DGPTOD1 ;ALB/AS/BOK - PTF DRG REPORTS, BUILD UTILITY ; 9/5/01 2:23pm

 ;;5.3;Registration;**158,238,375,744,1015**;Aug 13, 1993;Build 21

 K ^UTILITY($J),A

 S DGFY=$$FY^DGPTOD0(DGED),DGFY2K=$$DGY2K^DGPTOD0(DGFY)

 S DGFYQ=$$FMTE^XLFDT(DGFY2K)_$$QTR(DGED)

 ;S DGWWCST=$P(DGCST,"^",2),DG1DAWW=$P(DGCST,"^",3)/DGWWCST,DG1DAWW=$J(DG1DAWW,0,5),DGHIWW=$P(DGCST,"^",5)/DGWWCST,DGHIWW=$J(DGHIWW,0,5)

 S (DGWWCST,DG1DAWW,DGHIWW)=0

 D DT^DICRW S DGTPT=0

 F DGDRGDT=DGSD:0 S DGDRGDT=$O(^DGPT(DGCR,DGDRGDT)) Q:DGDRGDT'>0!(DGDRGDT>DGED)  F DGPTF=0:0 S DGPTF=$O(^DGPT(DGCR,DGDRGDT,DGPTF)) Q:DGPTF'>0  I $D(^DGPT(DGPTF,0)),'$P(^(0),U,4),$P(^(0),U,11)=1 S DGTPT=DGTPT+1,DGTLOS=0,DFN=+^(0) D ^DGPTOD2

 S H3="               National              "

 ;S DGFT(1)="The dollar figures shown are based on the formulas used in the FY 19"_$S($E(DGFY2K,1,3)>288:"89",1:"88")_" Target Allowance, as explained in the corresponding"

 ;S DGFT(2)="user documentation.  They are provided as a management tool for monitoring purposes and should not be used to predict"

 ;S DGFT(3)="RAM outcome.  They do not include RAM adjustments (salary, psychiatry, census, etc).  It will never be possible to duplicate"

 ;S DGFT(4)="RAM accurately on a current basis as the final RAM formulas are not determined until after the conclusion of the",DGFT(5)="fiscal year."

 S DGFT(4)="(*)Total Weight=Weight x Total # Discharges"

 S H="                Average              ",H1="DRG  Low  High    LOS  Weight         " K A F DGPGM=2:1:5 S R=$P(DGPTFR,"*",DGPGM) Q:R']""  D @R

 K DFN,DG1D,DGALOS,DGBE,DGDRG,DGDRGDT,DGDRGI,DGFYQ,DGHI,DGLBS,DGO,DGMBE,DGMV,DGOUT,DGPM,DGPR,DGPTF,DGPTFR,DGSNM,DGSV1,DGSVC,DGTLOS,DGTPT,DGWWU,H,H1,H3,K,R,W,DGLO,DGCNT,DGPROV,DGWGT

 G Q^DGPTOD0

1 D ^DGPTODT1 Q

2 D ^DGPTODF1 Q

3 D ^DGPTODA1 Q

4 D ^DGPTODCM Q  ;D ^DGPTODB1 Q

5 Q

 Q

WWU S (DGLO,DGHI,DGALOS,DGWWU,DGBE,DGMBE)="",%=$S($D(^ICD(+DGDRG,"FY",DGFY2K,0)):(^(0)),1:"") I %="",DGFY2K="3070000" N DGFY2KSV,DGFY2KYR S DGFY2KSV=DGFY2K,DGFY2KYR=$E(DGFY2K,1,3)-1,DGFY2K=DGFY2KYR_"0000" G WWU

 I $G(DGFY2KSV) S DGFY2K=DGFY2KSV

 S DGHI=$P(%,U,4),DGLO=$P(%,U,3),DGALOS=$P(%,U,9),DGWWU=$P(%,U,2)

 I DGSVC]"" S DGSV1=$S(DGSVC="M":1,DGSVC="NE":2,DGSVC="P":3,DGSVC="R":4,1:5),DGBE=$S($D(^ICD(+DGDRG,"BE",+DGFYQ,"S",+DGSV1,0)):$P(^(0),"^",2),1:""),DGMBE=$S($D(^ICD(+DGDRG,"BE",+DGFYQ,0)):$P(^(0),U,2),1:"")

 S ^UTILITY($J,"DRG",DGDRG)=DGLO_"^"_DGHI_"^"_DGALOS_"^"_DGWWU_"^"_DGBE_"^"_DGMBE Q

BE W !,"If local breakeven days have not been defined, values on this report will not be correct!",!

DIS W !,?10,DGFT(4)  ;F %=1:1:5 W !,DGFT(%)

 Q

 ;

QTR(X) ;Return FY quarter

 ;Input: X=date

 S X=$E(X,4,5)

 Q $S(X<4:2,X<7:3,X<10:4,1:1)

DGPTOD1   ;ALB/AS/BOK - PTF DRG REPORTS, BUILD UTILITY ; 9/5/01 2:23pm

 +1       ;;5.3;Registration;**158,238,375,744,1015**;Aug 13, 1993;Build 21

 +2        KILL ^UTILITY($JOB),A

 +3        SET DGFY=$$FY^DGPTOD0(DGED)

           SET DGFY2K=$$DGY2K^DGPTOD0(DGFY)

 +4        SET DGFYQ=$$FMTE^XLFDT(DGFY2K)_$$QTR(DGED)

 +5       ;S DGWWCST=$P(DGCST,"^",2),DG1DAWW=$P(DGCST,"^",3)/DGWWCST,DG1DAWW=$J(DG1DAWW,0,5),DGHIWW=$P(DGCST,"^",5)/DGWWCST,DGHIWW=$J(DGHIWW,0,5)

 +6        SET (DGWWCST,DG1DAWW,DGHIWW)=0

 +7        DO DT^DICRW

           SET DGTPT=0

 +8        FOR DGDRGDT=DGSD:0

               SET DGDRGDT=$ORDER(^DGPT(DGCR,DGDRGDT))

               IF DGDRGDT'>0!(DGDRGDT>DGED)

                   QUIT 

               FOR DGPTF=0:0

                   SET DGPTF=$ORDER(^DGPT(DGCR,DGDRGDT,DGPTF))

                   IF DGPTF'>0

                       QUIT 

                   IF $DATA(^DGPT(DGPTF,0))

                       IF '$PIECE(^(0),U,4)

                           IF $PIECE(^(0),U,11)=1

                               SET DGTPT=DGTPT+1

                               SET DGTLOS=0

                               SET DFN=+^(0)

                               DO ^DGPTOD2

 +9        SET H3="               National              "

 +10      ;S DGFT(1)="The dollar figures shown are based on the formulas used in the FY 19"_$S($E(DGFY2K,1,3)>288:"89",1:"88")_" Target Allowance, as explained in the corresponding"

 +11      ;S DGFT(2)="user documentation.  They are provided as a management tool for monitoring purposes and should not be used to predict"

 +12      ;S DGFT(3)="RAM outcome.  They do not include RAM adjustments (salary, psychiatry, census, etc).  It will never be possible to duplicate"

 +13      ;S DGFT(4)="RAM accurately on a current basis as the final RAM formulas are not determined until after the conclusion of the",DGFT(5)="fiscal year."

 +14       SET DGFT(4)="(*)Total Weight=Weight x Total # Discharges"

 +15       SET H="                Average              "

           SET H1="DRG  Low  High    LOS  Weight         "

           KILL A

           FOR DGPGM=2:1:5

               SET R=$PIECE(DGPTFR,"*",DGPGM)

               IF R']""

                   QUIT 

               DO @R

 +16       KILL DFN,DG1D,DGALOS,DGBE,DGDRG,DGDRGDT,DGDRGI,DGFYQ,DGHI,DGLBS,DGO,DGMBE,DGMV,DGOUT,DGPM,DGPR,DGPTF,DGPTFR,DGSNM,DGSV1,DGSVC,DGTLOS,DGTPT,DGWWU,H,H1,H3,K,R,W,DGLO,DGCNT,DGPROV,DGWGT

 +17       GOTO Q^DGPTOD0

1          DO ^DGPTODT1

           QUIT 

2          DO ^DGPTODF1

           QUIT 

3          DO ^DGPTODA1

           QUIT 

4         ;D ^DGPTODB1 Q

           DO ^DGPTODCM

           QUIT 

5          QUIT 

 +1        QUIT 

WWU        SET (DGLO,DGHI,DGALOS,DGWWU,DGBE,DGMBE)=""

           SET %=$SELECT($DATA(^ICD(+DGDRG,"FY",DGFY2K,0)):(^(0)),1:"")

           IF %=""

               IF DGFY2K="3070000"

                   NEW DGFY2KSV,DGFY2KYR

                   SET DGFY2KSV=DGFY2K

                   SET DGFY2KYR=$EXTRACT(DGFY2K,1,3)-1

                   SET DGFY2K=DGFY2KYR_"0000"

                   GOTO WWU

 +1        IF $GET(DGFY2KSV)

               SET DGFY2K=DGFY2KSV

 +2        SET DGHI=$PIECE(%,U,4)

           SET DGLO=$PIECE(%,U,3)

           SET DGALOS=$PIECE(%,U,9)

           SET DGWWU=$PIECE(%,U,2)

 +3        IF DGSVC]""

               SET DGSV1=$SELECT(DGSVC="M":1,DGSVC="NE":2,DGSVC="P":3,DGSVC="R":4,1:5)

               SET DGBE=$SELECT($DATA(^ICD(+DGDRG,"BE",+DGFYQ,"S",+DGSV1,0)):$PIECE(^(0),"^",2),1:"")

               SET DGMBE=$SELECT($DATA(^ICD(+DGDRG,"BE",+DGFYQ,0)):$PIECE(^(0),U,2),1:"")

 +4        SET ^UTILITY($JOB,"DRG",DGDRG)=DGLO_"^"_DGHI_"^"_DGALOS_"^"_DGWWU_"^"_DGBE_"^"_DGMBE

           QUIT 

BE         WRITE !,"If local breakeven days have not been defined, values on this report will not be correct!",!

DIS       ;F %=1:1:5 W !,DGFT(%)

           WRITE !,?10,DGFT(4)

 +1        QUIT 

 +2       ;

QTR(X)    ;Return FY quarter

 +1       ;Input: X=date

 +2        SET X=$EXTRACT(X,4,5)

 +3        QUIT $SELECT(X<4:2,X<7:3,X<10:4,1:1)