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