- DGRUGS ;ALB/MLI,PHH - RUG-II STATUS REPORT ; 13 SEPT 88 @2000
- ;;5.3;Registration;**89,173,568,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGRUGS ;ALB/MLI,PHH - RUG-II STATUS REPORT ; 13 SEPT 88 @2000
- +1 ;;5.3;Registration;**89,173,568,1015**;Aug 13, 1993;Build 21
- +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
