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

Last change on this file since 794 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1DGPTODI3 ;ALB/MTC - DRG INDEX(CONT),PRINT FROM ^UTILITY GLOBAL ; 8/29/01 11:08am
2 ;;5.3;Registration;**51,158,164,375,606,744**;Aug 13, 1993;Build 5
3 S (DGPAG,DGAT,DGBT,DGAAL,DGTP,DG1DAY,DGTDRG,DGTP(1),DGUNIQ,SSN(1))=0,$P(DGLN,"=",132)="",$P(DGLN2,"-",132)=""
4 F DRG=0:0 D:DRG>0 TOT S DRG=$O(^UTILITY($J,"DGDRGI",DRG)) Q:DRG'>0 D HDR S J1=0 F J=0:0 S J1=$O(^UTILITY($J,"DGDRGI",DRG,J1)) Q:J1']"" S:DGP DGPT=J1 S:'DGP DGTD=J1 D L2
5 W @IOF,!?61,"Summary Page",!!!,"Total combined hits for Medical Center of all DRGs: ",DGTP(1),!,"The following list gives the total hits by DRG:"
6 S DRG="" F J=0:0 Q:DRG<0 W ! F %=1:1:8 S DRG=$O(DRG(DRG)) S:DRG'>0 DRG=-1 Q:DRG'>0 W " DRG ",$J(DRG,3),":",$J(DRG(DRG),4)
7 D:$D(^UTILITY($J,"DGDRGI","DGNOCODE")) NC K DGAT,DGBT,DGAAL,DG1DAY,DGTDRG,DGUNIQ,DGLN,DGLN2,DGPT,DGAL,DGTD,DGDT,DGHI,DGLO,DGPAG,DGNC,DGTP,I,J,J1,K,L Q
8L2 F K=0:0 S K=$O(^UTILITY($J,"DGDRGI",DRG,J1,K)) Q:K'>0 F L=0:0 S L=$O(^UTILITY($J,"DGDRGI",DRG,J1,K,L)) Q:L']"" S DGDT=L,X=^(L) D LN
9 Q
10LN I $Y>$S('$D(IOSL):60,1:(IOSL-6)) D HDR
11 S DGTP=DGTP+1,DGTDRG=DGTDRG+1 W !! W:DGP DGPT I 'DGP S DFN=$P(X,"^",2) W $P(^DPT(DFN,0),"^",1)
12 S SSN(2)=$P(X,"^") W ?33,SSN(2),?44 S:SSN(2)'=SSN(1) DGUNIQ=DGUNIQ+1,SSN(1)=SSN(2) S Y=$P(X,"^",6) D DT W:DGD=0 ?55,"----------" I DGD S Y=$P(X,"^",7) I Y W ?55 D DT
13 W ?66 W:DGDT=1!(DGDT=$P(X,"^",7)) "----------" I DGDT>1&(DGDT'=$P(X,"^",7)) S Y=DGDT D DT
14 W ?76 S DGLOS=$P(X,"^",3),DGBE=$P(X,"^",9) W $J(DGLOS,4),?83,$J(DGBE,5) I DGLOS>0 W ?91 D FLG
15 W ?99 S DGSTAT=$P(X,"^",8) W $S(DGSTAT=0:"O",DGSTAT=1:"C",DGSTAT=2:"R",1:"T")
16 S DGPRO=$P(X,"^",4),DGBS=$P(X,"^",5) W ?103 W:DGPRO'>0 "not specified/" I DGPRO>0 W $S($D(^VA(200,DGPRO,0)):$E($P(^VA(200,DGPRO,0),"^",1),1,29),1:"not specified"),"/"
17 I DGBS>0 W !,?103,$E($P(^DIC(42.4,DGBS,0),"^",1),1,29)
18 Q
19FLG I DGLOS=1 S DG1DAY=DG1DAY+1 W " *" Q
20 S %="" S:DGBE]""&(DGLOS>DGBE) DGBT=DGBT+1,%="B" S:DGHI]""&(DGLOS>DGHI) DGAT=DGAT+1,%=%_"H" S:DGAL]""&(DGLOS>DGAL) DGAAL=DGAAL+1,%=%_"A" W:%]"" $J(%,4) Q
21TOT W !,DGLN,!?3,"Total: ",DGTP,!,?3,"Total Unique Patients: ",DGUNIQ S %=$S('$D(IOSL):56,1:(IOSL-10)) F I=$Y:1:% W !
22 W !!,"FLAGS: H - Total Above High Trim: ",DGAT," * - Total 1 Day LOS: ",DG1DAY," A - Total Above ALOS: ",DGAAL
23 S DRG(DRG)=DGTP,DGTP(1)=DGTP(1)+DGTP,(DGTP,DGBT,DGAT,DG1DAY,DGAAL,DGUNIQ,SSN(1))=0 W !!?64,"-",DGPAG,"-" Q
24DT W $TR($$FMTE^XLFDT(Y,"5DF")," ","0") S Y="" Q
25HDR W @IOF,!,"DRG INDEX FOR DRG ",DRG,?30,"Weight: "
26HD1 S %=$S($D(^ICD(DRG,"FY",DGFY2K,0)):(^(0)),1:"")
27 I %="",DGFY2K="3070000" N DGFY2KSV,DGFY2KYR S DGFY2KSV=DGFY2K,DGFY2KYR=$E(DGFY2K,1,3)-1,DGFY2K=DGFY2KYR_"0000" G HD1
28 I $G(DGFY2KSV) S DGFY2K=DGFY2KSV
29 W $P(%,"^",2),?46,"Low Trim: " S DGLO=$P(%,"^",3),DGHI=$P(%,"^",4),DGAL=$P(%,"^",9) W DGLO,?60,"High Trim: ",DGHI,?76,"Avg LOS: ",DGAL
30 W ?105,"PRINTED: " S Y=DT X ^DD("DD") W Y,!?3,"For ",$S(DGD:"Discharge Dates from: ",1:"Active Admissions") I DGD S Y=DGSD+.1 X ^DD("DD") W $P(Y,"@")," to " S Y=DGED X ^DD("DD") W $P(Y,"@") I DGB W " including TRANSFER DRGs"
31 ;W !!,?5,"Description:" F %=0:0 S %=$O(^ICD(DRG,1,%)) Q:%'>0 W ?18,^ICD(DRG,1,%,0),!
32 N DXD,DGDX S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DT)
33 W !!,?5,"Description:" F %=0:0 S %=$O(DGDX(%)) Q:'+% Q:DGDX(%)=" " W ?18,DGDX(%),!
34 W !!,?44,"ADMISSION",?55,"DISCHARGE",?66,"TRANSFER",?97,"PTF",?103,"TRANSFERRING PROVIDER/"
35 W !,"PATIENT NAME",?33,"SSN",?44,"DATE",?55,"DATE",?66,"DATE",?77,"LOS",?91,"FLGS",?97,"STAT",?103,"LOSING SPECIALTY"
36 W !,DGLN S DGPAG=DGPAG+1 S:'$D(^UTILITY($J,"DGTC",DRG)) ^UTILITY($J,"DGTC",DRG,DGPAG)="" Q
37PNC W !,DGNC,?9,$P(^DPT(DFN,0),"^"),?45,$P(^(0),"^",9),?63 S Y=DGDT D DT Q
38HD2 W:DGPAG>0 !,?64,"-",DGPAG,"-",@IOF S DGPAG=DGPAG+1 W !,"PTF #",?9,"PATIENT NAME",?45,"SSN",?60,"ADMISSION DATE",!,DGLN Q
39NC S (DGPAG,DGTP)=0
40 W @IOF,"A ",$S(DGB:"transfer ",1:""),"DRG can not be computed for 1 or more movement(s) associated with the following PTF records because ",$S(DGB:"transfer ",1:""),"ICD code(s) "
41 W:DGB ! W "are missing:"
42 D HD2
43 F DGNC=0:0 S DGNC=$O(^UTILITY($J,"DGDRGI","DGNOCODE",DGNC)) Q:DGNC'>0 S DGTP=DGTP+1,DFN=+^UTILITY($J,"DGDRGI","DGNOCODE",DGNC),DGDT=$P(^(DGNC),"^",2) D PNC D:$Y>$S('$D(IOSL):58,1:(IOSL-8)) HD2
44 S:DGPAG=0 DGPAG=1 W !,DGLN,!,"Total PTF Records: ",DGTP S %=$S('$D(IOSL):60,1:IOSL-6) F I=$Y:1:% W !
45 W !?64,"-",DGPAG,"-",! Q
Note: See TracBrowser for help on using the repository browser.