source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTOD2.m@ 1742

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