- 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 Feb 19, 2025@00:19:01 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