- DGPTODF1 ;ALB/MTC - PTF DRG FREQUENCY REPORT ; 4/8/14 9:32am
- ;;5.3;Registration;**375,886**;Aug 13, 1993;Build 5
- I "DB"[DGS,$D(^UTILITY($J,"DGPTFR","D")) D FD^DGPTODF2
- E I $D(^UTILITY($J,"DGPTFR","SB")) D FD^DGPTODF2 ;added line DG*5.3*375
- ;patch 886 changing drg codes 600 to 999 for the 2008 msdrg update
- I DGS'="D" S I=0 F I1=0:0 S I=$O(^UTILITY($J,"DGPTFR","FS",I)) Q:I']"" S S=^(I) F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","FS",I,D)) Q:D'>0!(D>999) S D1=^(D),^UTILITY($J,"DGPTFR","FS",I,(999999-$P(D1,U,2)),D)=D1 K ^UTILITY($J,"DGPTFR","FS",I,D)
- START D QUIT,MCT:$D(^UTILITY($J,"DGPTFR","FD")),ST:$D(^UTILITY($J,"DGPTFR","FS")) W @IOF
- QUIT K %,B,C,C1,C2,C3,C4,C5,D,D1,D2,D3,DGCPG,DGFLAG,DGTCH,E,F1,F2,F3,F4,F5,G,G1,G2,G3,I,I1,J,M1,M2,M3,M4,M5,P,P1,P3,S,S1,T,T1,T2,T3,X,X2,Y,Z,^UTILITY($J,"DGTC"),^UTILITY($J,"BOK") Q
- MCT S P=0,DGFLAG="Medical Center",P3="DRG" D INIT,TINIT,COV^DGPTODF2,HEAD^DGPTODF2 F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","FD",D)) Q:D'>0 S D1=999999-D F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","FD",D,D2)) Q:D2'>0 S D3=^(D2),P1=D2 D TDOL,PRINT
- D TOT,PP,TP^DGUTL
- Q
- ST S P=0,(DGFLAG,P3)="Service" D TINIT,INIT,COV^DGPTODF2
- S G=0 F G1=0:0 S G=$O(^UTILITY($J,"DGPTFR","FS",G)) Q:G']"" S (G2,P1)=^(G) D TOT:C1,STOT:C1,INIT,HEAD^DGPTODF2 F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","FS",G,D)) Q:D'>0 S D1=999999-D,G3=G2 D ST1
- S G3=G2 D STOT,TOT S DGFLAG="Medical Center" D HEAD^DGPTODF2,LAST S C1=F1,C2=F2,C3=F3,C4=F4,C5=F5,DGFLAG="Medical Center",^UTILITY($J,"DGTC","MEDICAL CENTER",P)="" D TOT,PP,TP^DGUTL
- BS S P=0,(DGFLAG,P3)="Specialty" D MI,INIT,TINIT,COV^DGPTODF2 S G=0 F G1=0:0 S G=$O(^UTILITY($J,"DGPTFR","FB",G)) Q:G']"" S G2=^(G) D CON:F1,MT:F1,INIT,TINIT,HEAD^DGPTODF2,BT
- D CON,MT,MCON,PP,TP^DGUTL
- Q
- BT F Z=0:0 S Z=$O(^UTILITY($J,"DGPTFR","FB",G,Z)) Q:Z'>0 S (B,P1)=^(Z) D TOT:C1,STOT:C1,INIT W !!!?15,B,!! F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","FB",G,Z,D)) Q:D'>0 S D1=999999-D D BT1
- D STOT,TOT Q
- BT1 F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","FB",G,Z,D,D2)) Q:D2'>0 S D3=^(D2) D TDOL,PRINT
- Q
- ST1 F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","FS",G,D,D2)) Q:D2'>0 S D3=^(D2) D TDOL,PRINT
- Q
- INIT S (C1,C2,C3,C4,C5,T,T1)=0 Q
- TINIT S (F1,F2,F3,F4,F5)=0 Q
- MI S (M1,M2,M3,M4,M5)=0 Q
- CON S C1=F1,C2=F2,C3=F3,C4=F4,C5=F5,DGFLAG="Service" D TOT S DGFLAG="Specialty" Q
- MCON S C1=M1,C2=M2,C3=M3,C4=M4,C5=M5,DGFLAG="Medical Center" D TOT Q
- TDOL S T=D1+$J($S($P(D3,U,3):$P(D3,U,11)/$P(D3,U,3),1:0),0,4)*$P(D3,U,6)+($P(D3,U,10)*DG1DAWW)+($P(D3,U,9)*DGHIWW),T=$S(T=0:$P(D3,U,6),1:T),T1=T*DGWWCST S:'$D(^UTILITY($J,"DGTC",P1)) ^(P1,P)="" Q
- PRINT D HEAD^DGPTODF2:$Y>(IOSL-11)
- W !?10,$J(D2,3),$J($P(D3,U,3),5),$J($P(D3,U,4),6),$J($P(D3,U,5),6),$J($P(D3,U,6),9),$J($P(D3,U,7),7),$J($P(D3,U,10),9),$J(D1,16),$J(+D3,11),$J(+D3/D1,12,2) S X=T,X2=2 D COMMA^%DTC W $J(X,18) ;S X=T1,X2=2 D COMMA^%DTC W $J(X,18)
- S C1=C1+D1,C3=+D3+C3,C4=C4+T,C5=C5+T1,C2=C2+$P(D3,U,10)
- Q
- TOT W ! F E=1:1:132 W $S(DGFLAG["Serv":"-",1:"=")
- ;adding code to protect from divide error if c1=0
- TOT1 N DGTMPC1 S DGTMPC1=C1 S:C1=0 C1=1 W !?10,"Total for ",DGFLAG,?46,$J(C2,9),$J(C1,16),$J(C3,11),$J(C3/C1,12,2) S X=C4,X2=2 D COMMA^%DTC W $J(X,18) W $J(C4/C1,18,2) ;S X=C5,X2="2$" D COMMA^%DTC W $J(X,18)
- I DGTMPC1=0 S C1=DGTMPC1
- Q
- STOT S F1=F1+C1,F2=F2+C2,F3=F3+C3,F4=F4+C4,F5=F5+C5,^UTILITY($J,"BOK",G3)=C1_U_C2_U_C3_U_C4_U_C5 Q
- MT S M1=M1+F1,M2=M2+F2,M3=M3+F3,M4=M4+F4,M5=M5+F5 Q
- LAST S D=0 F D1=0:0 S D=$O(^UTILITY($J,"BOK",D)) Q:D']"" F E=1:1:5 S @("C"_E)=$P(^UTILITY($J,"BOK",D),U,E) S DGFLAG=D D TOT1:E=5
- Q
- Q
- PP S %=$S($Y>(IOSL-11):($Y+2),1:IOSL-11) F E=$Y:1:% W ! I E=(%-1) D DIS^DGPTOD1 W !!?62,"-",P,"-"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTODF1 3646 printed Feb 19, 2025@00:19:07 Page 2
- DGPTODF1 ;ALB/MTC - PTF DRG FREQUENCY REPORT ; 4/8/14 9:32am
- +1 ;;5.3;Registration;**375,886**;Aug 13, 1993;Build 5
- +2 IF "DB"[DGS
- IF $DATA(^UTILITY($JOB,"DGPTFR","D"))
- DO FD^DGPTODF2
- +3 ;added line DG*5.3*375
- IF '$TEST
- IF $DATA(^UTILITY($JOB,"DGPTFR","SB"))
- DO FD^DGPTODF2
- +4 ;patch 886 changing drg codes 600 to 999 for the 2008 msdrg update
- +5 IF DGS'="D"
- SET I=0
- FOR I1=0:0
- SET I=$ORDER(^UTILITY($JOB,"DGPTFR","FS",I))
- if I']""
- QUIT
- SET S=^(I)
- FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"DGPTFR","FS",I,D))
- if D'>0!(D>999)
- QUIT
- SET D1=^(D)
- SET ^UTILITY($JOB,"DGPTFR","FS",I,(999999-$PIECE(D1,U,2)),D)=D1
- KILL ^UTILITY($JOB,"DGPTFR","FS",I,D)
- START DO QUIT
- if $DATA(^UTILITY($JOB,"DGPTFR","FD"))
- DO MCT
- if $DATA(^UTILITY($JOB,"DGPTFR","FS"))
- DO ST
- WRITE @IOF
- QUIT KILL %,B,C,C1,C2,C3,C4,C5,D,D1,D2,D3,DGCPG,DGFLAG,DGTCH,E,F1,F2,F3,F4,F5,G,G1,G2,G3,I,I1,J,M1,M2,M3,M4,M5,P,P1,P3,S,S1,T,T1,T2,T3,X,X2,Y,Z,^UTILITY($JOB,"DGTC"),^UTILITY($JOB,"BOK")
- QUIT
- MCT SET P=0
- SET DGFLAG="Medical Center"
- SET P3="DRG"
- DO INIT
- DO TINIT
- DO COV^DGPTODF2
- DO HEAD^DGPTODF2
- FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"DGPTFR","FD",D))
- if D'>0
- QUIT
- SET D1=999999-D
- FOR D2=0:0
- SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","FD",D,D2))
- if D2'>0
- QUIT
- SET D3=^(D2)
- SET P1=D2
- DO TDOL
- DO PRINT
- +1 DO TOT
- DO PP
- DO TP^DGUTL
- +2 QUIT
- ST SET P=0
- SET (DGFLAG,P3)="Service"
- DO TINIT
- DO INIT
- DO COV^DGPTODF2
- +1 SET G=0
- FOR G1=0:0
- SET G=$ORDER(^UTILITY($JOB,"DGPTFR","FS",G))
- if G']""
- QUIT
- SET (G2,P1)=^(G)
- if C1
- DO TOT
- if C1
- DO STOT
- DO INIT
- DO HEAD^DGPTODF2
- FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"DGPTFR","FS",G,D))
- if D'>0
- QUIT
- SET D1=999999-D
- SET G3=G2
- DO ST1
- +2 SET G3=G2
- DO STOT
- DO TOT
- SET DGFLAG="Medical Center"
- DO HEAD^DGPTODF2
- DO LAST
- SET C1=F1
- SET C2=F2
- SET C3=F3
- SET C4=F4
- SET C5=F5
- SET DGFLAG="Medical Center"
- SET ^UTILITY($JOB,"DGTC","MEDICAL CENTER",P)=""
- DO TOT
- DO PP
- DO TP^DGUTL
- BS SET P=0
- SET (DGFLAG,P3)="Specialty"
- DO MI
- DO INIT
- DO TINIT
- DO COV^DGPTODF2
- SET G=0
- FOR G1=0:0
- SET G=$ORDER(^UTILITY($JOB,"DGPTFR","FB",G))
- if G']""
- QUIT
- SET G2=^(G)
- if F1
- DO CON
- if F1
- DO MT
- DO INIT
- DO TINIT
- DO HEAD^DGPTODF2
- DO BT
- +1 DO CON
- DO MT
- DO MCON
- DO PP
- DO TP^DGUTL
- +2 QUIT
- BT FOR Z=0:0
- SET Z=$ORDER(^UTILITY($JOB,"DGPTFR","FB",G,Z))
- if Z'>0
- QUIT
- SET (B,P1)=^(Z)
- if C1
- DO TOT
- if C1
- DO STOT
- DO INIT
- WRITE !!!?15,B,!!
- FOR D=0:0
- SET D=$ORDER(^UTILITY($JOB,"DGPTFR","FB",G,Z,D))
- if D'>0
- QUIT
- SET D1=999999-D
- DO BT1
- +1 DO STOT
- DO TOT
- QUIT
- BT1 FOR D2=0:0
- SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","FB",G,Z,D,D2))
- if D2'>0
- QUIT
- SET D3=^(D2)
- DO TDOL
- DO PRINT
- +1 QUIT
- ST1 FOR D2=0:0
- SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","FS",G,D,D2))
- if D2'>0
- QUIT
- SET D3=^(D2)
- DO TDOL
- DO PRINT
- +1 QUIT
- INIT SET (C1,C2,C3,C4,C5,T,T1)=0
- QUIT
- TINIT SET (F1,F2,F3,F4,F5)=0
- QUIT
- MI SET (M1,M2,M3,M4,M5)=0
- QUIT
- CON SET C1=F1
- SET C2=F2
- SET C3=F3
- SET C4=F4
- SET C5=F5
- SET DGFLAG="Service"
- DO TOT
- SET DGFLAG="Specialty"
- QUIT
- MCON SET C1=M1
- SET C2=M2
- SET C3=M3
- SET C4=M4
- SET C5=M5
- SET DGFLAG="Medical Center"
- DO TOT
- QUIT
- TDOL SET T=D1+$JUSTIFY($SELECT($PIECE(D3,U,3):$PIECE(D3,U,11)/$PIECE(D3,U,3),1:0),0,4)*$PIECE(D3,U,6)+($PIECE(D3,U,10)*DG1DAWW)+($PIECE(D3,U,9)*DGHIWW)
- SET T=$SELECT(T=0:$PIECE(D3,U,6),1:T)
- SET T1=T*DGWWCST
- if '$DATA(^UTILITY($JOB,"DGTC",P1))
- SET ^(P1,P)=""
- QUIT
- PRINT if $Y>(IOSL-11)
- DO HEAD^DGPTODF2
- +1 ;S X=T1,X2=2 D COMMA^%DTC W $J(X,18)
- WRITE !?10,$JUSTIFY(D2,3),$JUSTIFY($PIECE(D3,U,3),5),$JUSTIFY($PIECE(D3,U,4),6),$JUSTIFY($PIECE(D3,U,5),6),$JUSTIFY($PIECE(D3,U,6),9),$JUSTIFY($PIECE(D3,U,7),7),$JUSTIFY($PIECE(D3,U,10),9),$JUSTIFY(D1,16),$JUSTIFY(+D3,11),$JUSTIFY(+D3/D1,12,2)
- SET X=T
- SET X2=2
- DO COMMA^%DTC
- WRITE $JUSTIFY(X,18)
- +2 SET C1=C1+D1
- SET C3=+D3+C3
- SET C4=C4+T
- SET C5=C5+T1
- SET C2=C2+$PIECE(D3,U,10)
- +3 QUIT
- TOT WRITE !
- FOR E=1:1:132
- WRITE $SELECT(DGFLAG["Serv":"-",1:"=")
- +1 ;adding code to protect from divide error if c1=0
- TOT1 ;S X=C5,X2="2$" D COMMA^%DTC W $J(X,18)
- NEW DGTMPC1
- SET DGTMPC1=C1
- if C1=0
- SET C1=1
- WRITE !?10,"Total for ",DGFLAG,?46,$JUSTIFY(C2,9),$JUSTIFY(C1,16),$JUSTIFY(C3,11),$JUSTIFY(C3/C1,12,2)
- SET X=C4
- SET X2=2
- DO COMMA^%DTC
- WRITE $JUSTIFY(X,18)
- WRITE $JUSTIFY(C4/C1,18,2)
- +1 IF DGTMPC1=0
- SET C1=DGTMPC1
- +2 QUIT
- STOT SET F1=F1+C1
- SET F2=F2+C2
- SET F3=F3+C3
- SET F4=F4+C4
- SET F5=F5+C5
- SET ^UTILITY($JOB,"BOK",G3)=C1_U_C2_U_C3_U_C4_U_C5
- QUIT
- MT SET M1=M1+F1
- SET M2=M2+F2
- SET M3=M3+F3
- SET M4=M4+F4
- SET M5=M5+F5
- QUIT
- LAST SET D=0
- FOR D1=0:0
- SET D=$ORDER(^UTILITY($JOB,"BOK",D))
- if D']""
- QUIT
- FOR E=1:1:5
- SET @("C"_E)=$PIECE(^UTILITY($JOB,"BOK",D),U,E)
- SET DGFLAG=D
- if E=5
- DO TOT1
- +1 QUIT
- +2 QUIT
- PP SET %=$SELECT($Y>(IOSL-11):($Y+2),1:IOSL-11)
- FOR E=$Y:1:%
- WRITE !
- IF E=(%-1)
- DO DIS^DGPTOD1
- WRITE !!?62,"-",P,"-"
- +1 QUIT