45 lines
3.5 KiB
Mathematica
45 lines
3.5 KiB
Mathematica
|
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
|