DGPTODI3 ;ALB/MTC - DRG INDEX(CONT),PRINT FROM ^UTILITY GLOBAL ; 8/29/01 11:08am
;;5.3;Registration;**51,158,164,375,606,744**;Aug 13, 1993;Build 5
S (DGPAG,DGAT,DGBT,DGAAL,DGTP,DG1DAY,DGTDRG,DGTP(1),DGUNIQ,SSN(1))=0,$P(DGLN,"=",132)="",$P(DGLN2,"-",132)=""
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
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:"
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)
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
L2 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
Q
LN I $Y>$S('$D(IOSL):60,1:(IOSL-6)) D HDR
S DGTP=DGTP+1,DGTDRG=DGTDRG+1 W !! W:DGP DGPT I 'DGP S DFN=$P(X,"^",2) W $P(^DPT(DFN,0),"^",1)
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
W ?66 W:DGDT=1!(DGDT=$P(X,"^",7)) "----------" I DGDT>1&(DGDT'=$P(X,"^",7)) S Y=DGDT D DT
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
W ?99 S DGSTAT=$P(X,"^",8) W $S(DGSTAT=0:"O",DGSTAT=1:"C",DGSTAT=2:"R",1:"T")
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"),"/"
I DGBS>0 W !,?103,$E($P(^DIC(42.4,DGBS,0),"^",1),1,29)
Q
FLG I DGLOS=1 S DG1DAY=DG1DAY+1 W " *" Q
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
TOT W !,DGLN,!?3,"Total: ",DGTP,!,?3,"Total Unique Patients: ",DGUNIQ S %=$S('$D(IOSL):56,1:(IOSL-10)) F I=$Y:1:% W !
W !!,"FLAGS: H - Total Above High Trim: ",DGAT," * - Total 1 Day LOS: ",DG1DAY," A - Total Above ALOS: ",DGAAL
S DRG(DRG)=DGTP,DGTP(1)=DGTP(1)+DGTP,(DGTP,DGBT,DGAT,DG1DAY,DGAAL,DGUNIQ,SSN(1))=0 W !!?64,"-",DGPAG,"-" Q
DT W $TR($$FMTE^XLFDT(Y,"5DF")," ","0") S Y="" Q
HDR W @IOF,!,"DRG INDEX FOR DRG ",DRG,?30,"Weight: "
HD1 S %=$S($D(^ICD(DRG,"FY",DGFY2K,0)):(^(0)),1:"")
I %="",DGFY2K="3070000" N DGFY2KSV,DGFY2KYR S DGFY2KSV=DGFY2K,DGFY2KYR=$E(DGFY2K,1,3)-1,DGFY2K=DGFY2KYR_"0000" G HD1
I $G(DGFY2KSV) S DGFY2K=DGFY2KSV
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
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"
;W !!,?5,"Description:" F %=0:0 S %=$O(^ICD(DRG,1,%)) Q:%'>0 W ?18,^ICD(DRG,1,%,0),!
N DXD,DGDX S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DT)
W !!,?5,"Description:" F %=0:0 S %=$O(DGDX(%)) Q:'+% Q:DGDX(%)=" " W ?18,DGDX(%),!
W !!,?44,"ADMISSION",?55,"DISCHARGE",?66,"TRANSFER",?97,"PTF",?103,"TRANSFERRING PROVIDER/"
W !,"PATIENT NAME",?33,"SSN",?44,"DATE",?55,"DATE",?66,"DATE",?77,"LOS",?91,"FLGS",?97,"STAT",?103,"LOSING SPECIALTY"
W !,DGLN S DGPAG=DGPAG+1 S:'$D(^UTILITY($J,"DGTC",DRG)) ^UTILITY($J,"DGTC",DRG,DGPAG)="" Q
PNC W !,DGNC,?9,$P(^DPT(DFN,0),"^"),?45,$P(^(0),"^",9),?63 S Y=DGDT D DT Q
HD2 W:DGPAG>0 !,?64,"-",DGPAG,"-",@IOF S DGPAG=DGPAG+1 W !,"PTF #",?9,"PATIENT NAME",?45,"SSN",?60,"ADMISSION DATE",!,DGLN Q
NC S (DGPAG,DGTP)=0
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) "
W:DGB ! W "are missing:"
D HD2
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
S:DGPAG=0 DGPAG=1 W !,DGLN,!,"Total PTF Records: ",DGTP S %=$S('$D(IOSL):60,1:IOSL-6) F I=$Y:1:% W !
W !?64,"-",DGPAG,"-",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTODI3 4333 printed Oct 16, 2024@18:53:43 Page 2
DGPTODI3 ;ALB/MTC - DRG INDEX(CONT),PRINT FROM ^UTILITY GLOBAL ; 8/29/01 11:08am
+1 ;;5.3;Registration;**51,158,164,375,606,744**;Aug 13, 1993;Build 5
+2 SET (DGPAG,DGAT,DGBT,DGAAL,DGTP,DG1DAY,DGTDRG,DGTP(1),DGUNIQ,SSN(1))=0
SET $PIECE(DGLN,"=",132)=""
SET $PIECE(DGLN2,"-",132)=""
+3 FOR DRG=0:0
if DRG>0
DO TOT
SET DRG=$ORDER(^UTILITY($JOB,"DGDRGI",DRG))
if DRG'>0
QUIT
DO HDR
SET J1=0
FOR J=0:0
SET J1=$ORDER(^UTILITY($JOB,"DGDRGI",DRG,J1))
if J1']""
QUIT
if DGP
SET DGPT=J1
if 'DGP
SET DGTD=J1
DO L2
+4 WRITE @IOF,!?61,"Summary Page",!!!,"Total combined hits for Medical Center of all DRGs: ",DGTP(1),!,"The following list gives the total hits by DRG:"
+5 SET DRG=""
FOR J=0:0
if DRG<0
QUIT
WRITE !
FOR %=1:1:8
SET DRG=$ORDER(DRG(DRG))
if DRG'>0
SET DRG=-1
if DRG'>0
QUIT
WRITE " DRG ",$JUSTIFY(DRG,3),":",$JUSTIFY(DRG(DRG),4)
+6 if $DATA(^UTILITY($JOB,"DGDRGI","DGNOCODE"))
DO NC
KILL DGAT,DGBT,DGAAL,DG1DAY,DGTDRG,DGUNIQ,DGLN,DGLN2,DGPT,DGAL,DGTD,DGDT,DGHI,DGLO,DGPAG,DGNC,DGTP,I,J,J1,K,L
QUIT
L2 FOR K=0:0
SET K=$ORDER(^UTILITY($JOB,"DGDRGI",DRG,J1,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^UTILITY($JOB,"DGDRGI",DRG,J1,K,L))
if L']""
QUIT
SET DGDT=L
SET X=^(L)
DO LN
+1 QUIT
LN IF $Y>$SELECT('$DATA(IOSL):60,1:(IOSL-6))
DO HDR
+1 SET DGTP=DGTP+1
SET DGTDRG=DGTDRG+1
WRITE !!
if DGP
WRITE DGPT
IF 'DGP
SET DFN=$PIECE(X,"^",2)
WRITE $PIECE(^DPT(DFN,0),"^",1)
+2 SET SSN(2)=$PIECE(X,"^")
WRITE ?33,SSN(2),?44
if SSN(2)'=SSN(1)
SET DGUNIQ=DGUNIQ+1
SET SSN(1)=SSN(2)
SET Y=$PIECE(X,"^",6)
DO DT
if DGD=0
WRITE ?55,"----------"
IF DGD
SET Y=$PIECE(X,"^",7)
IF Y
WRITE ?55
DO DT
+3 WRITE ?66
if DGDT=1!(DGDT=$PIECE(X,"^",7))
WRITE "----------"
IF DGDT>1&(DGDT'=$PIECE(X,"^",7))
SET Y=DGDT
DO DT
+4 WRITE ?76
SET DGLOS=$PIECE(X,"^",3)
SET DGBE=$PIECE(X,"^",9)
WRITE $JUSTIFY(DGLOS,4),?83,$JUSTIFY(DGBE,5)
IF DGLOS>0
WRITE ?91
DO FLG
+5 WRITE ?99
SET DGSTAT=$PIECE(X,"^",8)
WRITE $SELECT(DGSTAT=0:"O",DGSTAT=1:"C",DGSTAT=2:"R",1:"T")
+6 SET DGPRO=$PIECE(X,"^",4)
SET DGBS=$PIECE(X,"^",5)
WRITE ?103
if DGPRO'>0
WRITE "not specified/"
IF DGPRO>0
WRITE $SELECT($DATA(^VA(200,DGPRO,0)):$EXTRACT($PIECE(^VA(200,DGPRO,0),"^",1),1,29),1:"not specified"),"/"
+7 IF DGBS>0
WRITE !,?103,$EXTRACT($PIECE(^DIC(42.4,DGBS,0),"^",1),1,29)
+8 QUIT
FLG IF DGLOS=1
SET DG1DAY=DG1DAY+1
WRITE " *"
QUIT
+1 SET %=""
if DGBE]""&(DGLOS>DGBE)
SET DGBT=DGBT+1
SET %="B"
if DGHI]""&(DGLOS>DGHI)
SET DGAT=DGAT+1
SET %=%_"H"
if DGAL]""&(DGLOS>DGAL)
SET DGAAL=DGAAL+1
SET %=%_"A"
if %]""
WRITE $JUSTIFY(%,4)
QUIT
TOT WRITE !,DGLN,!?3,"Total: ",DGTP,!,?3,"Total Unique Patients: ",DGUNIQ
SET %=$SELECT('$DATA(IOSL):56,1:(IOSL-10))
FOR I=$Y:1:%
WRITE !
+1 WRITE !!,"FLAGS: H - Total Above High Trim: ",DGAT," * - Total 1 Day LOS: ",DG1DAY," A - Total Above ALOS: ",DGAAL
+2 SET DRG(DRG)=DGTP
SET DGTP(1)=DGTP(1)+DGTP
SET (DGTP,DGBT,DGAT,DG1DAY,DGAAL,DGUNIQ,SSN(1))=0
WRITE !!?64,"-",DGPAG,"-"
QUIT
DT WRITE $TRANSLATE($$FMTE^XLFDT(Y,"5DF")," ","0")
SET Y=""
QUIT
HDR WRITE @IOF,!,"DRG INDEX FOR DRG ",DRG,?30,"Weight: "
HD1 SET %=$SELECT($DATA(^ICD(DRG,"FY",DGFY2K,0)):(^(0)),1:"")
+1 IF %=""
IF DGFY2K="3070000"
NEW DGFY2KSV,DGFY2KYR
SET DGFY2KSV=DGFY2K
SET DGFY2KYR=$EXTRACT(DGFY2K,1,3)-1
SET DGFY2K=DGFY2KYR_"0000"
GOTO HD1
+2 IF $GET(DGFY2KSV)
SET DGFY2K=DGFY2KSV
+3 WRITE $PIECE(%,"^",2),?46,"Low Trim: "
SET DGLO=$PIECE(%,"^",3)
SET DGHI=$PIECE(%,"^",4)
SET DGAL=$PIECE(%,"^",9)
WRITE DGLO,?60,"High Trim: ",DGHI,?76,"Avg LOS: ",DGAL
+4 WRITE ?105,"PRINTED: "
SET Y=DT
XECUTE ^DD("DD")
WRITE Y,!?3,"For ",$SELECT(DGD:"Discharge Dates from: ",1:"Active Admissions")
IF DGD
SET Y=DGSD+.1
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," to "
SET Y=DGED
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")
IF DGB
WRITE " including TRANSFER DRGs"
+5 ;W !!,?5,"Description:" F %=0:0 S %=$O(^ICD(DRG,1,%)) Q:%'>0 W ?18,^ICD(DRG,1,%,0),!
+6 NEW DXD,DGDX
SET DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DT)
+7 WRITE !!,?5,"Description:"
FOR %=0:0
SET %=$ORDER(DGDX(%))
if '+%
QUIT
if DGDX(%)=" "
QUIT
WRITE ?18,DGDX(%),!
+8 WRITE !!,?44,"ADMISSION",?55,"DISCHARGE",?66,"TRANSFER",?97,"PTF",?103,"TRANSFERRING PROVIDER/"
+9 WRITE !,"PATIENT NAME",?33,"SSN",?44,"DATE",?55,"DATE",?66,"DATE",?77,"LOS",?91,"FLGS",?97,"STAT",?103,"LOSING SPECIALTY"
+10 WRITE !,DGLN
SET DGPAG=DGPAG+1
if '$DATA(^UTILITY($JOB,"DGTC",DRG))
SET ^UTILITY($JOB,"DGTC",DRG,DGPAG)=""
QUIT
PNC WRITE !,DGNC,?9,$PIECE(^DPT(DFN,0),"^"),?45,$PIECE(^(0),"^",9),?63
SET Y=DGDT
DO DT
QUIT
HD2 if DGPAG>0
WRITE !,?64,"-",DGPAG,"-",@IOF
SET DGPAG=DGPAG+1
WRITE !,"PTF #",?9,"PATIENT NAME",?45,"SSN",?60,"ADMISSION DATE",!,DGLN
QUIT
NC SET (DGPAG,DGTP)=0
+1 WRITE @IOF,"A ",$SELECT(DGB:"transfer ",1:""),"DRG can not be computed for 1 or more movement(s) associated with the following PTF records because ",$SELECT(DGB:"transfer ",1:""),"ICD code(s) "
+2 if DGB
WRITE !
WRITE "are missing:"
+3 DO HD2
+4 FOR DGNC=0:0
SET DGNC=$ORDER(^UTILITY($JOB,"DGDRGI","DGNOCODE",DGNC))
if DGNC'>0
QUIT
SET DGTP=DGTP+1
SET DFN=+^UTILITY($JOB,"DGDRGI","DGNOCODE",DGNC)
SET DGDT=$PIECE(^(DGNC),"^",2)
DO PNC
if $Y>$SELECT('$DATA(IOSL)
DO HD2
+5 if DGPAG=0
SET DGPAG=1
WRITE !,DGLN,!,"Total PTF Records: ",DGTP
SET %=$SELECT('$DATA(IOSL):60,1:IOSL-6)
FOR I=$Y:1:%
WRITE !
+6 WRITE !?64,"-",DGPAG,"-",!
QUIT
