- 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 Feb 19, 2025@00:24:27 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