DGRUGIX1 ;ALB/MLI - REPORT FOR RUG-II INDEX ; 9 FEB 88
;;5.3;Registration;**89,97,173,1015**;Aug 13, 1993;Build 21
HEAD D:$D(DG1) TRAIL S DGPG=DGPG+1 W:DGPG>1!($E(IOST,1,2)="C-") @IOF
W !?57,"RUG-II INDEX REPORT",?122,"PAGE: ",$J(DGPG,4),! W:DGX="AC" ?53 W:DGX="AA" ?57 W $S(DGX="AC":"BY ADMISSION/TRANSFER DATE",1:"BY ASSESSMENT DATE"),!?56,DGSRT,"-",DGEND,!?55,"RUN ON: ",DGNOW
W !!,?18,"RUG",?73,"ASSESSMENT",!,"LOCATION",?18,"GROUP",?25,"PATIENT NAME",?51,"SSN",?63,"DOB",?73,"DATE/PURPOSE",?87,"A/T DATE",?97,"CURRENT STATUS",?114,"CATEGORY",?128,"WWU" W ! K Y S $P(Y,"-",133)="" W Y,!!,$E($P(DGWD,U),1,15)
S DGNEW=1,DG1="" Q
1 D:(DGH'=DGWD)!($Y>(IOSL-8)) HEAD S DGI=^UTILITY($J,"I",DGWD,DGG,DFN,D) S:DGX="AA" DGAD=D,DGTD=$P(DGI,U,3) S:DGX="AC" DGTD=D,DGAD=$P(DGI,U,3) S DGN=$P(DGI,U),DGS=$P(DGI,U,2),DGP=$P(DGI,U,4),DGB=$P(DGI,U,5),DGC=$P(DGI,U,6)
S ^("TOT")=^UTILITY($J,"TOT")+1,^(DGG)=^("TOT",DGG)+1,^(DGWD)=^UTILITY($J,"W",DGWD)+1,^(DGG)=^(DGWD,DGG)+1
W:'DGNEW ! W ?18,"RUG"_DGG,?25,$E(DGN,1,20),?47,DGS,?61,$$FMTE^XLFDT(DGB,"5DZ"),?73 S X=DGAD D DT W ?82,$S(DGP=1:"A/T",DGP=2:"S-A",DGP=3:"CNH"),?87 S X=DGTD D DT W ?97 D INP^VADPT
W $S('+VAIN(4):"DISCHARGED",VAIN(6)']""!+VAIN(6):$E($P(VAIN(4),U,2),1,15),1:"**"_$E($P(VAIN(4),U,2),1,13))
W ?114,$S(DGC=1:"HEAVY REHAB",DGC=2:"SPECIAL CARE",DGC=3:"CLIN COMPLEX",DGC=4:"BEHAVIORAL",1:"PHYSICAL") D FY
S DGNEW=0,DGH=DGWD Q
Q
DT W $$FMTE^XLFDT(X,"2DZ") Q
TRAIL F I=$Y:1:(IOSL-8) W !
W !?74,"CURRENT STATUS:",?109,"** = Absent from ward",!?70,"ASSESSMENT PURPOSE:",?108,"S-A = Semi-annual census",!,?108,"A/T = Admission/transfer"
W !,?108,"CNH = Contract Nursing Home"
Q
FY K DGWWU S DGYR=$E(DGAD,1,3)_"0000" S:$E(DGAD,4,5)>9 DGYR=DGYR+10000 I $D(^DG(45.91,DGG,"FY",DGYR,0)) S DGWWU=$P(^(0),U,2)
W ?128,$S($D(DGWWU):DGWWU,1:"N/A")
Q
H K DG1 D:DGWD>0 TRAIL
S DGPG=DGPG+1 W @IOF,!,?16,"HISTOGRAM FOR"
W $S(DGWD'="":": "_DGWD,1:" ALL LOCATIONS"),?109,"PAGE:",$J(DGPG,4),!?16,"FOR PERIOD COVERING: ",DGSRT,"-",DGEND,?97,"RUN ON: ",DGNOW
W !!,?50,"PERCENTAGE OF PATIENTS IN GROUP",!! F I=1:1:9 W ?(I*10+16),I
W ! F I=1:1:9 W ?(I*10+16),"0"
K Y S $P(Y,"-",103)="" W !?16,Y I DGWD'="" S DGTOT=^UTILITY($J,"W",DGWD) F R=1:1:17 S DGSUM=^UTILITY($J,"W",DGWD,R),DGPER=DGSUM*100\DGTOT D PRINT
I DGWD="" S DGTOT=^UTILITY($J,"TOT") F R=1:1:17 S DGSUM=^UTILITY($J,"TOT",R),DGPER=DGSUM*100\DGTOT D PRINT
K Y S $P(Y,"-",103)="" W !?16,Y K DGCH,DGPER,DGSUM,DGTOT,Q Q
PRINT F Q=1:1:3 K Y S DGCH=$S(Q'=2:"=",1:"*"),$P(Y,DGCH,DGPER+1)="" W ! W:Q'=2 ?16,"|",Y W:Q=2 ?9,"RUG "_$J(R,2),?16,"|",Y," ",$J(DGSUM*100/DGTOT,7,2),"%" W ?117,"|"
Q
DATE S DGSRT=DGSD+.1,DGEND=DGED-.9,DGSRT=$$FMTE^XLFDT(DGSRT,"5DZ"),DGEND=$$FMTE^XLFDT(DGEND,"5DZ"),%DT="R",X="N" D ^%DT
S DGNOW=Y,DGNOW=$$FMTE^XLFDT(DGNOW,"5Z") Q
DGRUGIX1 ;ALB/MLI - REPORT FOR RUG-II INDEX ; 9 FEB 88
+1 ;;5.3;Registration;**89,97,173,1015**;Aug 13, 1993;Build 21
HEAD IF $DATA(DG1)
DO TRAIL
SET DGPG=DGPG+1
IF DGPG>1!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+1 WRITE !?57,"RUG-II INDEX REPORT",?122,"PAGE: ",$JUSTIFY(DGPG,4),!
IF DGX="AC"
WRITE ?53
IF DGX="AA"
WRITE ?57
WRITE $SELECT(DGX="AC":"BY ADMISSION/TRANSFER DATE",1:"BY ASSESSMENT DATE"),!?56,DGSRT,"-",DGEND,!?55,"RUN ON: ",DGNOW
+2 WRITE !!,?18,"RUG",?73,"ASSESSMENT",!,"LOCATION",?18,"GROUP",?25,"PATIENT NAME",?51,"SSN",?63,"DOB",?73,"DATE/PURPOSE",?87,"A/T DATE",?97,"CURRENT STATUS",?114,"CATEGORY",?128,"WWU"
WRITE !
KILL Y
SET $PIECE(Y,"-",133)=""
WRITE Y,!!,$EXTRACT($PIECE(DGWD,U),1,15)
+3 SET DGNEW=1
SET DG1=""
QUIT
1 IF (DGH'=DGWD)!($Y>(IOSL-8))
DO HEAD
SET DGI=^UTILITY($JOB,"I",DGWD,DGG,DFN,D)
IF DGX="AA"
SET DGAD=D
SET DGTD=$PIECE(DGI,U,3)
IF DGX="AC"
SET DGTD=D
SET DGAD=$PIECE(DGI,U,3)
SET DGN=$PIECE(DGI,U)
SET DGS=$PIECE(DGI,U,2)
SET DGP=$PIECE(DGI,U,4)
SET DGB=$PIECE(DGI,U,5)
SET DGC=$PIECE(DGI,U,6)
+1 SET ^("TOT")=^UTILITY($JOB,"TOT")+1
SET ^(DGG)=^("TOT",DGG)+1
SET ^(DGWD)=^UTILITY($JOB,"W",DGWD)+1
SET ^(DGG)=^(DGWD,DGG)+1
+2 IF 'DGNEW
WRITE !
WRITE ?18,"RUG"_DGG,?25,$EXTRACT(DGN,1,20),?47,DGS,?61,$$FMTE^XLFDT(DGB,"5DZ"),?73
SET X=DGAD
DO DT
WRITE ?82,$SELECT(DGP=1:"A/T",DGP=2:"S-A",DGP=3:"CNH"),?87
SET X=DGTD
DO DT
WRITE ?97
DO INP^VADPT
+3 WRITE $SELECT('+VAIN(4):"DISCHARGED",VAIN(6)']""!+VAIN(6):$EXTRACT($PIECE(VAIN(4),U,2),1,15),1:"**"_$EXTRACT($PIECE(VAIN(4),U,2),1,13))
+4 WRITE ?114,$SELECT(DGC=1:"HEAVY REHAB",DGC=2:"SPECIAL CARE",DGC=3:"CLIN COMPLEX",DGC=4:"BEHAVIORAL",1:"PHYSICAL")
DO FY
+5 SET DGNEW=0
SET DGH=DGWD
QUIT
+6 QUIT
DT WRITE $$FMTE^XLFDT(X,"2DZ")
QUIT
TRAIL FOR I=$Y:1:(IOSL-8)
WRITE !
+1 WRITE !?74,"CURRENT STATUS:",?109,"** = Absent from ward",!?70,"ASSESSMENT PURPOSE:",?108,"S-A = Semi-annual census",!,?108,"A/T = Admission/transfer"
+2 WRITE !,?108,"CNH = Contract Nursing Home"
+3 QUIT
FY KILL DGWWU
SET DGYR=$EXTRACT(DGAD,1,3)_"0000"
IF $EXTRACT(DGAD,4,5)>9
SET DGYR=DGYR+10000
IF $DATA(^DG(45.91,DGG,"FY",DGYR,0))
SET DGWWU=$PIECE(^(0),U,2)
+1 WRITE ?128,$SELECT($DATA(DGWWU):DGWWU,1:"N/A")
+2 QUIT
H KILL DG1
IF DGWD>0
DO TRAIL
+1 SET DGPG=DGPG+1
WRITE @IOF,!,?16,"HISTOGRAM FOR"
+2 WRITE $SELECT(DGWD'="":": "_DGWD,1:" ALL LOCATIONS"),?109,"PAGE:",$JUSTIFY(DGPG,4),!?16,"FOR PERIOD COVERING: ",DGSRT,"-",DGEND,?97,"RUN ON: ",DGNOW
+3 WRITE !!,?50,"PERCENTAGE OF PATIENTS IN GROUP",!!
FOR I=1:1:9
WRITE ?(I*10+16),I
+4 WRITE !
FOR I=1:1:9
WRITE ?(I*10+16),"0"
+5 KILL Y
SET $PIECE(Y,"-",103)=""
WRITE !?16,Y
IF DGWD'=""
SET DGTOT=^UTILITY($JOB,"W",DGWD)
FOR R=1:1:17
SET DGSUM=^UTILITY($JOB,"W",DGWD,R)
SET DGPER=DGSUM*100\DGTOT
DO PRINT
+6 IF DGWD=""
SET DGTOT=^UTILITY($JOB,"TOT")
FOR R=1:1:17
SET DGSUM=^UTILITY($JOB,"TOT",R)
SET DGPER=DGSUM*100\DGTOT
DO PRINT
+7 KILL Y
SET $PIECE(Y,"-",103)=""
WRITE !?16,Y
KILL DGCH,DGPER,DGSUM,DGTOT,Q
QUIT
PRINT FOR Q=1:1:3
KILL Y
SET DGCH=$SELECT(Q'=2:"=",1:"*")
SET $PIECE(Y,DGCH,DGPER+1)=""
WRITE !
IF Q'=2
WRITE ?16,"|",Y
IF Q=2
WRITE ?9,"RUG "_$JUSTIFY(R,2),?16,"|",Y," ",$JUSTIFY(DGSUM*100/DGTOT,7,2),"%"
WRITE ?117,"|"
+1 QUIT
DATE SET DGSRT=DGSD+.1
SET DGEND=DGED-.9
SET DGSRT=$$FMTE^XLFDT(DGSRT,"5DZ")
SET DGEND=$$FMTE^XLFDT(DGEND,"5DZ")
SET %DT="R"
SET X="N"
DO ^%DT
+1 SET DGNOW=Y
SET DGNOW=$$FMTE^XLFDT(DGNOW,"5Z")
QUIT
