DGRUGS ;ALB/MLI,PHH - RUG-II STATUS REPORT ; 13 SEPT 88 @2000
;;5.3;Registration;**89,173,568**;Aug 13, 1993
;
EN D Q,ASK2^SDDIV G:Y<0 Q
N ERR S ERR=$$CHOSE^DGRUGU1()
I +ERR<0 G Q
I $D(DGCL),$D(DGW) I '+$O(DGCL(0))&(+'$O(DGW(0)))&(DGW'=1)&(DGCL'=1) Q
S SEL=$P(ERR,"^",2)
ASK W !!,"Sort by (A)ssessment or (T)ransfer/Admission Date: T//" S Z="^TRANSFER/ADMISSION^ASSESSMENT" R X:DTIME G 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")
D DATE^DGSDUTL G:POP Q K BEGDATE,ENDATE
S DGB=SDBD-.1,DGE=SDED+.9
S DGPGM="1^DGRUGS",DGVAR="VAUTD#^DGW#^DGB^DGE^DGX^DGCL#"
D ZIS^DGUTQ G:POP Q
1 U IO S I=DGB
F S I=$O(^DG(45.9,DGX,I)) Q:I'>0!(I>DGE) D
.S J=""
.F S J=$O(^DG(45.9,DGX,I,J)) Q:J'>0!'$D(^DG(45.9,+J,0))!'$D(^("R"))!'$D(^("C")) D
..S DGR=^("R"),DG0=^(0),DGC=^("C"),DGWD=$P(DGR,"^")
..I $P(DG0,"^",6)'=3,$D(^DIC(42,+DGWD,0)) S DGS=^(0) D S
..I $P(DG0,"^",6)=3,$D(^FBAAV(+DGWD,0)) S DGS=^(0) D S
S (DGNEW,DGPG)=0,I="" D NOW^DGPTOTRL
S DGFL=0,FIRST=1
F S I=$O(^UTILITY($J,"S",I)) Q:I=""!(DGFL) D
.D HD
.S FIRST=FIRST+1
.Q:DGFL
.S J=""
.F S DGHJ=J,J=$O(^UTILITY($J,"S",I,J)) Q:J=""!(DGFL) D
..S K=""
..F S K=$O(^UTILITY($J,"S",I,J,K)) Q:K=""!(DGFL) D
...S L=""
...F S L=$O(^UTILITY($J,"S",I,J,K,L)) Q:L=""!(DGFL) D
....D PT
....Q:DGFL
Q W ! K %,^UTILITY($J),DG0,DGAD,DGAS,DGB,DGC,DGDV,DGE,DGHJ,DFN,DGFL
K DGNEW,DGNM,DGNOW,DGPG,DGPGM,DGR,DGS,DGSSN,DGVAR,DGW,DGWD,DGWN,DGX
K DGYR,ENDDATE,I,J,K,L,M,PG,SDBD,SDED,X,Y,VAUTD,Z,FIRST,DGCL,SEL
D CLOSE^DGUTQ
Q
S S DGWN=$P(DGS,"^") ;ward or cnh name
I $P(DG0,"^",6)'=3 S DGDV=$S($P(DGS,"^",11)]"":$P(DGS,"^",11),1:$O(^DG(40.8,0))) Q:'VAUTD&'$D(VAUTD(+DGDV))
I $P(DG0,"^",6)'=3 Q:'$D(DGW) Q:'DGW&'$D(DGW(+DGWD))
I $P(DG0,"^",6)=3 Q:'$D(DGCL) Q:'DGCL&'$D(DGCL(+DGWD))
Q:'$D(^DPT($P(DG0,"^"),0))
S DGNM=$P(^(0),"^"),DGSSN=$S($P(^(0),"^",9)]"":$P(^(0),"^",9),1:0)
S DGS=$P(DGC,"^")
S DGS=$S(DGS=1:"COMPLETED",DGS=2:"CLOSED",DGS=3:"RELEASED",DGS=4:"TRANSMITTED",DGS=5:"INCOMPLETE",DGS=0:"OPEN",1:"UNSPECIFIED")
S DGAS=$P(DG0,"^",2)
S ^UTILITY($J,"S",DGWN,DGS,DGNM,DGSSN,DGAS)=$P(DG0,"^",2)_"^"_$P(DG0,"^",6)_"^"_$P(DG0,"^",7)_"^"_$P(DGR,"^",2)_"^"_$P(DGR,"^",3)
Q
PT F M=0:0 S M=$O(^UTILITY($J,"S",I,J,K,L,M)) Q:'M D
.S DG0=^UTILITY($J,"S",I,J,K,L,M)
.W ! W:DGHJ'=J!DGNEW !,$E(J,1,6)
.S DGHJ=J
.W ?10,$E(K,1,15),?27,L,?41
.W $$FMTE^XLFDT($P(DG0,"^"),"5DZ")
.W " ",$S($P(DG0,"^",2)=1:"A/T",$P(DG0,"^",2)=2:"S-A",$P(DG0,"^",2)=3:"CNH")
.D W
Q
W W ?58,$$FMTE^XLFDT($P(DG0,U,3),"5DZ")
W ?71,$J($P(DG0,"^",5),2),?76,$J($P(DG0,"^",4),2)
D FY
S DGNEW=0
I $Y>(IOSL-6)&($O(^UTILITY($J,"S",I,J,K))'="") D HD S DGNEW=1
Q
HD D END
Q:DGFL
S DGPG=DGPG+1
I FIRST>1!($E(IOST)="C") W @IOF
W !?28,"RUG-II RECORD STATUS REPORT",!?30,$$FMTE^XLFDT(DGB+.1,"5DZ")," - ",$$FMTE^XLFDT(DGE,"5DZ"),!?32,"RUN: ",DGNOW,!!,"LOCATION: ",I,?71,"PAGE: ",$J(DGPG,3)
W !!,"RECORD",?13,"PATIENT",?42,"ASSESSMENT",?70,"ADL",!,"STATUS",?13,"NAME",?30,"SSN",?42,"DATE/PURPOSE",?58,"A/T DATE",?70,"SUM",?75,"RUG",?81,"WWU" K X S $P(X,"_",85)="" W !,X,!
Q
END S DGFL=0
Q:'DGPG!($E(IOST)'="C")
F PG=$Y:1:(IOSL-6) W !
R !!,"Enter <RETURN> to continue, '^' to halt",X:DTIME
S:(X["^")!('$T) DGFL=1
Q
FY Q:'$P(DG0,"^",4)
K DGWWU
S DGAD=$P(DG0,"^",1),DGYR=$E(DGAD,1,3)_"0000"
S:$E(DGAD,4,5)>9 DGYR=DGYR+10000
W ?80,$J($S($D(^DG(45.91,$P(DG0,"^",4),"FY",DGYR,0)):$P(^(0),"^",2),1:"N/A"),4)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGS 3634 printed Nov 22, 2024@18:08:31 Page 2
DGRUGS ;ALB/MLI,PHH - RUG-II STATUS REPORT ; 13 SEPT 88 @2000
+1 ;;5.3;Registration;**89,173,568**;Aug 13, 1993
+2 ;
EN DO Q
DO ASK2^SDDIV
if Y<0
GOTO Q
+1 NEW ERR
SET ERR=$$CHOSE^DGRUGU1()
+2 IF +ERR<0
GOTO Q
+3 IF $DATA(DGCL)
IF $DATA(DGW)
IF '+$ORDER(DGCL(0))&(+'$ORDER(DGW(0)))&(DGW'=1)&(DGCL'=1)
QUIT
+4 SET SEL=$PIECE(ERR,"^",2)
ASK WRITE !!,"Sort by (A)ssessment or (T)ransfer/Admission Date: T//"
SET Z="^TRANSFER/ADMISSION^ASSESSMENT"
READ X:DTIME
if X["^"!('$TEST)
GOTO Q
IF X=""
SET X="T"
WRITE X
+1 DO IN^DGHELP
+2 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
+3 SET DGX=$SELECT(X="T":"AC",1:"AA")
+4 DO DATE^DGSDUTL
if POP
GOTO Q
KILL BEGDATE,ENDATE
+5 SET DGB=SDBD-.1
SET DGE=SDED+.9
+6 SET DGPGM="1^DGRUGS"
SET DGVAR="VAUTD#^DGW#^DGB^DGE^DGX^DGCL#"
+7 DO ZIS^DGUTQ
if POP
GOTO Q
1 USE IO
SET I=DGB
+1 FOR
SET I=$ORDER(^DG(45.9,DGX,I))
if I'>0!(I>DGE)
QUIT
Begin DoDot:1
+2 SET J=""
+3 FOR
SET J=$ORDER(^DG(45.9,DGX,I,J))
if J'>0!'$DATA(^DG(45.9,+J,0))!'$DATA(^("R"))!'$DATA(^("C"))
QUIT
Begin DoDot:2
+4 SET DGR=^("R")
SET DG0=^(0)
SET DGC=^("C")
SET DGWD=$PIECE(DGR,"^")
+5 IF $PIECE(DG0,"^",6)'=3
IF $DATA(^DIC(42,+DGWD,0))
SET DGS=^(0)
DO S
+6 IF $PIECE(DG0,"^",6)=3
IF $DATA(^FBAAV(+DGWD,0))
SET DGS=^(0)
DO S
End DoDot:2
End DoDot:1
+7 SET (DGNEW,DGPG)=0
SET I=""
DO NOW^DGPTOTRL
+8 SET DGFL=0
SET FIRST=1
+9 FOR
SET I=$ORDER(^UTILITY($JOB,"S",I))
if I=""!(DGFL)
QUIT
Begin DoDot:1
+10 DO HD
+11 SET FIRST=FIRST+1
+12 if DGFL
QUIT
+13 SET J=""
+14 FOR
SET DGHJ=J
SET J=$ORDER(^UTILITY($JOB,"S",I,J))
if J=""!(DGFL)
QUIT
Begin DoDot:2
+15 SET K=""
+16 FOR
SET K=$ORDER(^UTILITY($JOB,"S",I,J,K))
if K=""!(DGFL)
QUIT
Begin DoDot:3
+17 SET L=""
+18 FOR
SET L=$ORDER(^UTILITY($JOB,"S",I,J,K,L))
if L=""!(DGFL)
QUIT
Begin DoDot:4
+19 DO PT
+20 if DGFL
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
Q WRITE !
KILL %,^UTILITY($JOB),DG0,DGAD,DGAS,DGB,DGC,DGDV,DGE,DGHJ,DFN,DGFL
+1 KILL DGNEW,DGNM,DGNOW,DGPG,DGPGM,DGR,DGS,DGSSN,DGVAR,DGW,DGWD,DGWN,DGX
+2 KILL DGYR,ENDDATE,I,J,K,L,M,PG,SDBD,SDED,X,Y,VAUTD,Z,FIRST,DGCL,SEL
+3 DO CLOSE^DGUTQ
+4 QUIT
S ;ward or cnh name
SET DGWN=$PIECE(DGS,"^")
+1 IF $PIECE(DG0,"^",6)'=3
SET DGDV=$SELECT($PIECE(DGS,"^",11)]"":$PIECE(DGS,"^",11),1:$ORDER(^DG(40.8,0)))
if 'VAUTD&'$DATA(VAUTD(+DGDV))
QUIT
+2 IF $PIECE(DG0,"^",6)'=3
if '$DATA(DGW)
QUIT
if 'DGW&'$DATA(DGW(+DGWD))
QUIT
+3 IF $PIECE(DG0,"^",6)=3
if '$DATA(DGCL)
QUIT
if 'DGCL&'$DATA(DGCL(+DGWD))
QUIT
+4 if '$DATA(^DPT($PIECE(DG0,"^"),0))
QUIT
+5 SET DGNM=$PIECE(^(0),"^")
SET DGSSN=$SELECT($PIECE(^(0),"^",9)]"":$PIECE(^(0),"^",9),1:0)
+6 SET DGS=$PIECE(DGC,"^")
+7 SET DGS=$SELECT(DGS=1:"COMPLETED",DGS=2:"CLOSED",DGS=3:"RELEASED",DGS=4:"TRANSMITTED",DGS=5:"INCOMPLETE",DGS=0:"OPEN",1:"UNSPECIFIED")
+8 SET DGAS=$PIECE(DG0,"^",2)
+9 SET ^UTILITY($JOB,"S",DGWN,DGS,DGNM,DGSSN,DGAS)=$PIECE(DG0,"^",2)_"^"_$PIECE(DG0,"^",6)_"^"_$PIECE(DG0,"^",7)_"^"_$PIECE(DGR,"^",2)_"^"_$PIECE(DGR,"^",3)
+10 QUIT
PT FOR M=0:0
SET M=$ORDER(^UTILITY($JOB,"S",I,J,K,L,M))
if 'M
QUIT
Begin DoDot:1
+1 SET DG0=^UTILITY($JOB,"S",I,J,K,L,M)
+2 WRITE !
if DGHJ'=J!DGNEW
WRITE !,$EXTRACT(J,1,6)
+3 SET DGHJ=J
+4 WRITE ?10,$EXTRACT(K,1,15),?27,L,?41
+5 WRITE $$FMTE^XLFDT($PIECE(DG0,"^"),"5DZ")
+6 WRITE " ",$SELECT($PIECE(DG0,"^",2)=1:"A/T",$PIECE(DG0,"^",2)=2:"S-A",$PIECE(DG0,"^",2)=3:"CNH")
+7 DO W
End DoDot:1
+8 QUIT
W WRITE ?58,$$FMTE^XLFDT($PIECE(DG0,U,3),"5DZ")
+1 WRITE ?71,$JUSTIFY($PIECE(DG0,"^",5),2),?76,$JUSTIFY($PIECE(DG0,"^",4),2)
+2 DO FY
+3 SET DGNEW=0
+4 IF $Y>(IOSL-6)&($ORDER(^UTILITY($JOB,"S",I,J,K))'="")
DO HD
SET DGNEW=1
+5 QUIT
HD DO END
+1 if DGFL
QUIT
+2 SET DGPG=DGPG+1
+3 IF FIRST>1!($EXTRACT(IOST)="C")
WRITE @IOF
+4 WRITE !?28,"RUG-II RECORD STATUS REPORT",!?30,$$FMTE^XLFDT(DGB+.1,"5DZ")," - ",$$FMTE^XLFDT(DGE,"5DZ"),!?32,"RUN: ",DGNOW,!!,"LOCATION: ",I,?71,"PAGE: ",$JUSTIFY(DGPG,3)
+5 WRITE !!,"RECORD",?13,"PATIENT",?42,"ASSESSMENT",?70,"ADL",!,"STATUS",?13,"NAME",?30,"SSN",?42,"DATE/PURPOSE",?58,"A/T DATE",?70,"SUM",?75,"RUG",?81,"WWU"
KILL X
SET $PIECE(X,"_",85)=""
WRITE !,X,!
+6 QUIT
END SET DGFL=0
+1 if 'DGPG!($EXTRACT(IOST)'="C")
QUIT
+2 FOR PG=$Y:1:(IOSL-6)
WRITE !
+3 READ !!,"Enter <RETURN> to continue, '^' to halt",X:DTIME
+4 if (X["^")!('$TEST)
SET DGFL=1
+5 QUIT
FY if '$PIECE(DG0,"^",4)
QUIT
+1 KILL DGWWU
+2 SET DGAD=$PIECE(DG0,"^",1)
SET DGYR=$EXTRACT(DGAD,1,3)_"0000"
+3 if $EXTRACT(DGAD,4,5)>9
SET DGYR=DGYR+10000
+4 WRITE ?80,$JUSTIFY($SELECT($DATA(^DG(45.91,$PIECE(DG0,"^",4),"FY",DGYR,0)):$PIECE(^(0),"^",2),1:"N/A"),4)
+5 QUIT
