DGPTOD2 ;ALB/BOK - PTF DRG REPORTS, BUILD UTILITY, CONT. ; 9/14/01 5:57pm
;;5.3;Registration;**375,744**;Aug 13, 1993;Build 5
S DGCNT=0 D SET:DGB,DRG:'DGB Q
SET F DGMV=0:0 S DGMV=$O(^DGPT(DGPTF,"M",DGMV)) Q:DGMV'>0 I $D(^DGPT(DGPTF,"M",DGMV,"P")) S DGPM=^("P"),DGTLOS=$P(DGPM,U,4),DGDRG=+DGPM,DGLBS=$P(^DGPT(DGPTF,"M",DGMV,0),U,2),DGSVC=$P(DGPM,U,2),DGPROV=$P(DGPM,U,5) I DGDRG D UTIL,COMP,CASEMIX
Q
UTIL Q:'DGDRG D:'$D(^UTILITY($J,"DRG",DGDRG)) WWU^DGPTOD1 S DGDRGI=^(DGDRG)
I "DB"[DGS S $P(^(DGDRG),U)=$S($D(^UTILITY($J,"DGPTFR","D",DGDRG)):$P(^(DGDRG),U),1:0)+DGTLOS,$P(^(DGDRG),U,2)=$P(^(DGDRG),U,2)+1 I $P(^(DGDRG),U,2)=1 S ^(DGDRG)=^(DGDRG)_U_DGDRGI,$P(^(DGDRG),U,7)=$P(^(DGDRG),U,8)
I "SB"[DGS,DGSVC]"" D SET1 S $P(^(DGDRG),U,1)=$S($D(^UTILITY($J,"DGPTFR","SB",DGSVC,DGLBS,DGDRG)):$P(^(DGDRG),U,1),1:0)+DGTLOS,$P(^(DGDRG),U,2)=$P(^(DGDRG),U,2)+1 I $P(^(DGDRG),U,2)=1 S ^(DGDRG)=^(DGDRG)_U_DGDRGI
Q
DRG Q:'$D(^DGPT(DGPTF,"M",1))
S DGLBS=$P(^DGPT(DGPTF,"M",1,0),U,2),DGSVC=$S(DGLBS:$P(^DIC(42.4,+DGLBS,0),U,3),1:"") Q:DGSVC']""
S DGLOS=$S($D(^DGPT(DGPTF,"M",1,"P")):$P(^("P"),U,6),1:""),PTF=DGPTF,DGTLOS=$S($D(^DGPT(DGPTF,"M",1,"P")):$P(^("P"),U,4),1:0),DGCPT="",DGPROV=$P($G(^DGPT(DGPTF,"M",1,"P")),U,5) D EN1^DGPTFD
I $D(DRG) S DGDRG=DRG D LOS:'DGLOS,UTIL,COMP,CASEMIX K DRG Q
Q
COMP I DGTLOS,"DB"[DGS,DGDRG S Z=^UTILITY($J,"DGPTFR","D",DGDRG) D SETSUB,SETD
I DGTLOS,DGSVC]"","SB"[DGS,DGDRG,DGLBS S Z=^UTILITY($J,"DGPTFR","SB",DGSVC,DGLBS,DGDRG) D SETSUB,SETSB ;DG*5.3*375 changed the check on DGSVC
Q
SETSUB S A=$S(DGTLOS>$P(Z,U,5):"AA",1:"BA"),T=$S(DGTLOS<$P(Z,U,3)!(DGTLOS=1):"BT",DGTLOS>$P(Z,U,4):"AT",1:"WT"),DGOUT=$S(T="AT"&($P(DGDRGI,U,2)):($S(DGTLOS<366:DGTLOS,1:365)-$P(DGDRGI,U,2)),1:0),DG1D=$S(T="BT"&(DGTLOS=1):1,1:0)
S B=$S($P(Z,U,7)']"":"",DGTLOS<$P(Z,U,7):"BBE",1:"ABE"),DGPR=$S(T="BT"&(DGTLOS>1):DGTLOS,1:0)
Q
SETD F W=A,T,B I W]"" S $P(^(W),U,1)=$S($D(^UTILITY($J,"DGPTFR","D",DGDRG,W)):$P(^(W),U,1),1:0)+DGTLOS,$P(^(W),U,2)=$P(^(W),U,2)+1,$P(^(W),U,3)=$P(^(W),U,3)+DGOUT,$P(^(W),U,4)=$P(^(W),U,4)+DG1D,$P(^(W),U,5)=$P(^(W),U,5)+DGPR D:DGPR LOW
Q
LOW S $P(^(W),U,6)=$P(^UTILITY($J,"DGPTFR","D",DGDRG,W),U,6)+1 Q
SETSB F W=A,T,B I W]"" D SETSB1
Q
SETSB1 S $P(^(W),U)=$S($D(^UTILITY($J,"DGPTFR","SB",DGSVC,DGLBS,DGDRG,W)):$P(^(W),U),1:0)+DGTLOS,$P(^(W),U,2)=$P(^(W),U,2)+1,$P(^(W),U,3)=$P(^(W),U,3)+DGOUT,$P(^(W),U,4)=$P(^(W),U,4)+DG1D,$P(^(W),U,5)=$P(^(W),U,5)+DGPR D:DGPR LOW1
Q
LOW1 S $P(^(W),U,6)=$P(^UTILITY($J,"DGPTFR","SB",DGSVC,DGLBS,DGDRG,W),U,6)+1 Q
SET1 S K=DGSVC,DGSNM=$S(K="M":"MEDICINE",K="S":"SURGERY",K="P":"PSYCHIATRY",K="NE":"NEUROLOGY",K="R":"REHAB MEDICINE",K="NH":"NHCU",K="I":"INTERMEDIATE MED",K="SCI":"SPINAL CORD INJURY",K="D":"DOMICILIARY",K="B":"BLIND REHAB",1:"RESPITE CARE")
I '$G(DGLBS) S DGLBS=83 ; use Respite Care
S ^UTILITY($J,"DGPTFR","SB",DGSVC)=DGSNM,^UTILITY($J,"DGPTFR","SB",DGSVC,DGLBS)=$P(^DIC(42.4,DGLBS,0),U,1) Q
LOS S X2=$S('DGTLOS:$P(^DGPT(DGPTF,0),U,2),1:X2),X1=$S($P(^DGPT(DGPTF,"M",1,0),U,10)]"":$P(^(0),U,10),1:DT) D ^%DTC S DGTLOS=$S(X<1:1,1:X) Q
Q
CASEMIX ;
S DGWGT=$P($G(^ICD(DGDRG,"FY",DGFY2K,0)),U,2)
I DGWGT="",DGFY2K="3070000" S DGWGT=$S($D(^ICD(DGDRG,"FY",DGFY2K,0)):(^(0)),1:"")
I DGWGT="",DGFY2K="3070000" N DGFY2KSV,DGFY2KYR S DGFY2KSV=DGFY2K,DGFY2KYR=$E(DGFY2K,1,3)-1,DGFY2K=DGFY2KYR_"0000" G CASEMIX
I $G(DGFY2KSV) S DGFY2K=DGFY2KSV
S DGCNT=DGCNT+1
; next line is to avoid adding duplicates when the
; "Batch Multiple DRG Reports" option is used
Q:$D(^UTILITY("DGPTOD1","CASEMIX",DGPTF,DGCNT))
S ^UTILITY("DGPTOD1","CASEMIX",DGPTF,DGCNT)=DGDRG_U_DGWGT_U_DGSVC_U_DGLBS_U_DGPROV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTOD2 3643 printed Sep 23, 2025@20:28:51 Page 2
DGPTOD2 ;ALB/BOK - PTF DRG REPORTS, BUILD UTILITY, CONT. ; 9/14/01 5:57pm
+1 ;;5.3;Registration;**375,744**;Aug 13, 1993;Build 5
+2 SET DGCNT=0
if DGB
DO SET
if 'DGB
DO DRG
QUIT
SET FOR DGMV=0:0
SET DGMV=$ORDER(^DGPT(DGPTF,"M",DGMV))
if DGMV'>0
QUIT
IF $DATA(^DGPT(DGPTF,"M",DGMV,"P"))
SET DGPM=^("P")
SET DGTLOS=$PIECE(DGPM,U,4)
SET DGDRG=+DGPM
SET DGLBS=$PIECE(^DGPT(DGPTF,"M",DGMV,0),U,2)
SET DGSVC=$PIECE(DGPM,U,2)
SET DGPROV=$PIECE(DGPM,U,5)
IF DGDRG
DO UTIL
DO COMP
DO CASEMIX
+1 QUIT
UTIL if 'DGDRG
QUIT
if '$DATA(^UTILITY($JOB,"DRG",DGDRG))
DO WWU^DGPTOD1
SET DGDRGI=^(DGDRG)
+1 IF "DB"[DGS
SET $PIECE(^(DGDRG),U)=$SELECT($DATA(^UTILITY($JOB,"DGPTFR","D",DGDRG)):$PIECE(^(DGDRG),U),1:0)+DGTLOS
SET $PIECE(^(DGDRG),U,2)=$PIECE(^(DGDRG),U,2)+1
IF $PIECE(^(DGDRG),U,2)=1
SET ^(DGDRG)=^(DGDRG)_U_DGDRGI
SET $PIECE(^(DGDRG),U,7)=$PIECE(^(DGDRG),U,8)
+2 IF "SB"[DGS
IF DGSVC]""
DO SET1
SET $PIECE(^(DGDRG),U,1)=$SELECT($DATA(^UTILITY($JOB,"DGPTFR","SB",DGSVC,DGLBS,DGDRG)):$PIECE(^(DGDRG),U,1),1:0)+DGTLOS
SET $PIECE(^(DGDRG),U,2)=$PIECE(^(DGDRG),U,2)+1
IF $PIECE(^(DGDRG),U,2)=1
SET ^(DGDRG)=^(DGDRG)_U_DGDRGI
+3 QUIT
DRG if '$DATA(^DGPT(DGPTF,"M",1))
QUIT
+1 SET DGLBS=$PIECE(^DGPT(DGPTF,"M",1,0),U,2)
SET DGSVC=$SELECT(DGLBS:$PIECE(^DIC(42.4,+DGLBS,0),U,3),1:"")
if DGSVC']""
QUIT
+2 SET DGLOS=$SELECT($DATA(^DGPT(DGPTF,"M",1,"P")):$PIECE(^("P"),U,6),1:"")
SET PTF=DGPTF
SET DGTLOS=$SELECT($DATA(^DGPT(DGPTF,"M",1,"P")):$PIECE(^("P"),U,4),1:0)
SET DGCPT=""
SET DGPROV=$PIECE($GET(^DGPT(DGPTF,"M",1,"P")),U,5)
DO EN1^DGPTFD
+3 IF $DATA(DRG)
SET DGDRG=DRG
if 'DGLOS
DO LOS
DO UTIL
DO COMP
DO CASEMIX
KILL DRG
QUIT
+4 QUIT
COMP IF DGTLOS
IF "DB"[DGS
IF DGDRG
SET Z=^UTILITY($JOB,"DGPTFR","D",DGDRG)
DO SETSUB
DO SETD
+1 ;DG*5.3*375 changed the check on DGSVC
IF DGTLOS
IF DGSVC]""
IF "SB"[DGS
IF DGDRG
IF DGLBS
SET Z=^UTILITY($JOB,"DGPTFR","SB",DGSVC,DGLBS,DGDRG)
DO SETSUB
DO SETSB
+2 QUIT
SETSUB SET A=$SELECT(DGTLOS>$PIECE(Z,U,5):"AA",1:"BA")
SET T=$SELECT(DGTLOS<$PIECE(Z,U,3)!(DGTLOS=1):"BT",DGTLOS>$PIECE(Z,U,4):"AT",1:"WT")
SET DGOUT=$SELECT(T="AT"&($PIECE(DGDRGI,U,2)):($SELECT(DGTLOS<366:DGTLOS,1:365)-$PIECE(DGDRGI,U,2)),1:0)
SET DG1D=$SELECT(T="BT"&(DGTLOS=1):1,1:0)
+1 SET B=$SELECT($PIECE(Z,U,7)']"":"",DGTLOS<$PIECE(Z,U,7):"BBE",1:"ABE")
SET DGPR=$SELECT(T="BT"&(DGTLOS>1):DGTLOS,1:0)
+2 QUIT
SETD FOR W=A,T,B
IF W]""
SET $PIECE(^(W),U,1)=$SELECT($DATA(^UTILITY($JOB,"DGPTFR","D",DGDRG,W)):$PIECE(^(W),U,1),1:0)+DGTLOS
SET $PIECE(^(W),U,2)=$PIECE(^(W),U,2)+1
SET $PIECE(^(W),U,3)=$PIECE(^(W),U,3)+DGOUT
SET $PIECE(^(W),U,4)=$PIECE(^(W),U,4)+DG1D
SET $PIECE(^(W),U,5)=$PIECE(^(W),U,5)+DGPR
if DGPR
DO LOW
+1 QUIT
LOW SET $PIECE(^(W),U,6)=$PIECE(^UTILITY($JOB,"DGPTFR","D",DGDRG,W),U,6)+1
QUIT
SETSB FOR W=A,T,B
IF W]""
DO SETSB1
+1 QUIT
SETSB1 SET $PIECE(^(W),U)=$SELECT($DATA(^UTILITY($JOB,"DGPTFR","SB",DGSVC,DGLBS,DGDRG,W)):$PIECE(^(W),U),1:0)+DGTLOS
SET $PIECE(^(W),U,2)=$PIECE(^(W),U,2)+1
SET $PIECE(^(W),U,3)=$PIECE(^(W),U,3)+DGOUT
SET $PIECE(^(W),U,4)=$PIECE(^(W),U,4)+DG1D
SET $PIECE(^(W),U,5)=$PIECE(^(W),U,5)+DGPR
if DGPR
DO LOW1
+1 QUIT
LOW1 SET $PIECE(^(W),U,6)=$PIECE(^UTILITY($JOB,"DGPTFR","SB",DGSVC,DGLBS,DGDRG,W),U,6)+1
QUIT
SET1 SET K=DGSVC
SET DGSNM=$SELECT(K="M":"MEDICINE",K="S":"SURGERY",K="P":"PSYCHIATRY",K="NE":"NEUROLOGY",K="R":"REHAB MEDICINE",K="NH":"NHCU",K="I":"INTERMEDIATE MED",K="SCI":"SPINAL CORD INJURY",K="D":"DOMICILIARY",K="B":"BLIND REHAB",1:"RESPITE CARE")
+1 ; use Respite Care
IF '$GET(DGLBS)
SET DGLBS=83
+2 SET ^UTILITY($JOB,"DGPTFR","SB",DGSVC)=DGSNM
SET ^UTILITY($JOB,"DGPTFR","SB",DGSVC,DGLBS)=$PIECE(^DIC(42.4,DGLBS,0),U,1)
QUIT
LOS SET X2=$SELECT('DGTLOS:$PIECE(^DGPT(DGPTF,0),U,2),1:X2)
SET X1=$SELECT($PIECE(^DGPT(DGPTF,"M",1,0),U,10)]"":$PIECE(^(0),U,10),1:DT)
DO ^%DTC
SET DGTLOS=$SELECT(X<1:1,1:X)
QUIT
+1 QUIT
CASEMIX ;
+1 SET DGWGT=$PIECE($GET(^ICD(DGDRG,"FY",DGFY2K,0)),U,2)
+2 IF DGWGT=""
IF DGFY2K="3070000"
SET DGWGT=$SELECT($DATA(^ICD(DGDRG,"FY",DGFY2K,0)):(^(0)),1:"")
+3 IF DGWGT=""
IF DGFY2K="3070000"
NEW DGFY2KSV,DGFY2KYR
SET DGFY2KSV=DGFY2K
SET DGFY2KYR=$EXTRACT(DGFY2K,1,3)-1
SET DGFY2K=DGFY2KYR_"0000"
GOTO CASEMIX
+4 IF $GET(DGFY2KSV)
SET DGFY2K=DGFY2KSV
+5 SET DGCNT=DGCNT+1
+6 ; next line is to avoid adding duplicates when the
+7 ; "Batch Multiple DRG Reports" option is used
+8 if $DATA(^UTILITY("DGPTOD1","CASEMIX",DGPTF,DGCNT))
QUIT
+9 SET ^UTILITY("DGPTOD1","CASEMIX",DGPTF,DGCNT)=DGDRG_U_DGWGT_U_DGSVC_U_DGLBS_U_DGPROV
+10 QUIT
