DGPTODT1 ;ALB/BOK - PTF DRG TRIM POINT REPORT ; 9/13/01 4:56pm
;;5.3;Registration;**375**;Aug 13, 1993
D QUIT,MCT:$D(^UTILITY($J,"DGPTFR","D")),SVC:$D(^UTILITY($J,"DGPTFR","SB")) W @IOF
QUIT K %,A1,A2,A3,B4,B,B1,B2,C1,C2,C3,C4,C5,D,D1,D2,D3,DGAT1,DGBT1,DGCPG,DGFLAG,DGTCH,DGWT1,E,E1,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,G,G1,G2,G3,M1,M2,M3,M4,M5,P,P1,P3,S,T,T1,T2,T3,W1,W2,X,X1,X2,Z,Y,^UTILITY($J,"DGTC") Q
MCT S P=0,DGFLAG="Medical Center",P3="DRG" D INIT,TINIT,COV^DGPTODT2,HEAD^DGPTODT2 F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","D",D2)) Q:D2'>0 S D3=^(D2) D MTRIM^DGPTODT2,TWWU,PRINT
D TOT,PP,TP^DGUTL
Q
SVC S P=0,(DGFLAG,P3)="Service" D TINIT,INIT,COV^DGPTODT2 S G=0
F G1=0:0 S G=$O(^UTILITY($J,"DGPTFR","SB",G)) Q:G']"" S (G2,P1)=^(G) D CONVS:T]"",TOT:C1,STOT:C1,INIT,HEAD^DGPTODT2 F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","SB",G,D)) Q:D'>0 S G3=G2 D SVC1
S G3=G2 D CONVS,STOT,TOT S DGFLAG="Medical Center" D HEAD^DGPTODT2,LAST,CONV,CONVB S 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^DGPTODT2 S G=0 F G1=0:0 S G=$O(^UTILITY($J,"DGPTFR","SB",G)) Q:G']"" S G2=^(G) D CONV:C1,MT:F1,INIT,TINIT,HEAD^DGPTODT2,BT S D=G2
D CONV,CONVB,PP,TP^DGUTL
Q
BT F D=0:0 S D=$O(^UTILITY($J,"DGPTFR","SB",G,D)) Q:D'>0 S (B,P1)=^(D) D TOT:C1,INIT W !!?15,B F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","SB",G,D,D2)) Q:D2'>0 S D3=^(D2) D BSTRIM^DGPTODT2,TWWU,PRINT
D TOT Q
SVC1 F D2=0:0 S D2=$O(^UTILITY($J,"DGPTFR","SB",G,D,D2)) Q:D2'>0 S D3=^(D2) D TSET^DGPTODT2,TWWU S $P(^UTILITY($J,"DGPTFR","T",D2),U,13)=$P(D3,U,3,7)
Q
TWWU S T=$P(D3,U,2)*$P(D3,U,6)+($P(DGBT1,U,4)*DG1DAWW)+($P(DGAT1,U,3)*DGHIWW),T=$S(T=0:$P(D3,U,6),1:T),T=T+$S($P(D3,U,3):+$P(DGBT1,U,5)/$P(D3,U,3)*$P(D3,U,6),1:0),T1=T*$P(DGCST,U,2)
I DGFLAG["Serv" S Z=^UTILITY($J,"DGPTFR","T",D2),$P(^UTILITY($J,"DGPTFR","T",D2),U,4)=$P(Z,U,4)+T,$P(^UTILITY($J,"DGPTFR","T",D2),U,5)=$P(Z,U,5)+T1
Q
INIT K ^UTILITY($J,"DGPTFR","T") S (C1,C2,C3,C4,C5,T1,B1,B2,B5,W1,W2,A1,A2,A3,B4)=0,T="" Q
TINIT S (F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13)=0 Q
MI S (M1,M2,M3,M4,M5)=0 Q
CONV F E=1:1:5 S @("C"_E)=@("F"_E)
I DGFLAG["Spec" S DGFLAG="Service" D LAST2,CONVB,TOT S DGFLAG="Specialty"
Q
CONVB S B1=F6,B2=F7,W1=F8,W2=F9,A1=F10,A2=F11,A3=F12,B4=F13 Q
CONVS F E1=0:0 S E1=$O(^UTILITY($J,"DGPTFR","T",E1)) Q:E1'>0 S Z=^(E1),D2=E1,D3=+Z_U_$P(Z,U,3)_U_$P(Z,U,13,17),DGBT1=$P(Z,U,6,7),DGWT1=$P(Z,U,8,9),DGAT1=$P(Z,U,10,12),T=$P(Z,U,4),T1=$P(Z,U,5) D PRINT
Q
PRINT D HEAD^DGPTODT2:$Y>(IOSL-11) W !,$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)," |"
W $J($P(DGBT1,U,2),6)," |",$J($P(DGWT1,U,2),7),$J(+DGWT1,8)," |",$J($P(DGAT1,U,2),7),$J($P(DGAT1,U,3),8),$J(+DGAT1,8)
W ?88,"|",$J($P(D3,U,2),8),$J(+D3,11) S X=T,X2=2 D COMMA^%DTC W $J(X,12) S X=T*$P(DGCST,U,2) ;S X=0 D COMMA^%DTC W $J(X,12)
S C1=C1+$P(D3,U,2),C3=+D3+C3,C4=C4+T,C5=C5+T1,C2=C2+B4 Q
TOT W ! F E=1:1:132 W $S(DGFLAG["Serv":"-",1:"=")
TOT1 W !?8,"Total for ",DGFLAG,?38,"|",$J(B2,6)," |",$J(W2,7),$J(W1,8)," |",$J(A2,7),$J(A1,8),$J(A3,8),?88,"|",$J(C1,8),$J(C3,11) S X=C4,X2=2 D COMMA^%DTC W $J(X,12) W $J(C4/C1,12,2) ;S C5=0 S (X,T3)=C5,X2="2$" D COMMA^%DTC W $J(X,12)
I B4 W !?15,"Total 1 Day Stays:",$J(B4,12)
Q
STOT S F1=F1+C1,F2=F2+C2,F3=F3+C3,F4=F4+C4,F5=F5+C5,S(G3)=C1_U_C2_U_C3_U_C4_U_C5_U_B2_U_B1_U_W2_U_W1_U_A2_U_A1_U_A3_U_B4 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(S(D)) Q:D']"" D LAST1 F E=1:1:5 S @("C"_E)=$P(S(D),U,E) S DGFLAG=D D TOT1:E=5
Q
LAST2 S:'$D(S(D)) S(D)="" F E=1:1:5 S @("C"_E)=$P(S(D),U,E)
LAST1 S B1=$P(S(D),U,7),B2=$P(S(D),U,6),W2=$P(S(D),U,8),W1=$P(S(D),U,9),A1=$P(S(D),U,11),A2=$P(S(D),U,10),A3=$P(S(D),U,12),F6=F6+B1,F7=F7+B2,F8=F8+W1,F9=F9+W2,F10=F10+A1,F11=F11+A2,F12=F12+A3,B4=$P(S(D),U,13)
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[HDGPTODT1 3977 printed Oct 16, 2024@18:53:45 Page 2
DGPTODT1 ;ALB/BOK - PTF DRG TRIM POINT REPORT ; 9/13/01 4:56pm
+1 ;;5.3;Registration;**375**;Aug 13, 1993
+2 DO QUIT
if $DATA(^UTILITY($JOB,"DGPTFR","D"))
DO MCT
if $DATA(^UTILITY($JOB,"DGPTFR","SB"))
DO SVC
WRITE @IOF
QUIT KILL %,A1,A2,A3,B4,B,B1,B2,C1,C2,C3,C4,C5,D,D1,D2,D3,DGAT1,DGBT1,DGCPG,DGFLAG,DGTCH,DGWT1,E,E1,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,G,G1,G2,G3,M1,M2,M3,M4,M5,P,P1,P3,S,T,T1,T2,T3,W1,W2,X,X1,X2,Z,Y,^UTILITY($JOB,"DGTC")
QUIT
MCT SET P=0
SET DGFLAG="Medical Center"
SET P3="DRG"
DO INIT
DO TINIT
DO COV^DGPTODT2
DO HEAD^DGPTODT2
FOR D2=0:0
SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","D",D2))
if D2'>0
QUIT
SET D3=^(D2)
DO MTRIM^DGPTODT2
DO TWWU
DO PRINT
+1 DO TOT
DO PP
DO TP^DGUTL
+2 QUIT
SVC SET P=0
SET (DGFLAG,P3)="Service"
DO TINIT
DO INIT
DO COV^DGPTODT2
SET G=0
+1 FOR G1=0:0
SET G=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G))
if G']""
QUIT
SET (G2,P1)=^(G)
if T]""
DO CONVS
if C1
DO TOT
if C1
DO STOT
DO INIT
DO HEAD^DGPTODT2
FOR D=0:0
SET D=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G,D))
if D'>0
QUIT
SET G3=G2
DO SVC1
+2 SET G3=G2
DO CONVS
DO STOT
DO TOT
SET DGFLAG="Medical Center"
DO HEAD^DGPTODT2
DO LAST
DO CONV
DO CONVB
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^DGPTODT2
SET G=0
FOR G1=0:0
SET G=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G))
if G']""
QUIT
SET G2=^(G)
if C1
DO CONV
if F1
DO MT
DO INIT
DO TINIT
DO HEAD^DGPTODT2
DO BT
SET D=G2
+1 DO CONV
DO CONVB
DO PP
DO TP^DGUTL
+2 QUIT
BT FOR D=0:0
SET D=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G,D))
if D'>0
QUIT
SET (B,P1)=^(D)
if C1
DO TOT
DO INIT
WRITE !!?15,B
FOR D2=0:0
SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G,D,D2))
if D2'>0
QUIT
SET D3=^(D2)
DO BSTRIM^DGPTODT2
DO TWWU
DO PRINT
+1 DO TOT
QUIT
SVC1 FOR D2=0:0
SET D2=$ORDER(^UTILITY($JOB,"DGPTFR","SB",G,D,D2))
if D2'>0
QUIT
SET D3=^(D2)
DO TSET^DGPTODT2
DO TWWU
SET $PIECE(^UTILITY($JOB,"DGPTFR","T",D2),U,13)=$PIECE(D3,U,3,7)
+1 QUIT
TWWU SET T=$PIECE(D3,U,2)*$PIECE(D3,U,6)+($PIECE(DGBT1,U,4)*DG1DAWW)+($PIECE(DGAT1,U,3)*DGHIWW)
SET T=$SELECT(T=0:$PIECE(D3,U,6),1:T)
SET T=T+$SELECT($PIECE(D3,U,3):+$PIECE(DGBT1,U,5)/$PIECE(D3,U,3)*$PIECE(D3,U,6),1:0)
SET T1=T*$PIECE(DGCST,U,2)
+1 IF DGFLAG["Serv"
SET Z=^UTILITY($JOB,"DGPTFR","T",D2)
SET $PIECE(^UTILITY($JOB,"DGPTFR","T",D2),U,4)=$PIECE(Z,U,4)+T
SET $PIECE(^UTILITY($JOB,"DGPTFR","T",D2),U,5)=$PIECE(Z,U,5)+T1
+2 QUIT
INIT KILL ^UTILITY($JOB,"DGPTFR","T")
SET (C1,C2,C3,C4,C5,T1,B1,B2,B5,W1,W2,A1,A2,A3,B4)=0
SET T=""
QUIT
TINIT SET (F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13)=0
QUIT
MI SET (M1,M2,M3,M4,M5)=0
QUIT
CONV FOR E=1:1:5
SET @("C"_E)=@("F"_E)
+1 IF DGFLAG["Spec"
SET DGFLAG="Service"
DO LAST2
DO CONVB
DO TOT
SET DGFLAG="Specialty"
+2 QUIT
CONVB SET B1=F6
SET B2=F7
SET W1=F8
SET W2=F9
SET A1=F10
SET A2=F11
SET A3=F12
SET B4=F13
QUIT
CONVS FOR E1=0:0
SET E1=$ORDER(^UTILITY($JOB,"DGPTFR","T",E1))
if E1'>0
QUIT
SET Z=^(E1)
SET D2=E1
SET D3=+Z_U_$PIECE(Z,U,3)_U_$PIECE(Z,U,13,17)
SET DGBT1=$PIECE(Z,U,6,7)
SET DGWT1=$PIECE(Z,U,8,9)
SET DGAT1=$PIECE(Z,U,10,12)
SET T=$PIECE(Z,U,4)
SET T1=$PIECE(Z,U,5)
DO PRINT
+1 QUIT
PRINT if $Y>(IOSL-11)
DO HEAD^DGPTODT2
WRITE !,$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)," |"
+1 WRITE $JUSTIFY($PIECE(DGBT1,U,2),6)," |",$JUSTIFY($PIECE(DGWT1,U,2),7),$JUSTIFY(+DGWT1,8)," |",$JUSTIFY($PIECE(DGAT1,U,2),7),$JUSTIFY($PIECE(DGAT1,U,3),8),$JUSTIFY(+DGAT1,8)
+2 ;S X=0 D COMMA^%DTC W $J(X,12)
WRITE ?88,"|",$JUSTIFY($PIECE(D3,U,2),8),$JUSTIFY(+D3,11)
SET X=T
SET X2=2
DO COMMA^%DTC
WRITE $JUSTIFY(X,12)
SET X=T*$PIECE(DGCST,U,2)
+3 SET C1=C1+$PIECE(D3,U,2)
SET C3=+D3+C3
SET C4=C4+T
SET C5=C5+T1
SET C2=C2+B4
QUIT
TOT WRITE !
FOR E=1:1:132
WRITE $SELECT(DGFLAG["Serv":"-",1:"=")
TOT1 ;S C5=0 S (X,T3)=C5,X2="2$" D COMMA^%DTC W $J(X,12)
WRITE !?8,"Total for ",DGFLAG,?38,"|",$JUSTIFY(B2,6)," |",$JUSTIFY(W2,7),$JUSTIFY(W1,8)," |",$JUSTIFY(A2,7),$JUSTIFY(A1,8),$JUSTIFY(A3,8),?88,"|",$JUSTIFY(C1,8),$JUSTIFY(C3,11)
SET X=C4
SET X2=2
DO COMMA^%DTC
WRITE $JUSTIFY(X,12)
WRITE $JUSTIFY(C4/C1,12,2)
+1 IF B4
WRITE !?15,"Total 1 Day Stays:",$JUSTIFY(B4,12)
+2 QUIT
STOT SET F1=F1+C1
SET F2=F2+C2
SET F3=F3+C3
SET F4=F4+C4
SET F5=F5+C5
SET S(G3)=C1_U_C2_U_C3_U_C4_U_C5_U_B2_U_B1_U_W2_U_W1_U_A2_U_A1_U_A3_U_B4
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(S(D))
if D']""
QUIT
DO LAST1
FOR E=1:1:5
SET @("C"_E)=$PIECE(S(D),U,E)
SET DGFLAG=D
if E=5
DO TOT1
+1 QUIT
LAST2 if '$DATA(S(D))
SET S(D)=""
FOR E=1:1:5
SET @("C"_E)=$PIECE(S(D),U,E)
LAST1 SET B1=$PIECE(S(D),U,7)
SET B2=$PIECE(S(D),U,6)
SET W2=$PIECE(S(D),U,8)
SET W1=$PIECE(S(D),U,9)
SET A1=$PIECE(S(D),U,11)
SET A2=$PIECE(S(D),U,10)
SET A3=$PIECE(S(D),U,12)
SET F6=F6+B1
SET F7=F7+B2
SET F8=F8+W1
SET F9=F9+W2
SET F10=F10+A1
SET F11=F11+A2
SET F12=F12+A3
SET B4=$PIECE(S(D),U,13)
+1 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
