Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRUGIX

DGRUGIX.m

Go to the documentation of this file.
  1. DGRUGIX ;ALB/BOK/MLI - RUG-II INDEX BY DATE ; 9 FEB 88
  1. ;;5.3;Registration;**89**;Aug 13, 1993
  1. D LO^DGUTL,Q,ASK
  1. Q W ! K %,%DT,%Y,^UTILITY($J),CT,D,DFN,DG1,DGA,DGAD,DGB,DGC,DGCT,DGD
  1. K DGED,DGEND,DGG,DGH,DGI,DGIFN,DGIN,DGLN,DGN,DGNEW,DGNOW,DGP,DGPG
  1. K DGPGM,DGPT,DGQ,DGR,DGS,DGSD,DGSRT,DGST,DGTD,DGVAR,DGW,DGWD,DGWD1
  1. K DGWR,DGX,DGYR,DGZ,DIC,I,I1,J,POP,R,DGCL,SEL,VAUTNI,VAUTSTR,VAUTVB
  1. K DGWWU,VAIN,VAUTD,VAUTN,VAUTP,VAERR,X,Y,Z,DIV
  1. D KVAR^VADPT,CLOSE^DGUTQ
  1. Q
  1. ASK S DGQ=0,X=""
  1. W !!,"Sort by (A)ssessment or (T)ransfer/Admission Date: T//" S Z="^TRANSFER/ADMISSION^ASSESSMENT"
  1. R X:DTIME
  1. Q:X["^"!('$T)
  1. I X="" S X="T" W X
  1. D IN^DGHELP
  1. I %=-1 W !!,?12,"CHOOSE FROM:",!?12,"A - Date range for the search is by Assessment Date",!?12,"T - Date range is by Transfer or admission date",! S %="" G ASK
  1. S DGX=$S(X="T":"AC",1:"AA")
  1. DAT S %DT(0)="-DT",%DT="AEPX",%DT("A")="START DATE: " D ^%DT Q:X["^" G:Y<0 DAT S DGSD=Y-.1
  1. S %DT("A")=" END DATE: ",%DT(0)=DGSD+.1,%DT="AEPX" D ^%DT Q:X["^" G:Y<0 DAT S DGED=Y_.9
  1. K DIC
  1. D ASK2^SDDIV Q:Y<0
  1. N ERR S ERR=$$CHOSE^DGRUGU1() I +ERR<0 G QUIT^DGRUGPP1
  1. S SEL=$P(ERR,"^",2)
  1. S VAUTSTR="RUG group",VAUTNI=2,VAUTVB="DGR",DIC="^DG(45.91,"
  1. D FIRST^VAUTOMA Q:Y<0
  1. S VAUTNI=2,DIC("S")="I $D(^DG(45.9,""B"",+Y))"
  1. D PATIENT^VAUTOMA Q:Y<0
  1. S DGCT=0 F J=1:0:20 W !,"Enter Category: " W:($O(DGCT(0))="") "ALL// " R X:DTIME Q:(X="")!(X="^")!('$T) W:X["?" " Enter a category or 'return' when all categories",!,"have been selected" D CL Q:(X="^")!('$T) I Y>0 S DGCT(Y)=Y(0),J=J+1
  1. Q:(X="^")!('$T)
  1. I X="",($O(DGCT(0))="") S DGCT=1
  1. OK W !!,"You have selected output for:",!!?4,$S(DGX="AA":"Assessment",1:"Transfer/Admission")," dates between "
  1. S Y=$P(DGSD,".",1)+1
  1. D DT^DIQ
  1. W " and "
  1. S Y=$P(DGED,".",1)
  1. D DT^DIQ
  1. W !,?4,"Patients: ",$S(VAUTN:"ALL",1:"") X:'VAUTN "S X=""VAUTN"" D M"
  1. I SEL="R"!(SEL="B") W !,?4,"Divisions for Wards: ",$S(VAUTD:"ALL",1:"") X:'VAUTD "S X=""VAUTD"" D M"
  1. I $D(DGW) I ($O(DGW(0))'="")!(DGW) W !?4,"Wards: ",$S(DGW:"ALL",1:"") I 'DGW S X="DGW" D M
  1. I $D(DGCL) I ($O(DGCL(0))'="")!(DGCL) W !?4,"CNH Locations: ",$S(DGCL:"ALL",1:"") I 'DGCL S X="DGCL" D M
  1. W !,?4,"RUG-II Groups: ",$S(DGR:"ALL",1:"") X:'DGR "S X=""DGR"" D M"
  1. W !,?4,"Categories: ",$S(DGCT:"ALL",1:"") I 'DGCT S X="DGCT" D M
  1. W !!,"IS THIS CORRECT" S %=1 D YN^DICN G OK:%Y["?",Q:%'=1
  1. S DGPGM="1^DGRUGIX",DGVAR="DGSD^DGED^DGR^DGX^VAUTD#^VAUTN#^DGR#^DGCT#^DGW#^DGCL#"
  1. W !!,*7,"This output requires 132 columns!",!
  1. D ZIS^DGUTQ G:POP Q
  1. U IO
  1. S X=132 X ^%ZOSF("RM")
  1. D 1,CLOSE^DGUTQ
  1. Q
  1. ;
  1. 1 D DATE^DGRUGIX1
  1. S (DGPG,DGH,^UTILITY($J,"TOT"))=0
  1. F I=1:1:17 S ^UTILITY($J,"TOT",I)=0
  1. F D=DGSD:0 S D=$O(^DG(45.9,DGX,D)) Q:D'>0!(D>DGED) F DGIFN=0:0 S DGIFN=$O(^DG(45.9,DGX,D,DGIFN)) Q:DGIFN'>0 I $D(^DG(45.9,DGIFN,0)) S DFN=$P(^(0),U) I $D(^DPT(DFN,0))&($D(VAUTN(DFN))!(VAUTN)) D CS
  1. S DGWD=0
  1. F DGWD1=0:0 D:DGWD'=0 H^DGRUGIX1 S DGWD=$O(^UTILITY($J,"I",DGWD)) Q:DGWD="" D INIT F DGG=0:0 S DGG=$O(^UTILITY($J,"I",DGWD,DGG)) Q:DGG'>0 F DFN=0:0 S DFN=$O(^UTILITY($J,"I",DGWD,DGG,DFN)) Q:DFN'>0 D CONT
  1. I '$D(^UTILITY($J,"I")) W:$E(IOST)="C" @IOF W !,"***RUG-II INDEX REPORTS--NO MATCHES FOUND***" D Q Q
  1. I $D(DGW),DGW=0 S I="",I=$O(DGW(I)),J=$O(DGW(I)) G:J="" Q
  1. D H^DGRUGIX1
  1. G Q
  1. ;
  1. CS I $D(^DG(45.9,DGIFN,"R")),$D(^("C")),($P(^("C"),U)'=5) D
  1. .S R=^("R")
  1. .I $P($G(^DG(45.9,DGIFN,0)),"^",6)'=3 Q:'$D(DGW) Q:(DGW=0)&('+$O(DGW(0))) Q:(DGR'=1)&('$D(DGR(+$P(R,U)))) S DGWD1=+$P(R,U),DGWD=$S($D(^DIC(42,+DGWD1,0)):$P(^(0),U),1:0)
  1. .I $P($G(^DG(45.9,DGIFN,0)),"^",6)=3 Q:'$D(DGCL) Q:(DGCL=0)&('+$O(DGCL(0))) Q:(DGCL'=1)&('$D(DGCL(+$P(R,U)))) S DGWD1=+$P(R,U),DGWD=$S($D(^FBAAV(+DGWD1,0)):$P(^(0),U),1:0)
  1. .Q:'$D(DGWD) ;bad pointer
  1. .S DGG=$P(R,U,2),CT=$P(R,U,4)
  1. .I DGWD'=0,DGG,CT&(DGR!($D(DGR(DGG))))&(DGCT!($D(DGCT(CT)))) D
  1. ..I $D(DGW),($P($G(^DG(45.9,DGIFN,0)),"^",6)'=3) D
  1. ...I DGW!($D(DGW(DGWD1))) I VAUTD=1!($D(VAUTD(+$P($G(^DIC(42,DGWD1,0)),"^",11)))) D S
  1. ..I $D(DGCL),($P($G(^DG(45.9,DGIFN,0)),"^",6)=3)&(DGCL)!($D(DGCL(DGWD1))) D S
  1. Q
  1. S S DGN=$E($P(^DPT(DFN,0),U),1,25),DGS=$P(^(0),U,9)
  1. S DGB=$P(^(0),U,3),DGP=$P(^DG(45.9,DGIFN,0),U,6)
  1. S:DGX="AA" DGD=$P(^(0),U,7)
  1. S:DGX="AC" DGD=$P(^(0),U,2)
  1. S ^UTILITY($J,"I",DGWD,DGG,DFN,D)=DGN_"^"_DGS_"^"_DGD_"^"_DGP_"^"_DGB_"^"_CT
  1. Q
  1. CONT F D=0:0 S D=$O(^UTILITY($J,"I",DGWD,DGG,DFN,D)) Q:D'>0 D 1^DGRUGIX1
  1. Q
  1. CL I X["?" W !,"Choose from (H)eavy Rehabilitation, (S)pecial Care, (C)linical Complex",!,"(B)ehavioral, or (P)hysical: " R X:DTIME Q:'$T
  1. S Z="^HEAVY REHABILITATION^SPECIAL CARE^CLINICAL COMPLEX^BEHAVIORAL^PHYSICAL",DGZ=Z G:X["?" CL I X="^" S DGQ=1 Q
  1. Q:X="" D IN^DGHELP I %=-1 S X="?" G CL
  1. S Y=$S(X="H":1,X="S":2,X="C":3,X="B":4,X="P":5,1:0),Y(0)=$P(DGZ,"^",Y+1) G:'Y CL
  1. Q
  1. M S I=0,I=$O(@(X_"(I)"))
  1. Q:I=""
  1. W @(X_"(I)")
  1. F I1=I:0 S I=$O(@(X_"(I)")) Q:I="" W ", ",@(X_"(I)")
  1. Q
  1. INIT S ^UTILITY($J,"W",DGWD)=0 F I=1:1:17 S ^UTILITY($J,"W",DGWD,I)=0
  1. Q